module Framework
    ( safetyHeaders
    , redirectBack
    , getA
    , getAuth
    , postA
    , postAuth
    , render
    , partialRender
    , prepareRequest
    , limitHttpMethods
    , htmxRedirectMiddleware
    , isHtmx
    ) where

import Types
import Models
import qualified Web.Scotty.Trans as Scotty
import Web.Scotty.Trans (RoutePattern, redirect, request, html)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Network.Wai ( Middleware, mapResponseHeaders, rawPathInfo,
    Request (..), responseStatus, responseLBS)
import qualified Data.Text as T
import qualified Lucid.Base as Lucid
import Control.Monad.Reader (Reader, lift, runReader, ask, runReaderT, asks)
import qualified Web
import Cookies
import qualified Repos.Users as Users
import qualified Repos.Stories as Stories
import Utils
import qualified Data.Text.Encoding as T
import Web.Scotty.Internal.Types (ActionT(..))
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text.Lazy as TL
import Colog (LogAction)
import qualified Data.ByteString as BS
import qualified Data.Aeson as JSON
import Network.HTTP.Types (parseMethod, Status (..), status400)
import Data.Time (diffUTCTime)
import qualified Data.Vault.Lazy as V
import Database.SQLite.Simple (Connection)
import Repos.Utils (CanDB)

type PreActionR a = ActionT App a
type PreAction = PreActionR ()

safetyHeaders :: Middleware
safetyHeaders app req resp = do
    app req $ resp . mapResponseHeaders (\h ->
        -- ("Content-Security-Policy", "default-src 'self';") :
        ("X-Content-Type-Options", "nosniff") :
        ("X-Frame-Options", "deny") :
        ("X-XSS-Protection", "0") : h)

redirectBack :: Monad m => ActionT m a
redirectBack = do
    req <- request
    let referer = TL.fromStrict . T.decodeUtf8 <$> requestHeaderReferer req
    redirect $ fromMaybe "/" referer

getCSRF :: PreActionR T.Text
getCSRF = do
    mCookieToken <- getCookie "csrf_token"
    case mCookieToken of
        Nothing -> do
            -- TODO crypto secure token
            setCookie "csrf_token" "abc123"
            return "abc123"
        Just cookieToken ->
            return cookieToken

basicHandler :: Action () -> PreAction
basicHandler handler = do
    csrf <- getCSRF
    path <- fmap (.rawPathInfo) request
    reqInfo <- getReqInfo
    let reqId = reqInfo.reqId
    let user = reqInfo.user
    env <- lift getEnv
    let ctx = Ctx reqId csrf (T.decodeUtf8 path)
    let envCtx = EnvCtx env ctx user
    scottyEnv <- ask
    let runSc = runReaderT handler.runAM scottyEnv
    liftIO $ runReaderT runSc.runHandler envCtx

basicAuthHandler :: ActionAuth () -> PreAction
basicAuthHandler handler = do
    csrf <- getCSRF
    path <- fmap (.rawPathInfo) request
    reqInfo <- getReqInfo
    let reqId = reqInfo.reqId
    user <- case reqInfo.user of
        Just u -> return u
        Nothing -> redirect "/login"
    env <- lift getEnv
    let ctx = Ctx reqId csrf (T.decodeUtf8 path)
    let envCtxAuth = EnvCtxAuth env ctx user
    scottyEnv <- ask
    let runSc = runReaderT handler.runAM scottyEnv
    liftIO $ runReaderT runSc.runHandler envCtxAuth

getReqInfo :: PreActionR ReqInfo
getReqInfo = do
    key <- lift $ asks (.reqInfoKey)
    v <- fmap (.vault) request
    let reqInfo = V.lookup key v
    case reqInfo of
        Just r -> return r
        -- TODO error handling
        Nothing -> return $ ReqInfo "" Nothing

getA :: RoutePattern -> Action () -> Server
getA route handler = do
    Scotty.get route $ do
        basicHandler handler

getAuth :: RoutePattern -> ActionAuth () -> Server
getAuth route handler = do
    Scotty.get route $ do
        basicAuthHandler handler

postA :: RoutePattern -> Action () -> Server
postA route handler = do
    Scotty.post route $ do
        basicHandler handler

postAuth :: RoutePattern -> ActionAuth () -> Server
postAuth route handler = do
    Scotty.post route $ do
        basicAuthHandler handler

render :: (HasUser m, HasCtx m, CanDB m, MonadIO m) =>
     Lucid.HtmlT (Reader Web.Context) () -> ActionT m ()
render content = do
    csrfToken <- lift $ fmap (.csrf) getCtx
    mUser <- lift getUser
    lastStories <- lift $ Stories.lastStories 3
    let context = Web.Context mUser csrfToken lastStories
    let page = runReader (Lucid.renderTextT (Web.root content)) context
    html page

partialRender :: (HasUser m, HasCtx m, CanDB m, MonadIO m) =>
     Lucid.HtmlT (Reader Web.Context) () -> ActionT m ()
partialRender content = do
    csrfToken <- lift $ fmap (.csrf) getCtx
    mUser <- lift getUser
    lastStories <- lift $ Stories.lastStories 3
    let context = Web.Context mUser csrfToken lastStories
    let page = runReader (Lucid.renderTextT content) context
    html page

limitHttpMethods :: Middleware
limitHttpMethods app req resp = do
    let method = parseMethod req.requestMethod
    case method of
        Left _ -> resp $ responseLBS status400 [] ""
        Right _ -> app req resp

isHtmx :: Monad m => ActionT m Bool
isHtmx = isJust <$> Scotty.header "HX-Request"

htmxRedirectMiddleware :: Middleware
htmxRedirectMiddleware app req resp = do
    let htmx = isJust $ lookup "HX-Request" $ req.requestHeaders
    app req $ \r -> do
        if htmx then do resp
            . mapResponseHeaders (map (\(k, v) -> do
                if k == "Location" then ("HX-redirect", v)
                else (k, v)
            )) $ r
        else do resp r

prepareRequest :: V.Key ReqInfo -> Connection -> LogAction IO BS.ByteString -> Middleware
prepareRequest vaultKey conn logger app req resp = do
    start <- now
    reqId <- shortId

    let method = T.decodeUtf8 req.requestMethod
    let headers = req.requestHeaders
    let cookies = T.decodeUtf8 <$> lookup "Cookie" headers
    let session = getCookieFromHeader cookies "session"

    user <- case session of
        Just s -> Users.bySession' conn s
        Nothing -> return Nothing
    let csrfCookie = getCookieFromHeader cookies "csrf_token"

    let reqInfo = ReqInfo reqId user
    let newVault = V.insert vaultKey reqInfo (vault req)
    let newReq = req { vault = newVault }

    let path = T.decodeUtf8 req.rawPathInfo
    liftIO $ logJson logger
        [ ("requestId", JSON.toJSON reqId)
        , ("path", JSON.toJSON $ method <> " " <> path)
        , ("time", JSON.toJSON start)
        , ("user", JSON.toJSON $ (.id) <$> user)
        ]
    app newReq $ \r -> do
        let status = responseStatus r
        stop <- now
        let dt :: Int = round $ 1000 * diffUTCTime stop start
        liftIO $ logJson logger
            [ ("requestId", JSON.toJSON reqId)
            , ("status", JSON.toJSON $ status.statusCode)
            , ("dt", JSON.toJSON $ show dt ++ "ms")
            , ("time", JSON.toJSON stop)
            , ("user", JSON.toJSON $ (.id) <$> user)
            ]
        resp r