{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonadFailDesugaring #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module DeckGo.Handler where

-- TODO: nullable slide content
-- TODO: feed API

-- TODO: check permissions
-- TODO: TTL on anonymous users
-- TODO: get rid of anonymous users

import Control.Applicative
import Control.Lens hiding ((.=))
import Control.Monad
import Control.Monad.Except
import Data.ByteArray.Encoding (convertToBase, Base (Base64))
import Data.Aeson ((.=), (.:), (.!=), (.:?))
import Data.Bifunctor
import Data.Char
import Data.Int
import Data.List (find)
import Data.List (foldl')
import Data.Maybe
import Data.Proxy
import Data.String
import Data.Swagger hiding (Tag)
import DeckGo.Prelude
import GHC.Generics
import Hasql.Statement (Statement(..))
import Servant (Context ((:.)))
import Servant.API
import Servant.Auth.Firebase (Protected)
import System.Environment
import System.FilePath
import UnliftIO
import qualified Cases
import qualified Codec.Archive.Zip as Zip
import qualified Crypto.Hash as Hash
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.HashMap.Strict as HMS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Hasql.Connection as HC
import qualified Hasql.Decoders as HD
import qualified Hasql.Encoders as HE
import qualified Hasql.Session as HS
import qualified Network.AWS as AWS
import qualified Network.AWS.Data.Body as Body
import qualified Network.AWS.S3 as S3
import qualified Network.AWS.SQS as SQS
import qualified Network.Mime as Mime
import qualified Network.Wai as Wai
import qualified Servant as Servant
import qualified Servant.Auth.Firebase as Firebase
import qualified System.Directory as Dir
import qualified System.IO.Temp as Temp
import qualified System.Random as Random
import qualified Text.HTML.TagSoup as TagSoup

------------------------------------------------------------------------------
-- API
------------------------------------------------------------------------------

-- COMMON

data Item id a = Item { itemId :: id, itemContent :: a }
  deriving (Show, Eq, Generic)

class ToJSONObject a where
  toJSONObject :: a -> Aeson.Object

instance (Aeson.ToJSON id, ToJSONObject a) => Aeson.ToJSON (Item id a) where
  toJSON i = Aeson.Object $
    HMS.fromList [ "id" .= itemId i ] <>
    toJSONObject (itemContent i)

class FromJSONObject a where
  parseJSONObject :: Aeson.Object -> Aeson.Parser a

instance (Aeson.FromJSON id, FromJSONObject a) => Aeson.FromJSON (Item id a) where
  parseJSON = Aeson.withObject "FromJSONObject" $ \o -> Item <$>
    o .: "id" <*> parseJSONObject o

-- USERS

type UsersAPI =
    Get '[JSON] [Item UserId User] :<|>
    Capture "user_id" UserId :> Get '[JSON] (Item UserId User) :<|>
    Protected :>
      ReqBody '[JSON] UserInfo :>
      Post '[JSON] (Item UserId User) :<|>
    Protected :>
      Capture "user_id" UserId :>
      ReqBody '[JSON] User :> Put '[JSON] (Item UserId User) :<|>
    Protected :> Capture "user_id" UserId :> Delete '[JSON] ()

newtype Username = Username { unUsername :: T.Text }
  deriving stock (Show, Eq)
  deriving newtype (Aeson.FromJSON, Aeson.ToJSON)

data UserInfo = UserInfo
  { userInfoFirebaseId :: FirebaseId
  , userInfoEmail :: Maybe T.Text
  } deriving (Show, Eq)

data User = User
  { userFirebaseId :: FirebaseId
  , userUsername :: Maybe Username -- + return anonymous
  } deriving (Show, Eq)

newtype UserId = UserId { unUserId :: FirebaseId }
  deriving newtype
    ( Aeson.FromJSON
    , Aeson.ToJSON
    , FromHttpApiData
    , ToHttpApiData
    , Show
    , Eq
    )
  deriving stock
    ( Generic )

newtype FirebaseId = FirebaseId { unFirebaseId :: T.Text }
  deriving newtype
    ( Aeson.FromJSON
    , Aeson.ToJSON
    , FromHttpApiData
    , ToHttpApiData
    , Show
    , Eq
    )
  deriving stock
    ( Generic )

-- XXX !!?!??!?!! pattern match failures are propagated to the client!!!
instance FromJSONObject UserInfo where
  parseJSONObject = \obj ->
    UserInfo
      <$> obj .: "firebase_uid"
      <*> (
        (do
          True <- obj .: "anonymous"
          (Nothing :: Maybe T.Text) <- obj .:? "email"
          pure Nothing
        ) <|> (do
          False <- obj .: "anonymous"
          obj .:? "email"
        )
        )

instance Aeson.FromJSON User where
  parseJSON = Aeson.withObject "User" parseJSONObject

instance FromJSONObject User where
  parseJSONObject = \obj ->
    User
      <$> obj .: "firebase_uid"
      <*> (
        (do
          True <- obj .: "anonymous"
          (Nothing :: Maybe Username) <- obj .:? "username"
          pure Nothing
        ) <|> (do
          False <- obj .: "anonymous"
          obj .:? "username"
        )
        )

instance ToJSONObject UserInfo where
  toJSONObject uinfo = HMS.fromList
    [ "anonymous" .= isNothing (userInfoEmail uinfo)
    , "email" .= userInfoEmail uinfo
    , "firebase_uid" .= userInfoFirebaseId uinfo
    ]

instance Aeson.ToJSON User where
  toJSON = Aeson.Object . toJSONObject

instance Aeson.FromJSON UserInfo where
  parseJSON = Aeson.withObject "UserInfo" parseJSONObject

instance ToJSONObject User where
  toJSONObject user = HMS.fromList
    [ "anonymous" .= isNothing (userUsername user)
    , "username" .= userUsername user
    , "firebase_uid" .= userFirebaseId user
    ]

instance Aeson.ToJSON UserInfo where
  toJSON = Aeson.Object . toJSONObject

instance ToSchema (Item UserId User) where
  declareNamedSchema _ = pure $ NamedSchema (Just "UserWithId") mempty

instance ToSchema PresResponse where
  declareNamedSchema _ = pure $ NamedSchema (Just "PresResponse") mempty

instance ToSchema User where
  declareNamedSchema _ = pure $ NamedSchema (Just "User") mempty

instance ToParamSchema (Item UserId User) where
  toParamSchema _ = mempty

instance ToParamSchema UserId where
  toParamSchema _ = mempty

instance ToSchema UserInfo where
  declareNamedSchema _ = pure $ NamedSchema (Just "UserInfo") mempty

instance ToParamSchema (Item UserId UserInfo) where
  toParamSchema _ = mempty

newtype PresentationName = PresentationName { unPresentationName :: T.Text }
  deriving stock (Show, Eq)
  deriving newtype (Aeson.FromJSON, Aeson.ToJSON)

newtype PresentationBackground = PresentationBackground { unPresentationBackground :: T.Text }
  deriving stock (Show, Eq)
  deriving newtype (Aeson.FromJSON, Aeson.ToJSON)

newtype PresentationHeader = PresentationHeader { unPresentationHeader :: T.Text }
  deriving stock (Show, Eq)
  deriving newtype (Aeson.FromJSON, Aeson.ToJSON)

newtype PresentationFooter = PresentationFooter { unPresentationFooter :: T.Text }
  deriving stock (Show, Eq)
  deriving newtype (Aeson.FromJSON, Aeson.ToJSON)

-- SLIDES

instance ToSchema Slide where
  declareNamedSchema _ = pure $ NamedSchema (Just "Slide") mempty

data Slide = Slide
  { slideContent :: Maybe T.Text
  , slideTemplate :: T.Text
  , slideAttributes :: HMS.HashMap T.Text T.Text
  } deriving (Show, Eq)

instance FromJSONObject Slide where
  parseJSONObject = \obj ->
    Slide <$>
      obj .:? "content" .!= Nothing <*>
      obj .: "template" <*>
      obj .:? "attributes" .!= HMS.empty

instance ToJSONObject Slide where
  toJSONObject slide = HMS.fromList
    [ "template" .= slideTemplate slide
    , "attributes" .= slideAttributes slide
    , "content" .= slideContent slide
    ]

instance Aeson.FromJSON Slide where
  parseJSON = Aeson.withObject "Slide" parseJSONObject
instance Aeson.ToJSON Slide where
  toJSON = Aeson.Object . toJSONObject

-- PRESENTATIONS

type PresentationsAPI =
    Protected :>
      ReqBody '[JSON] PresentationInfo :>
      Post '[JSON] (Item PresentationId PresentationResult) :<|>
    Protected :>
      Capture "presentation_id" PresentationId :>
      ReqBody '[JSON] PresentationInfo :>
      Put '[JSON] (Item PresentationId PresentationResult)

instance ToSchema (Item PresentationId PresentationResult) where
  declareNamedSchema _ = pure $ NamedSchema (Just "PresentationWithId") mempty

instance ToSchema PresentationInfo where
  declareNamedSchema _ = pure $ NamedSchema (Just "Presentation") mempty

-- instance ToParamSchema (Item PresentationId Presentation) where
  -- toParamSchema _ = mempty

newtype PresentationId = PresentationId { unPresentationId :: T.Text }
  deriving newtype
    ( Aeson.FromJSON
    , Aeson.ToJSON
    , FromHttpApiData
    , ToHttpApiData
    , Show
    , Eq
    )
  deriving stock
    ( Generic )

instance ToParamSchema PresentationId

data PresentationInfo = PresentationInfo
  { presentationName :: PresentationName
  , presentationOwner :: UserId
  , presentationBackground :: Maybe PresentationBackground
  , presentationHeader :: Maybe PresentationHeader
  , presentationFooter :: Maybe PresentationFooter
  , presentationAttributes :: HMS.HashMap T.Text T.Text
  , presentationSlides :: [Slide]
  , presentationDescription :: T.Text
  , presentationHeadExtra :: Maybe T.Text
  } deriving (Show, Eq)

data PresentationResult = PresentationResult
  { presentationUrl :: T.Text
  } deriving (Show, Eq)

instance ToJSONObject PresentationInfo where
  toJSONObject = undefined -- \obj ->

instance FromJSONObject PresentationInfo where
  parseJSONObject = \obj ->
    PresentationInfo <$>
      obj .: "name" <*>
      obj .: "owner_id" <*>
      obj .:? "background" <*>
      obj .:? "header" <*>
      obj .:? "footer" <*>
      obj .:? "attributes" .!= HMS.empty <*>
      obj .: "slides" <*>
      obj .: "description" <*>
      obj .:? "head_extra"

instance FromJSONObject PresentationResult where
  parseJSONObject = undefined

instance ToJSONObject PresentationResult where
  toJSONObject pres = HMS.fromList
    [ "url" .= presentationUrl pres
    ]

instance Aeson.ToJSON PresentationInfo where
  toJSON = Aeson.Object . toJSONObject
instance Aeson.FromJSON PresentationInfo where
  parseJSON = Aeson.withObject "Presentation" parseJSONObject
instance Aeson.ToJSON PresentationResult where
  toJSON = Aeson.Object . toJSONObject
instance Aeson.FromJSON PresentationResult where
  parseJSON = Aeson.withObject "Presentation" parseJSONObject

type API = "api" :> (
    "users" :> UsersAPI :<|>
    "presentations" :> PresentationsAPI
    )

api :: Proxy API
api = Proxy

------------------------------------------------------------------------------
-- SERVER
------------------------------------------------------------------------------

application
  :: Firebase.FirebaseLoginSettings
  -> AWS.Env
  -> HC.Connection
  -> Wai.Application
application settings env conn =
    Servant.serveWithContext
      api
      (settings :. Servant.EmptyContext)
      (server env conn)

server :: AWS.Env -> HC.Connection -> Servant.Server API
server env conn =
    serveUsers :<|>
    servePresentations
  where
    serveUsers =
      usersGet conn :<|>
      usersGetUserId conn :<|>
      usersPost conn :<|>
      usersPut conn :<|>
      usersDelete conn
    servePresentations =
      presentationsPost env conn :<|>
      presentationsPut env conn

presentationsPost
  :: AWS.Env -> HC.Connection
  -> Firebase.UserId
  -> PresentationInfo
  -> Servant.Handler (Item PresentationId PresentationResult)
presentationsPost env conn _userId pinfo = do
    liftIO $ putStrLn $ unwords
      [ "POST presentation"
      , show (pinfo { presentationSlides = [] }) -- make sure output ain't too big
      , show _userId
      ]

    iface <- liftIO $ getDbInterface conn
    user <- liftIO (dbGetUserById iface (presentationOwner pinfo)) >>= \case
      Nothing -> do
        liftIO $ putStrLn "Presentation user does not exist in DB"
        Servant.throwError Servant.err404
      Just u -> pure u

    let userId = presentationOwner pinfo

    uname <- case userUsername (itemContent user) of
      Nothing -> do
        liftIO $ putStrLn "User is anonymous"
        Servant.throwError Servant.err422
      Just uname -> pure uname

    liftIO $ putStrLn $ "Got user: " <> show uname

    let psname = sanitizePresentationName (presentationName pinfo)

    liftIO $ deployPresentation env uname psname pinfo

    presId <- liftIO $ PresentationId <$> newId

    presUrl <- do
      purl <- liftIO (getEnv "DECKGO_PRESENTATIONS_URL")
      pure $ mconcat
        [ "https://"
        , T.pack purl
        , "/"
        , unPresentationPrefix $
            presentationPrefix uname psname
        ]

    liftIO $ putStrLn $ unwords
      [ "Presentation info:"
      , show (presUrl, presId, psname)
      ]

    -- TODO: make unique
    liftIO (dbCreatePresentation iface presId psname presUrl userId)

    pure $ Item
      { itemId = presId
      , itemContent = PresentationResult { presentationUrl = presUrl }
      }

presentationsPut
  :: AWS.Env -> HC.Connection
  -> Firebase.UserId
  -> PresentationId
  -> PresentationInfo
  -> Servant.Handler (Item PresentationId PresentationResult)
presentationsPut env conn _uid pid pinfo = do
    liftIO $ putStrLn $ "PUT PRESENTATION" <> show pid
    liftIO $ putStrLn $ unwords
      [ "PUT presentation"
      , show (pinfo { presentationSlides = [] })
      , "(with ID " <> show pid <> ")"
      , show _uid
      ]

    liftIO $ print pinfo
    iface <- liftIO $ getDbInterface conn

    user <- liftIO (dbGetUserById iface (presentationOwner pinfo)) >>= \case
      Nothing -> do
        liftIO $ putStrLn "Presentation user does not exist in DB"
        Servant.throwError Servant.err404
      Just u -> pure u

    liftIO $ putStrLn $ "Got user from DB: " <> show user

    uname <- case userUsername (itemContent user) of
      Nothing -> do
        liftIO $ putStrLn "User is anonymous"
        Servant.throwError Servant.err422
      Just uname -> pure uname

    liftIO $ putStrLn $ "Got user: " <> show uname

    (presName, presUrl) <- liftIO (dbGetPresentationById iface pid) >>= \case
      Nothing -> do
        liftIO $ putStrLn "Presentation does not exist in DB"
        Servant.throwError Servant.err404
      Just res -> pure res

    liftIO $ putStrLn $ "Got presentation: " <> show (presName, presUrl)

    liftIO $ deployPresentation env uname presName pinfo

    presUrl' <- do
      purl <- liftIO (getEnv "DECKGO_PRESENTATIONS_URL")
      pure $ mconcat
        [ "https://"
        , T.pack purl
        , "/"
        , unPresentationPrefix $
            presentationPrefix uname presName
        ]

    liftIO $ putStrLn $ "Replying with url: " <> show presUrl'

    pure $ Item
      { itemId = pid
      , itemContent = PresentationResult { presentationUrl = presUrl' }
      }

-- USERS

usersGet :: MonadIO io => HC.Connection -> io [Item UserId User]
usersGet conn = do
    iface <- liftIO $ getDbInterface conn
    liftIO $ dbGetAllUsers iface -- TODO: to Servant err500 on error

usersGetSession :: HS.Session [Item UserId User]
usersGetSession = do
    HS.statement () usersGetStatement

usersGetStatement :: Statement () [Item UserId User]
usersGetStatement = Statement sql encoder decoder True
  where
    sql = BS8.unwords
      [ "SELECT account.id, account.firebase_id, account.username"
      ,   "FROM account"
      ]
    encoder = mempty
    decoder :: HD.Result [Item UserId User]
    decoder = HD.rowList row
    row :: HD.Row (Item UserId User)
    row =
      Item <$>
        ((UserId . FirebaseId) <$> (HD.column (HD.nonNullable HD.text))) <*>
        (User <$>
            (FirebaseId <$> (HD.column (HD.nonNullable HD.text))) <*>
            (HD.column (HD.nullable (Username <$> HD.text)))
        )

usersGetUserId :: HC.Connection -> UserId -> Servant.Handler (Item UserId User)
usersGetUserId conn userId = do
    iface <- liftIO $ getDbInterface conn
    liftIO (dbGetUserById iface userId) >>= \case
      Nothing -> Servant.throwError Servant.err404
      Just u -> pure u

usersGetUserIdSession :: UserId -> HS.Session (Maybe (Item UserId User))
usersGetUserIdSession userId = do
    HS.statement userId usersGetUserIdStatement

usersGetUserIdStatement :: Statement UserId (Maybe (Item UserId User))
usersGetUserIdStatement = Statement sql encoder decoder True
  where
    sql = BS8.unwords
      [ "SELECT account.id, account.firebase_id, account.username"
      ,   "FROM account"
      ,   "WHERE account.id = $1"
      ]
    encoder = contramap
        (unFirebaseId . unUserId)
        (HE.param (HE.nonNullable HE.text))
    decoder = HD.rowMaybe $
      Item <$>
        ((UserId . FirebaseId) <$> HD.column (HD.nonNullable HD.text)) <*>
        ( User <$>
          (FirebaseId <$> HD.column (HD.nonNullable HD.text)) <*>
          (HD.column (HD.nullable (Username <$> HD.text)))
        )

usersPost
  :: HC.Connection
  -> Firebase.UserId
  -> UserInfo
  -> Servant.Handler (Item UserId User)
usersPost conn fuid uinfo = do

    when (Firebase.unUserId fuid /= unFirebaseId (userInfoFirebaseId uinfo)) $ do
      Servant.throwError Servant.err403

    iface <- liftIO $ getDbInterface conn
    liftIO $ putStrLn "got DB interface"

    let userId = UserId (userInfoFirebaseId uinfo)
    user <- case userInfoToUser uinfo of
      Left e -> Servant.throwError Servant.err400
        { Servant.errBody = BL.fromStrict $ T.encodeUtf8 e }
      Right user -> pure user
    liftIO (dbCreateUser iface userId user) >>= \case
      Left () ->
          Servant.throwError $ Servant.err409
            { Servant.errBody = Aeson.encode (Item userId user) }
      Right user' -> pure $ Item userId user'

userInfoToUser :: UserInfo -> Either T.Text User
userInfoToUser uinfo = User <$>
    pure (userInfoFirebaseId uinfo) <*>
    (traverse emailToUsername (userInfoEmail uinfo))

emailToUsername :: T.Text -> Either T.Text Username
emailToUsername t = case T.breakOn "@" t of
    ("", _) -> Left ("Invalid email: " <> t)
    (out', _) -> case dropBadChars (T.toLower out') of
      "" -> Left ("No valid char found: " <> out')
      out -> Right $ Username out
  where
    dropBadChars :: T.Text -> T.Text
    dropBadChars = T.concatMap
      $ \case
        c | isAscii c && isAlphaNum c -> T.singleton c
          | otherwise -> ""

usersPostSession :: UserId -> User -> HS.Session (Either () User)
usersPostSession uid u = do
    HS.sql "BEGIN"
    liftIO $ putStrLn "Creating user in DB"
    HS.statement (uid,u) usersPostStatement >>= \case
      1 -> do
        liftIO $ putStrLn "User was created"
        case userUsername u of
          Just uname -> do
            liftIO $ putStrLn "Creating username"
            let success unam = do
                    liftIO $ putStrLn "User created successfully"
                    HS.sql "COMMIT"
                    pure $ Right $ u { userUsername = Just unam }
            HS.statement (uname, uid) usersPostStatement' >>= \case
              1 -> success uname
              _ -> do
                liftIO $ putStrLn "Couldn't create username"
                rand <- liftIO $ randomText 4 ['0' .. '9' ]
                let uname' = Username $ unUsername uname <> rand
                liftIO $ putStrLn $ "Retrying with username " <> (T.unpack $ unUsername uname')
                HS.statement (uname', uid) usersPostStatement' >>= \case
                  1 -> success uname'
                  _ -> do
                    liftIO $ putStrLn "Couldn't create username again"
                    HS.sql "ROLLBACK"
                    pure $ Left ()
          Nothing -> do
            liftIO $ putStrLn "No username"
            HS.sql "COMMIT"
            pure $ Right u
      _ -> do
        liftIO $ putStrLn "Couldn't create exactly one user"
        HS.sql "ROLLBACK"
        pure $ Left ()

usersPostStatement :: Statement (UserId, User) Int64
usersPostStatement = Statement sql encoder decoder True
  where
    sql = BS8.unwords
      [ "INSERT INTO account"
      ,   "(id, firebase_id, username)"
      ,   "VALUES ($1, $2, NULL)"
      ,   "ON CONFLICT DO NOTHING"
      ]
    encoder =
      contramap
        (unFirebaseId . unUserId . view _1)
        (HE.param (HE.nonNullable HE.text)) <>
      contramap (unFirebaseId . userFirebaseId . view _2) (HE.param (HE.nonNullable HE.text))
    decoder = HD.rowsAffected

usersPostStatement' :: Statement (Username, UserId) Int64
usersPostStatement' = Statement sql encoder decoder True
  where
    sql = BS8.unwords
      [ "UPDATE account SET username = $1 WHERE id = $2 AND NOT EXISTS (SELECT 1 FROM account WHERE username = $1)" ]
    encoder =
      contramap
        (unUsername . view _1)
        (HE.param (HE.nonNullable HE.text)) <>
      contramap
        (unFirebaseId . unUserId . view _2)
        (HE.param (HE.nonNullable HE.text))
    decoder = HD.rowsAffected

usersPostStatement'' :: Statement Username () -- TODO: check was deleted?
usersPostStatement'' = Statement sql encoder decoder True
  where
    sql = BS8.unwords
      [ "UPDATE account SET username = NULL WHERE id = $1"
      ]
    encoder =
      contramap
        (unUsername)
        (HE.param (HE.nonNullable HE.text))
    decoder = HD.noResult

usersPut
  :: HC.Connection
  -> Firebase.UserId
  -> UserId
  -> User
  -> Servant.Handler (Item UserId User)
usersPut conn fuid userId user = do

    when (Firebase.unUserId fuid /= unFirebaseId (unUserId userId)) $ do
      liftIO $ putStrLn $ unwords
        [ "User is trying to update another uinfo:", show (fuid, userId, user) ]
      Servant.throwError Servant.err404

    when (Firebase.unUserId fuid /= unFirebaseId (userFirebaseId user)) $ do
      liftIO $ putStrLn $ unwords
        [ "Client used the wrong uinfo ID on uinfo", show (fuid, userId, user) ]
      Servant.throwError Servant.err400

    iface <- liftIO $ getDbInterface conn
    liftIO (dbUpdateUser iface userId user) >>= \case
      UserUpdateOk -> pure $ Item userId user -- TODO: check # of affected rows
      e -> do -- TODO: handle not found et al.
        liftIO $ print e
        Servant.throwError Servant.err400

data UserUpdateResult
  = UserUpdateOk
  | UserUpdateNotExist
  | UserUpdateClash
  deriving Show

usersPutSession :: UserId -> User -> HS.Session UserUpdateResult
usersPutSession uid u = do
    HS.sql "BEGIN"
    usersGetUserIdSession uid >>= \case
      Nothing -> do
        HS.sql "ROLLBACK"
        pure UserUpdateNotExist

      -- XXX: no handling of updating firebase id
      Just (Item _ oldUser) -> case (userUsername oldUser, userUsername u) of
        (Nothing, Nothing) -> do
          HS.sql "ROLLBACK" -- doesn't matter if rollback or commit
          pure UserUpdateOk
        (oldUname, newUname) -> do
          case oldUname of
            Nothing -> pure ()
            Just uname -> do
              HS.statement uname usersPostStatement''
          case newUname of
            Nothing -> do
              HS.sql "COMMIT"
              pure UserUpdateOk
            Just uname -> do
              HS.statement (uname, uid) usersPostStatement' >>= \case
                1 -> do
                  HS.sql "COMMIT"
                  pure UserUpdateOk
                _ -> do
                  HS.sql "ROLLBACK"
                  pure UserUpdateClash

usersDelete :: HC.Connection -> Firebase.UserId -> UserId -> Servant.Handler ()
usersDelete conn fuid userId = do

    when (Firebase.unUserId fuid /= unFirebaseId (unUserId userId)) $ do
      Servant.throwError Servant.err403

    iface <- liftIO $ getDbInterface conn
    liftIO (dbDeleteUser iface userId) >>= \case
      Left () -> Servant.throwError Servant.err404
      Right () -> pure ()

usersDeleteSession :: UserId -> HS.Session ()
usersDeleteSession uid = do
    HS.statement uid usersDeleteStatement

usersDeleteStatement :: Statement UserId ()
usersDeleteStatement = Statement sql encoder decoder True
  where
    sql = "DELETE FROM account WHERE id = $1"
    encoder =
      contramap
        (unFirebaseId . unUserId)
        (HE.param (HE.nonNullable HE.text))
    decoder = HD.noResult -- TODO: affected rows

-- PRESENTATIONS


presentationsPostSession :: PresentationId -> PresShortname -> T.Text -> UserId -> HS.Session ()
presentationsPostSession pid pnam purl uid = do
    liftIO $ putStrLn "Creating presentation in DB"
    HS.statement (pid, pnam, purl, uid) presentationsPostStatement

presentationsPostStatement :: Statement (PresentationId, PresShortname, T.Text, UserId) ()
presentationsPostStatement = Statement sql encoder decoder True
  where
    sql = BS8.unwords
      [ "INSERT INTO presentation"
      ,   "(id, name, url, owner)"
      ,   "VALUES ($1, $2, $3, $4)"
      ]
    encoder =
      contramap (unPresentationId . view _1) (HE.param (HE.nonNullable HE.text)) <>
      contramap (unPresShortname . view _2) (HE.param (HE.nonNullable HE.text)) <>
      contramap (view _3) (HE.param (HE.nonNullable HE.text)) <>
      contramap
        (unFirebaseId . unUserId . view _4)
        (HE.param (HE.nonNullable HE.text))
    decoder = HD.noResult

presentationsGetByIdSession :: PresentationId -> HS.Session (Maybe (PresShortname, T.Text))
presentationsGetByIdSession pid = do
    liftIO $ putStrLn $ "Getting presentation by id"
    HS.statement pid presentationsGetByIdStatement

presentationsGetByIdStatement :: Statement PresentationId (Maybe (PresShortname, T.Text))
presentationsGetByIdStatement = Statement sql encoder decoder True
  where
    sql = BS8.unwords
      [ "SELECT name, url, owner FROM presentation"
      ,   "WHERE id = $1"
      ]
    encoder = contramap unPresentationId (HE.param (HE.nonNullable HE.text))
    decoder = HD.rowMaybe $ (,) <$>
      (PresShortname <$> HD.column (HD.nonNullable HD.text)) <*>
      HD.column (HD.nonNullable HD.text)
      -- TODO: return user ID

data PresResponse = PresResponse T.Text

instance Aeson.ToJSON PresResponse where
  toJSON (PresResponse t) = Aeson.object [ "url" .= t ]

instance Aeson.FromJSON PresResponse where
  parseJSON = Aeson.withObject "pres-response" $ \o ->
    PresResponse <$> o .: "url"

-------------------------------------------------------------------------------
-- DATABASE
-------------------------------------------------------------------------------

data DbInterface = DbInterface
  { dbGetAllUsers :: IO [Item UserId User]
  , dbGetUserById :: UserId -> IO (Maybe (Item UserId User))
  , dbCreateUser :: UserId -> User -> IO (Either () User)
  , dbUpdateUser :: UserId -> User -> IO UserUpdateResult
  , dbDeleteUser :: UserId -> IO (Either () ())

  -- TODO: dbCreateSlide: if duplicated, no error !?
  , dbCreatePresentation :: PresentationId -> PresShortname -> T.Text -> UserId -> IO ()
  , dbGetPresentationById :: PresentationId -> IO (Maybe (PresShortname, T.Text))
  }

data DbVersion
  = DbVersion0
  | DbVersion1
  | DbVersion2
  | DbVersion3
  | DbVersion4
  | DbVersion5
  | DbVersion6
  | DbVersion7
  deriving stock (Enum, Bounded, Ord, Eq)

-- | Migrates from ver to latest
migrateFrom :: DbVersion -> HS.Session ()
migrateFrom = \frm -> do
    liftIO $ putStrLn $ "Migration: " <>
      show (dbVersionToText <$> [frm ..maxBound])
    HS.sql "BEGIN"
    forM_ [frm .. maxBound] $ \ver -> do
      migrateTo ver
      HS.statement (dbVersionToText ver) $ Statement
        (BS8.unwords
          [ "INSERT INTO db_meta (key, value) VALUES ('version', $1)"
          , "ON CONFLICT (key) DO UPDATE SET value = $1"
          ]
        ) (HE.param (HE.nonNullable HE.text)) HD.noResult True
    HS.sql "COMMIT"
  where
    -- | Migrates from (ver -1) to ver
    migrateTo :: DbVersion -> HS.Session ()
    migrateTo = \case
      DbVersion0 -> do
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE account ("
            ,   "id TEXT UNIQUE,"
            ,   "firebase_id TEXT UNIQUE,"
            ,   "anonymous BOOLEAN"
            , ");"
            ]
          ) mempty HD.noResult True
      DbVersion1 -> do
        HS.statement () $ Statement
          (BS8.unwords
            [ "DROP TABLE IF EXISTS account CASCADE"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE account ("
            ,   "id TEXT UNIQUE NOT NULL,"
            ,   "firebase_id TEXT UNIQUE NOT NULL"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE username ("
            ,   "id TEXT UNIQUE NOT NULL,"
            ,   "account TEXT REFERENCES account (id) ON DELETE CASCADE UNIQUE NOT NULL"
            , ");"
            ]
          ) mempty HD.noResult True
      DbVersion2 -> do
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE slide ("
            ,   "id TEXT UNIQUE NOT NULL,"
            ,   "content TEXT,"
            ,   "template TEXT,"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
      DbVersion3 -> do
        HS.sql "DROP TABLE IF EXISTS username"
        HS.sql "DROP TABLE IF EXISTS account CASCADE"
        HS.sql "DROP TABLE IF EXISTS slide"
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE account ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "firebase_id TEXT UNIQUE,"
            ,   "username TEXT UNIQUE NULL"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE deck ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "name TEXT NOT NULL,"
            ,   "background TEXT NULL,"
            ,   "owner TEXT NOT NULL REFERENCES account (id),"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE slide ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "deck TEXT NOT NULL REFERENCES deck (id) ON DELETE CASCADE,"
            ,   "index INT2 NULL,"
            ,   "content TEXT," -- TODO: is any of this nullable?
            ,   "template TEXT,"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
      DbVersion4 -> do
        HS.sql "DROP TABLE IF EXISTS username"
        HS.sql "DROP TABLE IF EXISTS account CASCADE"
        HS.sql "DROP TABLE IF EXISTS slide"
        HS.sql "DROP TABLE IF EXISTS deck"
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE account ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "firebase_id TEXT UNIQUE,"
            ,   "username TEXT UNIQUE NULL"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE deck ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "name TEXT NOT NULL,"
            ,   "background TEXT NULL,"
            ,   "owner TEXT NOT NULL REFERENCES account (id),"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE slide ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "deck TEXT NOT NULL REFERENCES deck (id) ON DELETE CASCADE,"
            ,   "index INT2 NULL,"
            ,   "content TEXT," -- TODO: is any of this nullable?
            ,   "template TEXT,"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
      DbVersion5 -> do
        HS.sql "DROP TABLE IF EXISTS username"
        HS.sql "DROP TABLE IF EXISTS account CASCADE"
        HS.sql "DROP TABLE IF EXISTS slide"
        HS.sql "DROP TABLE IF EXISTS deck"
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE account ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "firebase_id TEXT UNIQUE,"
            ,   "username TEXT UNIQUE NULL"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE deck ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "name TEXT NOT NULL,"
            ,   "background TEXT NULL,"
            ,   "owner TEXT NOT NULL REFERENCES account (id) ON DELETE CASCADE,"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE slide ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "deck TEXT NOT NULL REFERENCES deck (id) ON DELETE CASCADE,"
            ,   "index INT2 NULL,"
            ,   "content TEXT," -- TODO: is any of this nullable?
            ,   "template TEXT,"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
      DbVersion6 -> do
        HS.sql "DROP TABLE IF EXISTS username"
        HS.sql "DROP TABLE IF EXISTS account CASCADE"
        HS.sql "DROP TABLE IF EXISTS slide"
        HS.sql "DROP TABLE IF EXISTS deck"
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE account ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "firebase_id TEXT UNIQUE,"
            ,   "username TEXT UNIQUE NULL"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE deck ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "name TEXT NOT NULL,"
            ,   "background TEXT NULL,"
            ,   "owner TEXT NOT NULL REFERENCES account (id) ON DELETE CASCADE,"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE slide ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "deck TEXT NOT NULL REFERENCES deck (id) ON DELETE CASCADE,"
            ,   "index INT2 NULL,"
            ,   "content TEXT," -- TODO: is any of this nullable?
            ,   "template TEXT,"
            ,   "attributes JSON"
            , ");"
            ]
          ) mempty HD.noResult True
      -- TODO: unique on (owner, name)
      -- TODO: drop deck, slide tables
      DbVersion7 -> do
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE presentation ("
            ,   "id TEXT PRIMARY KEY,"
            ,   "name TEXT NOT NULL,"
            ,   "url TEXT NOT NULL,"
            ,   "owner TEXT NOT NULL REFERENCES account (id) ON DELETE CASCADE"
            , ");"
            ]
          ) mempty HD.noResult True

readDbVersion :: HS.Session (Either String (Maybe DbVersion))
readDbVersion = do
    res <- HS.statement () $ Statement
      (BS8.unwords
        [ "SELECT EXISTS ("
        ,   "SELECT 1"
        ,   "FROM   information_schema.tables"
        ,   "WHERE  table_schema = 'public'"
        ,   "AND    table_name = 'db_meta'"
        ,   ");"
        ]
      ) mempty (HD.singleRow (HD.column (HD.nonNullable HD.bool))) True
    case res of
      True -> do
        mtver <- HS.statement () $ Statement
          "SELECT value FROM db_meta WHERE key = 'version'"
          mempty (HD.rowMaybe (HD.column (HD.nonNullable HD.text))) True
        case mtver of
          Nothing -> pure (Right Nothing)
          Just tver -> case dbVersionFromText tver of
            Nothing -> error $ "could not decode DB version: " <> T.unpack tver
            Just ver -> pure (Right $ Just ver)
      False -> do
        HS.statement () $ Statement
          (BS8.unwords
            [ "CREATE TABLE db_meta ("
            ,   "key TEXT UNIQUE NOT NULL,"
            ,   "value TEXT NOT NULL"
            ,   ");"
            ]
          ) mempty HD.noResult True
        pure $ Right Nothing

dbVersionToText :: DbVersion -> T.Text
dbVersionToText = \case
  DbVersion0 -> "0"
  DbVersion1 -> "1"
  DbVersion2 -> "2"
  DbVersion3 -> "3"
  DbVersion4 -> "4"
  DbVersion5 -> "5"
  DbVersion6 -> "6"
  DbVersion7 -> "7"

dbVersionFromText :: T.Text -> Maybe DbVersion
dbVersionFromText t =
    find (\ver -> dbVersionToText ver == t) [minBound .. maxBound]

migrate :: HS.Session ()
migrate = do
    readDbVersion >>= \case
      Left e -> error $ show e
      Right Nothing -> do
        liftIO $ putStrLn "Migrating from beginning"
        migrateFrom minBound
      Right (Just v) ->
        if
          | v == maxBound -> pure ()
          | v > maxBound -> error "V greater than maxbound"
          | v < maxBound -> migrateFrom (succ v)
          | True -> error $ unwords
              [ "impossible:"
              , "version must be equal to,"
              , "greater than or smaller than maxBound."
              ]

getDbInterface :: HC.Connection -> IO DbInterface
getDbInterface conn = do
    HS.run migrate conn >>= \case
      Left e -> error $ show e
      Right () -> pure ()

    pure $ DbInterface
      { dbGetAllUsers = wrap usersGetSession
      , dbGetUserById = \uid -> wrap (usersGetUserIdSession uid)
      , dbCreateUser = \uid uinfo -> wrap (usersPostSession uid uinfo)
      , dbUpdateUser = \uid uinfo -> wrap (usersPutSession uid uinfo)

      -- TODO: proper return type on delete
      , dbDeleteUser = \uid -> Right <$> wrap (usersDeleteSession uid)

      , dbCreatePresentation = \pid pname purl uid  -> wrap (presentationsPostSession pid pname purl uid)
      , dbGetPresentationById = \pid -> wrap (presentationsGetByIdSession pid)
      }
  where
    wrap :: forall b. HS.Session b -> IO b
    wrap act = HS.run act conn >>= \case
      Left e -> error $ "getDbInterface: error: " <> show e -- TODO
      Right x -> pure x

-- AUX

runAWS :: MonadIO m => AWS.Env -> AWS.AWS a -> m (Either SomeException a)
runAWS env =
    liftIO .
    tryAny .
    AWS.runResourceT .
    AWS.runAWS env .
    AWS.within AWS.NorthVirginia

randomString :: Int -> [Char] -> IO String
randomString len allowedChars =
  replicateM len $ do
    idx <- Random.randomRIO (0, length allowedChars - 1)
    pure $ allowedChars !! idx

randomText :: Int -> [Char] -> IO T.Text
randomText len allowedChars = T.pack <$> randomString len allowedChars

newId :: IO T.Text
newId = randomText 32 (['0' .. '9'] <> ['a' .. 'z'])

tshow :: Show a => a -> T.Text
tshow = T.pack . show

newtype PresentationPrefix = PresentationPrefix { unPresentationPrefix :: T.Text }

-- TODO: what happens when the deckname is "-" ?
presentationPrefix :: Username -> PresShortname -> PresentationPrefix
presentationPrefix uname psname =
    PresentationPrefix $
      unUsername uname <> "/" <> unPresShortname psname <> "/"

sanitizePresentationName :: PresentationName -> PresShortname
sanitizePresentationName = PresShortname . T.toLower . strip . dropBadChars . unPresentationName
  where
    strip :: T.Text -> T.Text
    strip = T.dropAround ( == '-' )
    dropBadChars :: T.Text -> T.Text
    dropBadChars = T.concatMap
      $ \case
        c | isAscii c && isAlphaNum c -> T.singleton c
          | c == '-' -> T.singleton c
          | c == ' ' -> T.singleton '-'
          | otherwise -> ""

data Err = Err T.Text SomeException
  deriving (Show, Exception)

err :: T.Text -> SomeException -> IO a
err msg e = throwIO $ Err msg e

-- | Diffs the bucket objects.
-- Returns:
--  * fst: the files to add
--  * snd: the files to delete
diffObjects
  :: [(FilePath, S3.ObjectKey, S3.ETag)]
  -> [(S3.ObjectKey, S3.ETag)]
  -> ([(FilePath, S3.ObjectKey, S3.ETag)], [S3.ObjectKey])
diffObjects news0 (HMS.fromList -> olds0) = second HMS.keys $
    foldl' (
      \(news, olds) obj@(_fp, okey, etag) -> do
          case HMS.lookup okey olds of
            Nothing -> (obj : news, olds)
            Just etag' ->
              if etag' == etag
              then (news, HMS.delete okey olds)
              else (obj : news, olds)
      ) ([], olds0) news0

listPresentationObjects
  :: AWS.Env
  -> S3.BucketName
  -> PresentationPrefix
  -> IO [S3.Object]
listPresentationObjects env bucket pprefix =
    listObjects env bucket (Just $ unPresentationPrefix pprefix)

zipExtract :: FilePath -> FilePath -> IO ()
zipExtract dest archivePath = do
    archive <- Zip.toArchive <$> BL.readFile archivePath
    Zip.extractFilesFromArchive [ Zip.OptDestination dest ] archive

withPresentationFiles
  :: Username
  -> PresShortname
  -> PresentationInfo
  -> ([(FilePath, S3.ObjectKey, S3.ETag)] -> IO a)
  -> IO a
withPresentationFiles uname psname presentationInfo act = do
    deckgoStarterDist <- getEnv "DECKGO_STARTER_DIST"
    Temp.withSystemTempDirectory "dist" $ \dir -> do
      zipExtract dir deckgoStarterDist

      -- Here we deal with workbox' precache by updating index.html and then
      -- propagate the new etag (md5) through precache-manifest.js and
      -- service-worker.js.

      oldIndexMd5 <- fileETag $ dir </> "index.html"
      let serviceWorkerFile = dir </> "service-worker.js"
      mapFile processIndex $ dir </> "index.html"
      newIndexMd5 <- fileETag $ dir </> "index.html"
      putStrLn $ "Changing index.html MD5 from " <>
        show oldIndexMd5 <> " to " <> show newIndexMd5
      mapFile (T.replace oldIndexMd5 newIndexMd5) $ dir </> serviceWorkerFile

      mapFile interpol $ dir </> "manifest.json"
      putStrLn "Listing files..."
      files <- listDirectoryRecursive dir
      files' <- forM files $ \(fp, components) -> do
        etag <- fileETag fp
        let okey = mkObjectKey uname psname components
        pure (fp, okey, etag)
      act files'
  where
    pname = presentationName presentationInfo
    processIndex :: T.Text -> T.Text
    processIndex input =
      let content =
            interpol . TagSoup.renderTags . processTags presentationInfo . TagSoup.parseTags $ input
          scriptShas = (pad . sha256digest) <$> (findScripts content)
          pad = \x -> "'sha256-" <> x <> "'"
      in T.replace "{{DECKDECKGO_EXTRA_SHAS}}" (T.intercalate " " scriptShas) content
    interpol =
      T.replace "{{DECKDECKGO_TITLE}}" (unPresentationName pname) .
      T.replace "{{DECKDECKGO_TITLE_SHORT}}" (T.take 12 $ unPresentationName pname) .
      T.replace "{{DECKDECKGO_AUTHOR}}" (unUsername uname) .
      T.replace "{{DECKDECKGO_USERNAME}}" (unUsername uname) .
      T.replace "{{DECKDECKGO_DESCRIPTION}}" (presentationDescription presentationInfo) .
      T.replace "{{DECKDECKGO_USER_ID}}"
        (unFirebaseId . unUserId $ presentationOwner presentationInfo) .
      T.replace "{{DECKDECKGO_DECKNAME}}" (unPresShortname psname) .
      T.replace "{{DECKDECKGO_BASE_HREF}}"
        ("/" <> unPresentationPrefix (presentationPrefix uname psname)) .
      T.replace "{{DECKDECKGO_BASE_HREF}}"
        ("/" <> unPresentationPrefix (presentationPrefix uname psname)) .
      T.replace "{{DECKDECKGO_HEAD_EXTRA}}"
        (fromMaybe "" (presentationHeadExtra presentationInfo))

sha256digest :: T.Text -> T.Text
sha256digest =
    T.decodeUtf8 .
    convertToBase Base64 .
    Hash.hashWith Hash.SHA256 .
    T.encodeUtf8

-- | finds all inlined javascript
findScripts :: T.Text -> [T.Text]
findScripts (TagSoup.parseTags -> ts) = xif ts
    (\f -> \case
      (TagSoup.TagOpen "script" _):(TagSoup.TagText t):rest ->
        t:(f rest)
      -- tagsoup guarantees that text nodes are not empty
      (TagSoup.TagOpen "script" _):(TagSoup.TagClose _):rest ->
        "":(f rest)
      [] -> []
      _:rest -> f rest
    )

mapFile :: (T.Text -> T.Text) -> FilePath -> IO ()
mapFile f fp = do
    T.readFile fp >>= T.writeFile fp . f

type Tag = TagSoup.Tag T.Text

processTags :: PresentationInfo -> [Tag] -> [Tag]
processTags presentationInfo = concatMap $ \case
  TagSoup.TagOpen str (HMS.fromList -> attrs)
    -- If the tag is 'deckgo-deck', we add the slides and the "background",
    -- "header" and "footer" divs
    | str == "deckgo-deck" -> do
        [ TagSoup.TagOpen str (HMS.toList (presentationAttributes presentationInfo <> attrs)) ] <>
          (concatMap slideTags (presentationSlides presentationInfo)) <>
          (maybe [] presentationBackgroundTags
            (presentationBackground presentationInfo)) <>
          (maybe [] presentationHeaderTags
            (presentationHeader presentationInfo)) <>
          (maybe [] presentationFooterTags
            (presentationFooter presentationInfo))
  t -> [t]

presentationBackgroundTags :: PresentationBackground -> [Tag]
presentationBackgroundTags (unPresentationBackground -> bg) =
    [ TagSoup.TagOpen "div" (HMS.toList $ HMS.singleton "slot" "background")
    ] <> TagSoup.parseTags bg <>
    [ TagSoup.TagClose "div"
    ]

presentationHeaderTags :: PresentationHeader -> [Tag]
presentationHeaderTags (unPresentationHeader -> bg) =
    [ TagSoup.TagOpen "div" (HMS.toList $ HMS.singleton "slot" "header")
    ] <> TagSoup.parseTags bg <>
    [ TagSoup.TagClose "div"
    ]

presentationFooterTags :: PresentationFooter -> [Tag]
presentationFooterTags (unPresentationFooter -> bg) =
    [ TagSoup.TagOpen "div" (HMS.toList $ HMS.singleton "slot" "footer")
    ] <> TagSoup.parseTags bg <>
    [ TagSoup.TagClose "div"
    ]

slideTags :: Slide -> [Tag]
slideTags slide =
    [ TagSoup.TagOpen
        (slideTemplate slide)
        (first Cases.spinalize <$> HMS.toList (slideAttributes slide))
    ] <> maybe [] TagSoup.parseTags (slideContent slide) <>
    [ TagSoup.TagClose (slideTemplate slide)
    ]


listObjects :: AWS.Env -> S3.BucketName -> Maybe T.Text -> IO [S3.Object]
listObjects env bname mpref = xif ([],Nothing) $ \f (es, ct) ->
    runAWS env (AWS.send $ S3.listObjectsV2 bname &
      S3.lovContinuationToken .~ ct &
      S3.lovPrefix .~ mpref
      ) >>= \case
      Right r -> do
        putStrLn "Listed objects..."
        let objs = r ^. S3.lovrsContents
        case (r ^. S3.lovrsIsTruncated, r ^. S3.lovrsNextContinuationToken) of
          (Just True, Just ct') -> f (es <> objs, Just ct')
          _ -> pure (es <> objs)
      Left e -> err "Could not list objects" e

deleteObjects :: AWS.Env -> S3.BucketName -> Maybe T.Text -> IO ()
deleteObjects env bname mpref = do
    es <- listObjects env bname mpref
    putStrLn $ "Deleting " <> show (length es) <> " objects..."
    deleteObjects' env bname $ map (^. S3.oKey) es

deleteObjects' :: AWS.Env -> S3.BucketName -> [S3.ObjectKey] -> IO ()
deleteObjects' env bname okeys =
    forConcurrentlyN_ 10 okeys $ \okey -> runAWS env (
      AWS.send $ S3.deleteObject bname okey) >>= \case
        Right {} -> pure ()
        Left e -> error $ "Could not delete object: " <> show e

newtype PresShortname = PresShortname { unPresShortname :: T.Text }
    deriving (Show)

deployPresentation
  :: AWS.Env
  -> Username
  -> PresShortname
  -> PresentationInfo
  -> IO ()
deployPresentation env uname psname presentationInfo = do
    let pprefix = presentationPrefix uname psname
    bucketName <- getEnv "BUCKET_NAME"
    let bucket = S3.BucketName (T.pack bucketName)
    putStrLn "Listing current objects"
    currentObjs <- listPresentationObjects env bucket pprefix
    putStrLn "Listing presentations files"

    withPresentationFiles uname psname presentationInfo $ \files -> do
      let
        currentObjs' =
          (\obj ->
            (obj ^. S3.oKey, fixupS3ETag $ obj ^. S3.oETag)
          ) <$> currentObjs
        (toPut, toDelete) = diffObjects files currentObjs'
      putStrLn $ "Deleting " <> show (length toDelete) <> " old files"
      deleteObjects' env bucket toDelete
      putStrLn $ "Uploading " <> show (length toPut) <> " new files"
      putObjects env bucket toPut

    queueName <- liftIO $ T.pack <$> getEnv "QUEUE_NAME"

    -- TODO: cleaner error handling down here

    liftIO $ putStrLn $ "Forwarding to queue: " <> T.unpack queueName
    queueUrl <- runAWS env (AWS.send $ SQS.getQueueURL queueName) >>= \case
      Right e -> pure $ e ^. SQS.gqursQueueURL
      Left e -> do
        liftIO $ print e
        error "Failed"

    liftIO $ print queueUrl

    res <- runAWS env $ AWS.send $ SQS.sendMessage queueUrl $
      T.decodeUtf8 $ BL.toStrict $ Aeson.encode $
        unPresentationPrefix pprefix

    case res of
      Right r -> do
        liftIO $ print r
      Left e -> do
        liftIO $ print e
        error "Failed!!"

putObjects
  :: AWS.Env
  -> S3.BucketName
  -> [(FilePath, S3.ObjectKey, S3.ETag)]
  -> IO ()
putObjects env bucket objs = forConcurrentlyN_ 10 objs $ putObject env bucket

putObject
  :: AWS.Env
  -> S3.BucketName
  -> (FilePath, S3.ObjectKey, S3.ETag)
  -> IO ()
putObject env bucket (fp, okey, etag) = do
    body <- Body.toBody <$> BS.readFile fp
    runAWS env (
      AWS.send $ S3.putObject bucket okey body &
          -- XXX: partial, though technically should never fail
          S3.poContentType .~ inferContentType (T.pack fp) &
          S3.poCacheControl .~ Just "no-cache"
      ) >>= \case
        Right r -> do
          putStrLn $ "Copied: " <> fp <> " to " <> show okey <> " with ETag " <> show etag
          case r ^. S3.porsETag of
            Just (fixupS3ETag -> s3ETag) ->
              when (etag /= s3ETag) $ do
                putStrLn $ "Warning: mismatched MD5: expected : actual: " <>
                  show etag <> " : " <> show s3ETag
            Nothing -> putStrLn "Warning: no ETag"
        Left e -> error $ "Error in put: " <> show e

-- | Some of the ETags we receive from S3 are surrounded with /"/ chars so we
-- strip them
fixupS3ETag :: S3.ETag -> S3.ETag
fixupS3ETag (S3.ETag etag) =
    S3.ETag $
      T.encodeUtf8 $
      T.dropWhileEnd (== '"') $
      T.dropWhile (== '"') $
      T.decodeUtf8 etag

mkObjectKey :: Username -> PresShortname -> [T.Text] -> S3.ObjectKey
mkObjectKey uname pname components = S3.ObjectKey $
    unPresentationPrefix (presentationPrefix uname pname) <> T.intercalate "/" components

-- | calculates the MD5 sum of a file, hex representation.
fileETag :: IsString a => FilePath -> IO a
fileETag fp =
    -- XXX: The 'show' step is very import, it's what converts the Digest to
    -- the Hex representation
    (fromString . show . MD5.md5 . BL.fromStrict) <$> BS.readFile fp

inferContentType :: T.Text -> Maybe T.Text
inferContentType = Just . T.decodeUtf8 .
    Mime.mimeByExt Mime.defaultMimeMap Mime.defaultMimeType

listDirectoryRecursive :: FilePath -> IO [(FilePath, [T.Text])]
listDirectoryRecursive = fix $ \f dir -> do
    -- XXX: /so/ not tail recursive
    (dirs, fs) <- Dir.listDirectory dir >>=
      mapM (\component -> pure (dir </> component, [T.pack component])) >>=
      partitionM (Dir.doesDirectoryExist . fst)
    fs' <- concatMapM
      (\(dir', components) -> fmap (second (components <>)) <$> (f dir'))
      dirs
    pure (fs <> fs')

-- Data.List for Monad

-- | A version of 'partition' that works with a monadic predicate.
--
-- > partitionM (Just . even) [1,2,3] == Just ([2], [1,3])
-- > partitionM (const Nothing) [1,2,3] == Nothing
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM _ [] = return ([], [])
partitionM f (x:xs) = do
    res <- f x
    (as,bs) <- partitionM f xs
    return ([x | res]++as, [x | not res]++bs)

-- | A version of 'concatMap' that works with a monadic predicate.
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
{-# INLINE concatMapM #-}
concatMapM act = foldr f (return [])
    where f x xs = do x' <- act x; if null x' then xs else do xs' <- xs; return $ x' ++xs'

forConcurrentlyN_
  :: (MonadUnliftIO m) => Int -> [a] -> (a -> m b) -> m ()
forConcurrentlyN_ n xs act = forConcurrently_ (nChunks n xs) (mapM_ act)

nChunks :: Int -> [a] -> [[a]]
nChunks n xs = HMS.elems $ snd $ foldl'
    (\(i, m) v -> (i+1, HMS.insertWith (<>) (i `mod` n) [v] m) )
    (0, HMS.empty) xs
