{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell,
    TypeFamilies, ViewPatterns, LambdaCase, EmptyDataDecls,
    FlexibleContexts, GADTs, GeneralizedNewtypeDeriving,
    MultiParamTypeClasses, DerivingStrategies, StandaloneDeriving,
    UndecidableInstances, DataKinds, FlexibleInstances, TypeOperators #-}

{-# 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 Data.Aeson
import Database.Persist.Sqlite
import Data.Char (isAlphaNum)
import Data.Function ((&))
import Data.Maybe (maybeToList)
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

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
PendingBang
    bang T.Text
    url T.Text
    displayName T.Text
    notifyEmail (Maybe T.Text)
    UniqueBang bang url displayName
    deriving Show
|]

instance ToJSON PendingBang where
    toJSON (PendingBang b u dp em) = object $
        ["bang" .= b, "url" .= u, "name" .= dp] ++ case em of
            Nothing -> []
            Just e -> ["email" .= e]

    -- TODO toEncoding. Not sure how much value that holds though

instance FromJSON PendingBang where
    parseJSON = withObject "PendingBang" $ \ob ->
        PendingBang
        <$> ob .:  "bang"
        <*> ob .:  "url"
        <*> ob .:  "name"
        <*> ob .:? "email"

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@(PendingBang n u dp mayEm) <- requireCheckJsonBody
    unless (T.all isAlphaNum n) $ invalidArgs []
    let strings = [n, u, dp] <> maybeToList mayEm
    unless (all ((<255) . T.length) strings) $ 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

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

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

    liftIO $ runSettings settings sApp
