{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
    TypeFamilies, LambdaCase, EmptyDataDecls, ScopedTypeVariables #-}

{-# OPTIONS -Wno-unused-top-binds #-}

module Main (main) where

import Control.Monad.IO.Unlift (toIO)
import Control.Monad.Logger (runStdoutLoggingT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad (when, unless)
import Database.Persist.Sqlite
import Data.Bool (bool)
import Data.FileEmbed (embedFile)
import Data.Function ((&))
import Data.Pool (Pool)
import Network.Wai.Handler.Warp hiding (getPort, getHost)
import Yesod

import qualified Data.ByteString as BS
import qualified Data.Text as T

import Auth
import BangState
import Config
import Data.PendingBang
import BatchedRunner

data Search = Search {
    bangState :: BangState,
    sqlPool :: ConnectionPool,
    config :: Config,
    notifyPbRunner :: Runner
}

mkYesod "Search" [parseRoutes|
/             HomeR GET
/bundle.js    BundleR GET
/style.css    StyleR GET
/bangs.json   BangsR GET
/search.xml   OpenSearchR GET
/submitBang   SubmitR POST
/acceptBang   AcceptR POST
/rejectBang   RejectR POST
/pendingBangs PendingR GET
|]

instance Yesod Search where
    makeSessionBackend _ = return Nothing
    approot = ApprootStatic ""

instance YesodPersist Search where
    type YesodPersistBackend Search = SqlBackend

    runDB action = getYesod >>= runSqlPool action . sqlPool

getHomeR :: Handler TypedContent
getHomeR = do
    cacheSeconds $ 60 * 60 * 24 * 7
    respond typeHtml ($(embedFile "build/index.html"))

getBundleR :: Handler TypedContent
getBundleR = do
    cacheSeconds $ 60 * 60 * 24 * 7
    noEmbed <- confNoEmbed . config <$> getYesod

    respond typeJavascript =<< if noEmbed
                               then liftIO $ BS.readFile "../build/bundle.js"
                               else pure ($(embedFile "build/bundle.js"))

getStyleR :: Handler TypedContent
getStyleR = do
    cacheSeconds $ 60 * 60 * 24 * 7
    noEmbed <- confNoEmbed . config <$> getYesod

    respond typeCss =<< if noEmbed
                        then liftIO $ BS.readFile "../build/style.css"
                        else pure ($(embedFile "build/style.css"))

getBangsR :: Handler TypedContent
getBangsR = do
    st <- getsYesod bangState

    -- changes here should propagate quicker, so we're using 1h.
    -- besides, we're using an eTag as well.
    cacheSeconds $ 60 * 60
    setEtag =<< liftIO (getBangsHash st)

    bs <- lookupHeader "accept-encoding" >>= \case
        Just ae | "br" `BS.isInfixOf` ae -> do
            addHeader "content-encoding" "br"
            liftIO $ getBangsBrotli st
        _ -> do
            liftIO $ getBangsJSON st

    respond typeJson bs

postSubmitR :: Handler ()
postSubmitR = do
    pb <- requireCheckJsonBody
    unless (verifyPendingBang pb) $ invalidArgs []

    cnt <- runDB $ count ([] :: [Filter PendingBang])
    unless (cnt < 1000) $ permissionDenied "Too many pending bangs already in database"
    runDB $ insert400_ pb

    liftIO . notifyRunner . notifyPbRunner =<< getYesod

getOpenSearchR :: Handler TypedContent
getOpenSearchR = do
    neverExpires

    cfg <- getsYesod config
    resXml <- makeOpenSearch cfg <$> lookupGetParam "default"
    respond "application/opensearchdescription+xml" resXml

postVerdictR :: Bool -> Handler ()
postVerdictR b = do
    cfg <- getsYesod config
    ensureAuth cfg

    (PendingBang n u dp mayEm) <- requireCheckJsonBody
    -- NOTE: known race condition: the bang bang may be deleted from the database
    -- before the updated bangs are written to disk, leading to the loss of
    -- a pending bang on very specific crash timing.
    st <- getsYesod bangState 
    when b $ liftIO $ addBang n u dp st
    runDB $ deleteWhere [PendingBangBang ==. n]

    case mayEm of
        Nothing -> return ()
        Just em -> do
            let e = T.unpack em
            sendEmail cfg e ("Your bang was " <> bool "rejected" "accepted!" b) $
                "Hello,\n" <>
                "\n" <>
                "We're " <> bool "sorry" "happy" b <> " to announce that your" <>
                " submitted bang \"" <> T.unpack dp <> "\" (\"!" <> T.unpack n <>
                "\", leading to " <> T.unpack u <> ") has been " <>
                bool "rejected" "accepted" b <>
                " by an administrator. Good look with your future banging!\n"

    return ()

postAcceptR, postRejectR :: Handler ()
postAcceptR = postVerdictR True
postRejectR = postVerdictR False

getPendingR :: Handler Value
getPendingR = do
    ensureAuth . config =<< getYesod

    pendingBangs <- runDB $ selectList [] []
    return $ toJSON $ map entityVal (pendingBangs :: [Entity PendingBang])

sendPendingBangs :: forall m. (MonadLogger m, MonadUnliftIO m)
                 => Config -> Pool SqlBackend -> m ()
sendPendingBangs cfg pool = do
    n <- length <$> (runSqlPool (selectList [] []) pool :: m [Entity PendingBang])
    when (n > 0) $ sendEmail cfg (confAdminEmail cfg) "Pending Bang notification" $
        "There are currently " <> show n <> " pending bangs.\n" <>
        "Please do something about it.\n"

main :: IO ()
main = runStdoutLoggingT $ withSqlitePool "banger.db" 2 $ \pool -> do
    runResourceT $ flip runSqlPool pool $ runMigration migrateAll

    bs <- liftIO initBangState
    cfg <- liftIO getConfig
    $(logInfo) $ "Using config: " <> T.pack (show cfg)

    sendPbIO <- toIO $ sendPendingBangs cfg pool
    notifyPb <- liftIO $ makeRunner sendPbIO 600000000 {- 10 min -}

    sApp <- liftIO $ toWaiApp $ Search bs pool cfg notifyPb -- includes middlewares

    let settings = defaultSettings
            & setHost (confHost cfg)
            & setPort (confPort cfg)

    liftIO $ runSettings settings sApp