{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module Web.Spock.Config
  ( SpockCfg (..),
    defaultSpockCfg,
    defaultBrowserSpockCfg,
    SlashPolicy (..),

    -- * Database
    PoolOrConn (..),
    ConnBuilder (..),
    PoolCfg (..),

    -- * Sessions
    defaultSessionCfg,
    SessionCfg (..),
    SessionBackend (..),
    ServerSessionCfg (..),
    defaultServerSessionCfg,
    ClientSessionCfg (..),
    ClientSessionCodec (..),
    defaultClientSessionCfg,
    SessionMode (..),
    SessionError (..),
    CookieSettings (..),
    SameSite (..),
    CookieEOL (..),
    defaultSessionHooks,
    SessionHooks (..),
    SessionStore (..),
    SessionStoreInstance (..),
    SV.newStmSessionStore,
  )
where

#if MIN_VERSION_base(4,11,0)
#elif MIN_VERSION_base(4,9,0)
import Data.Semigroup
#else
import Data.Monoid
#endif

import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Network.HTTP.Types.Status
import System.IO
import Data.Time (getCurrentTime)
import Web.Spock.Action
import Web.Spock.Core (SlashPolicy (..))
import qualified Web.Spock.Internal.SessionVault as SV
import Web.Spock.Internal.Types

-- | NOP session hooks
defaultSessionHooks :: SessionHooks a
defaultSessionHooks :: forall a. SessionHooks a
defaultSessionHooks =
  SessionHooks
    { sh_removed :: HashMap Text a -> IO ()
sh_removed = IO () -> HashMap Text a -> IO ()
forall a b. a -> b -> a
const (IO () -> HashMap Text a -> IO ())
-> IO () -> HashMap Text a -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }

-- | Session configuration with reasonable defaults and an
-- stm based session store
defaultSessionCfg :: a -> IO (SessionCfg conn a st)
defaultSessionCfg :: forall a conn st. a -> IO (SessionCfg conn a st)
defaultSessionCfg a
emptySession =
  do
    store <- IO (SessionStoreInstance (Session conn a st))
forall conn sess st.
IO (SessionStoreInstance (Session conn sess st))
SV.newStmSessionStore
    return
      SessionCfg
        { sc_sessionMode = SessionsOnDemand,
          sc_cookieName = "spockcookie",
          sc_cookieSettings = defaultCookieSettings {cs_EOL = CookieValidForever, cs_HTTPOnly = True},
          sc_sessionTTL = 3600,
          sc_sessionIdEntropy = 64,
          sc_sessionExpandTTL = True,
          sc_emptySession = emptySession,
          sc_backend = ServerSessions $ defaultServerSessionCfg store
        }

defaultServerSessionCfg :: SessionStoreInstance (Session conn sess st) -> ServerSessionCfg conn sess st
defaultServerSessionCfg :: forall conn sess st.
SessionStoreInstance (Session conn sess st)
-> ServerSessionCfg conn sess st
defaultServerSessionCfg SessionStoreInstance (Session conn sess st)
store = SessionStoreInstance (Session conn sess st)
-> NominalDiffTime
-> SessionHooks sess
-> ServerSessionCfg conn sess st
forall conn sess st.
SessionStoreInstance (Session conn sess st)
-> NominalDiffTime
-> SessionHooks sess
-> ServerSessionCfg conn sess st
ServerSessionCfg SessionStoreInstance (Session conn sess st)
store (NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
10) SessionHooks sess
forall a. SessionHooks a
defaultSessionHooks

defaultClientSessionCfg :: ClientSessionCodec sess -> ClientSessionCfg sess
defaultClientSessionCfg :: forall sess. ClientSessionCodec sess -> ClientSessionCfg sess
defaultClientSessionCfg ClientSessionCodec sess
codec = ClientSessionCodec sess
-> Int -> IO UTCTime -> ClientSessionCfg sess
forall sess.
ClientSessionCodec sess
-> Int -> IO UTCTime -> ClientSessionCfg sess
ClientSessionCfg ClientSessionCodec sess
codec Int
4096 IO UTCTime
getCurrentTime

-- | Spock configuration with reasonable defaults such as a basic error page
-- and 5MB request body limit. IMPORTANT: CSRF Protection is turned off by
-- default for now to not break any existing Spock applications. Consider
-- turning it on manually as it will become the default in the future.
defaultSpockCfg :: sess -> PoolOrConn conn -> st -> IO (SpockCfg conn sess st)
defaultSpockCfg :: forall sess conn st.
sess -> PoolOrConn conn -> st -> IO (SpockCfg conn sess st)
defaultSpockCfg sess
sess PoolOrConn conn
conn st
st =
  do
    defSess <- sess -> IO (SessionCfg conn sess st)
forall a conn st. a -> IO (SessionCfg conn a st)
defaultSessionCfg sess
sess
    return
      SpockCfg
        { spc_initialState = st,
          spc_database = conn,
          spc_sessionCfg = defSess,
          spc_maxRequestSize = Just (5 * 1024 * 1024),
          spc_logError = T.hPutStrLn stderr,
          spc_logging = Nothing,
          spc_slashPolicy = IgnoreSlashes,
          spc_errorHandler = errorHandler,
          spc_csrfProtection = False,
          spc_csrfHeaderName = "X-Csrf-Token",
          spc_csrfPostName = "__csrf_token"
        }

-- | An opt-in configuration for HTTPS browser applications: on-demand sessions,
-- CSRF checks, and Secure, HttpOnly, SameSite=Lax browser-session cookies.
-- For local HTTP development, explicitly override 'cs_secure' to 'False'.
defaultBrowserSpockCfg :: sess -> PoolOrConn conn -> st -> IO (SpockCfg conn sess st)
defaultBrowserSpockCfg :: forall sess conn st.
sess -> PoolOrConn conn -> st -> IO (SpockCfg conn sess st)
defaultBrowserSpockCfg sess
sess PoolOrConn conn
conn st
st = do
  cfg <- sess -> PoolOrConn conn -> st -> IO (SpockCfg conn sess st)
forall sess conn st.
sess -> PoolOrConn conn -> st -> IO (SpockCfg conn sess st)
defaultSpockCfg sess
sess PoolOrConn conn
conn st
st
  let sessions = SpockCfg conn sess st -> SessionCfg conn sess st
forall conn sess st.
SpockCfg conn sess st -> SessionCfg conn sess st
spc_sessionCfg SpockCfg conn sess st
cfg
  pure cfg
    { spc_csrfProtection = True,
      spc_sessionCfg = sessions
        { sc_sessionMode = SessionsOnDemand,
          sc_cookieSettings = (sc_cookieSettings sessions)
            { cs_EOL = CookieValidForSession,
              cs_HTTPOnly = True,
              cs_secure = True,
              cs_sameSite = Just SameSiteLax }
        }
    }

errorHandler :: Status -> ActionCtxT () IO ()
errorHandler :: Status -> ActionCtxT () IO ()
errorHandler Status
status = Text -> ActionCtxT () IO ()
forall (m :: * -> *) ctx a. MonadIO m => Text -> ActionCtxT ctx m a
html (Text -> ActionCtxT () IO ()) -> Text -> ActionCtxT () IO ()
forall a b. (a -> b) -> a -> b
$ Status -> Text
errorTemplate Status
status

-- Danger! This should better be done using combinators, but we do not
-- want Spock depending on a specific html combinator framework
errorTemplate :: Status -> T.Text
errorTemplate :: Status -> Text
errorTemplate Status
s =
  Text
"<html><head>"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<title>"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
message
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</title>"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</head>"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<body>"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<h1>"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
message
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</h1>"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<a href='https://www.spock.li'>powered by Spock</a>"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</body>"
  where
    message :: Text
message =
      Int -> Text
showT (Status -> Int
statusCode Status
s) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (Status -> ByteString
statusMessage Status
s)
    showT :: Int -> Text
showT = String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show