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

module Main (main) where

import Control.Monad.Logger (runStdoutLoggingT)
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad (unless)
import Data.Char (isAlphaNum)
import Database.Persist.Sqlite
import Data.Function ((&))
import Data.Functor ((<&>))
import Network.Wai.Handler.Warp hiding (getPort, getHost)
import Yesod

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

import BangState
import Config

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
PendingBang
    name T.Text
    url T.Text
    displayName T.Text
    UniqueBang name
    deriving Show
|]

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

mkYesod "Search" [parseRoutes|
/           HomeR GET
/bundle.js  BundleR GET
/style.css  StyleR GET
/bangs.json BangsR GET
/submitBang SubmitR POST
/search.xml OpenSearchR 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 = sequence (map lookupPostParam ["bang", "url", "name"])
  >>= \l -> case sequence l of
    Just [bn, bu, bdp] -> do
        unless (T.all isAlphaNum bn)                   $ invalidArgs []
        unless (all ((<255) . T.length) [bn, bu, bdp]) $ invalidArgs []
        runDB $ insert400_ $ PendingBang bn bu bdp

    _ -> invalidArgs []

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

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