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

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

module Main (main) where

import Control.Monad.Logger (runStdoutLoggingT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad (when, unless)
import Database.Persist.Sqlite
import Data.Function ((&))
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

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

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 ()
getHomeR = do
    cacheSeconds $ 60 * 60 * 24 * 7
    sendFile typeHtml "index.html"

getBundleR :: Handler ()
getBundleR = do
    cacheSeconds $ 60 * 60 * 24 * 7
    sendFile typeJavascript "bundle.js"

getStyleR :: Handler ()
getStyleR = do
    cacheSeconds $ 60 * 60 * 24 * 7
    sendFile typeCss "style.css"

getBangsR :: Handler TypedContent
getBangsR = do
    st <- bangState <$> getYesod

    -- 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

    return $ TypedContent typeJson $ toContent bs

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

getOpenSearchR :: Handler TypedContent
getOpenSearchR = do
    neverExpires

    cfg <- config <$> getYesod
    resXml <- makeOpenSearch cfg <$> lookupGetParam "default"
    return $ TypedContent "application/opensearchdescription+xml" $ toContent resXml

postVerdictR :: Bool -> Handler ()
postVerdictR b = do
    ensureAuth . config =<< getYesod

    (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 <- bangState <$> getYesod
    when b $ liftIO $ addBang n u dp st
    --sendEmail mayEm $ "your bang was " <> bool b "rejected" "accepted" -- TODO
    runDB $ deleteWhere [PendingBangBang ==. 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])

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)

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

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

    liftIO $ runSettings settings sApp