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

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

instance Yesod Search where
    makeSessionBackend _ = return Nothing

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
    baseUrl <- liftIO getBaseUrl
    url <- lookupGetParam "default" <&> \case
        Nothing -> baseUrl <> "/#{searchTerms}"
        Just b  -> baseUrl <> "/#" <> b <> "#{searchTerms}"

    liftIO $
        TypedContent "application/opensearchdescription+xml"
        .   toContent
        <$> makeOpenSearch url

getPendingR :: Handler Value
getPendingR = do
    ensureAuth

    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

    s <- Search
        <$> liftIO initBangState
        <*> pure pool
    sApp <- liftIO $ toWaiApp s -- includes middlewares

    host <- liftIO getHost
    port <- liftIO getPort
    let settings = defaultSettings
            & setHost host
            & setPort port

    liftIO $ runSettings settings sApp