module Foundation.Yesod.Session
  ( makeSessionBackend
  ) where

import Import.NoFoundation hiding (makeSessionBackend)

import Foundation.Routes
import Foundation.Type

import qualified Web.ServerSession.Core as ServerSession
import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession

import qualified Network.Wai as W
import qualified Network.HTTP.Types.Header as W
import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
import qualified Network.HTTP.Types as HTTP

import qualified Data.Map as Map

import Web.Cookie


makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = noCreateFor (return . forRoute isError) . notFor isUserGenerated . notFor isBearer . sameSite $ case appSessionStore of
  SessionStorageMemcachedSql sqlStore
    -> mkBackend . stateSettings =<< ServerSession.createState sqlStore
  SessionStorageAcid acidStore
    | appServerSessionAcidFallback
      -> mkBackend . stateSettings =<< ServerSession.createState acidStore
  _other
    -> return Nothing
  where
    cfg = JwtSession.ServerSessionJwtConfig
      { sJwtJwkSet             = appJSONWebKeySet
      , sJwtStart              = appSessionTokenStart
      , sJwtExpiration         = appSessionTokenExpiration
      , sJwtEncoding           = appSessionTokenEncoding
      , sJwtIssueBy            = appInstanceID
      , sJwtIssueFor           = appClusterID
      , sJwtClockLeniencyStart = appSessionTokenClockLeniencyStart
      , sJwtClockLeniencyEnd   = appSessionTokenClockLeniencyEnd
      }
    mkBackend :: forall sto.
               ( ServerSession.SessionData sto ~ Map Text ByteString
               , ServerSession.Storage sto
               )
              => ServerSession.State sto -> IO (Maybe SessionBackend)
    mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
    stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
    stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
    sameSite
      | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
      = strictSameSiteSessions
      | Just sameSiteLax    == cookieSameSite (getCookieSettings app CookieSession)
      = laxSameSiteSessions
      | otherwise
      = id

    notFor :: (W.Request -> IO Bool) -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
    notFor f = fmap $ fmap notFor'
      where notFor' :: SessionBackend -> SessionBackend
            notFor' (SessionBackend load) = SessionBackend $ \req -> do
              pMatches <- f req
              if | not pMatches -> load req
                 | otherwise    -> return (mempty, const $ return [])

    noCreateFor :: (W.Request -> IO Bool) -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
    noCreateFor f = fmap $ fmap notFor'
      where notFor' :: SessionBackend -> SessionBackend
            notFor' (SessionBackend load) = SessionBackend $ \req -> do
              pMatches <- f req
              if | not pMatches -> load req
                 | otherwise    -> noCreate <$> load req
            noCreate resp@(session, _)
              | Map.null session = (session, const $ return [])
              | otherwise = resp

    forRoute :: (Route UniWorX -> Bool) -> (W.Request -> Bool)
    forRoute f req = maybe False f mRoute
      where mRoute = parseRoute
              ( W.pathInfo req
              , over (mapped . _2) (fromMaybe "") . HTTP.queryToQueryText $ W.queryString req
              )


    isBearer req = return $ if
      | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
      , any (is _Just . W.extractBearerAuth) aHdrs
        -> True
      | otherwise
        -> False

    isUserGenerated req = return $ if
      | Just approotHost <- approotScopeHost ApprootUserGenerated app
      , Just reqHost <- W.requestHeaderHost req
      , views _appRoot ($ ApprootUserGenerated) app /= views _appRoot ($ ApprootDefault) app
      , reqHost == approotHost
        -> True
      | otherwise
        -> False

    isError = \case
      ErrorR -> True
      _other -> False