{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- | Yesod foundational datatype. Routes and helper types are defined here
module HagiaSite
    ( HagiaSite (..)
    , Route (..)
    , resourcesHagiaSite
    , Handler
    , Widget

      -- * Utility functions
    , repoPath
    ) where

import ClassyPrelude hiding (Handler, (</>))

import qualified Log
import qualified Web.ClientSession as ClientSession
import qualified Yesod
import qualified Yesod.Auth as Yesod
import qualified Yesod.Auth.Message as Yesod

import Database (SessionKey (..), Unique (UniqueUsername), UserId, userUsername)
import Database.Persist (entityKey, entityVal)
import Database.Persist.Sqlite (ConnectionPool, SqlBackend, runSqlPool)
import Git (GitImpl)
import Network.Wai.Logger (clockDateCacher)
import Path (GitBranch, PathSegment, pathSegmentFromDbString, toPath)
import Routes.Routes (routes)
import System.Log.FastLogger (defaultBufSize, newStderrLoggerSet)
import System.OsPath (OsPath, (</>))
import Text.Hamlet (hamletFile)
import Text.Lucius (luciusFile)
import Text.Shakespeare.Text (st)
import Yesod
    ( FormMessage
    , RenderMessage (..)
    , Yesod (..)
    , YesodPersist (..)
    , getYesod
    , liftHandler
    , mkYesodData
    , whamlet
    )
import Yesod.Auth (Auth, Creds (..), Route (LoginR, LogoutR), YesodAuth (..), YesodAuthPersist, getAuth)
import Yesod.Auth.HashDB (authHashDB)
import Yesod.Core.Types (Logger (..))

data HagiaSite = HagiaSite
    { projectsRoot :: !OsPath
    , baseUrl :: !Text
    , dbPool :: !ConnectionPool
    , git :: !GitImpl
    }

mkYesodData "HagiaSite" routes

instance Yesod HagiaSite where
    -- Logger in our format, outputs to stderr
    makeLogger _ = do
        loggerSet <- newStderrLoggerSet defaultBufSize
        (loggerDate, _) <- clockDateCacher
        pure Logger{loggerSet, loggerDate}
    messageLoggerSource _ Logger{loggerSet} = Log.logFast loggerSet

    authRoute _ = Just (AuthR LoginR)
    approot = Yesod.ApprootMaster baseUrl

    -- default middleware + csrf protection
    yesodMiddleware =
        Yesod.defaultCsrfSetCookieMiddleware
            . hagiaCsrfCheckMiddleware
            . Yesod.defaultYesodMiddleware
      where
        -- CSRF middleware breaks git authentication, so we disable it for git routes
        hagiaCsrfCheckMiddleware h =
            Yesod.csrfCheckMiddleware
                h
                (Yesod.getCurrentRoute >>= maybe (return False) isWriteNotGit)
                Yesod.defaultCsrfHeaderName
                Yesod.defaultCsrfParamName
        isWriteNotGit = \case
            RefsR _ _ -> pure False
            UploadPackR _ _ -> pure False
            ReceivePackR _ _ -> pure False
            other -> Yesod.isWriteRequest other

    -- Session backend that reads the key from the database
    -- TODO: maybe use transient sessions, don't persist the token and logout
    -- everyone on restart. Seems more secure.
    makeSessionBackend HagiaSite{dbPool} = do
        key <-
            flip runSqlPool dbPool $
                Yesod.selectList [] [] >>= \case
                    [] -> do
                        (sessionKeyValue, key) <- liftIO ClientSession.randomKey
                        _ <- Yesod.insert SessionKey{sessionKeyValue}
                        pure key
                    [v] ->
                        let SessionKey{sessionKeyValue} = entityVal v
                        in  case ClientSession.initKey sessionKeyValue of
                                Left err -> error $ "XXX" <> err
                                Right x -> pure x
                    _ -> error "XXX multiple results for session key"
        (getCachedDate, _closeDateCacher) <- Yesod.clientSessionDateCacher (2 * 60 * 60)
        pure . Just $ Yesod.clientSessionBackend key getCachedDate

    defaultLayout = hagiaLayout

instance RenderMessage HagiaSite FormMessage where
    renderMessage _ _ = Yesod.defaultFormMessage

instance YesodAuth HagiaSite where
    type AuthId HagiaSite = UserId
    authenticate Creds{credsIdent} =
        liftHandler . runDB $
            Yesod.getBy (UniqueUsername credsIdent) >>= \case
                Nothing -> pure $ Yesod.UserError Yesod.UserName
                Just x -> pure $ Yesod.Authenticated $ entityKey x

    loginDest _ = HomeR
    logoutDest _ = HomeR

    authPlugins _ = [authHashDB (Just . UniqueUsername)]

instance YesodAuthPersist HagiaSite

instance YesodPersist HagiaSite where
    type YesodPersistBackend HagiaSite = SqlBackend
    runDB action = do
        HagiaSite{dbPool} <- getYesod
        runSqlPool action dbPool

-- | Path to repository
repoPath :: PathSegment -> PathSegment -> Handler OsPath
repoPath user repo = do
    HagiaSite{projectsRoot} <- getYesod
    pure $ projectsRoot </> toPath user </> toPath repo

-- | Create layout with a header and messages. Add global styles
hagiaLayout :: Widget -> Handler Yesod.Html
hagiaLayout w = do
    let style = $(luciusFile "src/Templates/DefaultStyle.lucius")

    let headerStyle =
            makeStyle
                [ "width" .: "100%"
                , "height" .: "50px"
                , "gap" .: "10px"
                , "background" .: "black"
                , "color" .: "white"
                , "font-size" .: "20px"
                ]
    header <- do
        mbUsername <-
            maybeAuthId >>= \case
                Nothing -> pure Nothing
                Just uid -> fmap (pathSegmentFromDbString . userUsername) <$> runDB (Yesod.get uid)
        pure $
            Yesod.toWidget
                [whamlet|
                    <div .row style="#{headerStyle}">
                        <div style="margin-left: 10px">
                            <a .seamless-a style="font-size: 30px" href=@{HomeR}> Hagia
                        $maybe username <- mbUsername
                            <a href=@{UserR username} style="color: inherit; margin-left: auto"> #{username}
                            <a href=@{AuthR LogoutR} style="color: inherit; margin-right: 10px"> logout
                        $nothing
                            <a href=@{AuthR LoginR} style="color: inherit; margin-left: auto; margin-right: 10px"> log in
                |]

    messages <- Yesod.getMessages
    let messageStyle level =
            makeStyle
                [ "background" .: rgb (messageColor level)
                , "border-color" .: (rgb . darker $ messageColor level)
                , "font-size" .: "20px"
                , "text-align" .: "center"
                , "border-style" .: "solid"
                , "border-radius" .: "5px"
                , "border-width" .: "1px"
                , "padding" .: " 5px"
                ]
    let messageBlock =
            Yesod.toWidget
                [whamlet|
                    $if not (null messages)
                        <div .column-g5 .w100 style="margin-top: 5px">
                            $forall (level, msg) <- messages
                              <div .content-narrow style="#{messageStyle level}">#{msg}
                |]

    p <- Yesod.widgetToPageContent $ Yesod.toWidget style <> header <> messageBlock <> w
    Yesod.withUrlRenderer $ $(hamletFile "src/Templates/DefaultLayout.hamlet")
  where
    messageColor :: Text -> (Int, Int, Int)
    messageColor "success" = (153, 255, 204)
    messageColor _ = (255, 255, 153)
    darker (a, b, c) = (a `div` 2, b `div` 2, c `div` 2)
    rgb (a, b, c) = [st|rgb(#{a}, #{b}, #{c})|]

    makeStyle :: [(Text, Text)] -> Text
    makeStyle = intercalate ";\n" . map (\(k, v) -> k <> ": " <> v)

    (.:) :: a -> b -> (a, b)
    (.:) = (,)