{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Web.Spock.Internal.ClientSession (createClientSessionManager) where

import Control.Concurrent.MVar
import Control.Exception (throwIO)
import Control.Monad (when)
import Control.Monad.IO.Class
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as T
import Data.Time
import qualified Data.Vault.Lazy as V
import Network.HTTP.Types.URI (urlDecode)
import qualified Network.Wai as Wai
import qualified Web.Cookie as Cookie
import Web.Spock.Internal.Cookies
import Web.Spock.Internal.SessionCommon
import Web.Spock.Internal.Types
import Web.Spock.Internal.Util (mapReqHeaders)

data ClientState conn sess st
  = Unloaded (Maybe BS.ByteString)
  | Loaded (Session conn sess st)
  | Destroyed

-- Both state and the pending response cookie commit together. An encoding or
-- size failure leaves the last successful session operation intact.
type ClientCell conn sess st = MVar (ClientState conn sess st, Maybe BS.ByteString)

createClientSessionManager :: MonadIO m => SessionCfg conn sess st -> ClientSessionCfg sess -> SessionIf m -> IO (SessionManager m conn sess st)
createClientSessionManager :: forall (m :: * -> *) conn sess st.
MonadIO m =>
SessionCfg conn sess st
-> ClientSessionCfg sess
-> SessionIf m
-> IO (SessionManager m conn sess st)
createClientSessionManager SessionCfg conn sess st
cfg ClientSessionCfg sess
client SessionIf m
sif = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClientSessionCfg sess -> Int
forall sess. ClientSessionCfg sess -> Int
csc_maxCookieBytes ClientSessionCfg sess
client Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| ClientSessionCfg sess -> Int
forall sess. ClientSessionCfg sess -> Int
csc_maxCookieBytes ClientSessionCfg sess
client Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4096
        Bool -> Bool -> Bool
|| SessionCfg conn sess st -> NominalDiffTime
forall conn a st. SessionCfg conn a st -> NominalDiffTime
sc_sessionTTL SessionCfg conn sess st
cfg NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
0 Bool -> Bool -> Bool
|| SessionCfg conn sess st -> Int
forall conn a st. SessionCfg conn a st -> Int
sc_sessionIdEntropy SessionCfg conn sess st
cfg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16
        Bool -> Bool -> Bool
|| SessionCfg conn sess st -> Int
forall conn a st. SessionCfg conn a st -> Int
sc_sessionIdEntropy SessionCfg conn sess st
cfg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
256) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    SessionError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SessionError
InvalidClientSessionConfig
  key <- IO (Key (MVar (ClientState conn sess st, Maybe ByteString)))
forall a. IO (Key a)
V.newKey
  let withCell MVar (ClientState conn sess st, Maybe ByteString) -> IO a
action
        | SessionCfg conn sess st -> SessionMode
forall conn a st. SessionCfg conn a st -> SessionMode
sc_sessionMode SessionCfg conn sess st
cfg SessionMode -> SessionMode -> Bool
forall a. Eq a => a -> a -> Bool
== SessionMode
SessionsDisabled = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ SessionError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SessionError
SessionUseWhenDisabled
        | Bool
otherwise = do
            cell <- SessionIf m -> forall a. Key a -> m (Maybe a)
forall (m :: * -> *). SessionIf m -> forall a. Key a -> m (Maybe a)
si_queryVault SessionIf m
sif Key (MVar (ClientState conn sess st, Maybe ByteString))
key
            maybe (liftIO $ throwIO ClientSessionOutsideRequest) (liftIO . action) cell
      readCurrent = (MVar (ClientState conn sess st, Maybe ByteString)
 -> IO (Session conn sess st))
-> m (Session conn sess st)
forall {a}.
(MVar (ClientState conn sess st, Maybe ByteString) -> IO a) -> m a
withCell ((MVar (ClientState conn sess st, Maybe ByteString)
  -> IO (Session conn sess st))
 -> m (Session conn sess st))
-> (MVar (ClientState conn sess st, Maybe ByteString)
    -> IO (Session conn sess st))
-> m (Session conn sess st)
forall a b. (a -> b) -> a -> b
$ SessionCfg conn sess st
-> ClientSessionCfg sess
-> Bool
-> (Session conn sess st
    -> IO (Session conn sess st, Session conn sess st))
-> MVar (ClientState conn sess st, Maybe ByteString)
-> IO (Session conn sess st)
forall conn sess st a.
SessionCfg conn sess st
-> ClientSessionCfg sess
-> Bool
-> (Session conn sess st -> IO (Session conn sess st, a))
-> ClientCell conn sess st
-> IO a
operate SessionCfg conn sess st
cfg ClientSessionCfg sess
client Bool
False (\Session conn sess st
s -> (Session conn sess st, Session conn sess st)
-> IO (Session conn sess st, Session conn sess st)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Session conn sess st
s, Session conn sess st
s))
      change Session conn sess st -> IO (Session conn sess st, a)
f = (MVar (ClientState conn sess st, Maybe ByteString) -> IO a) -> m a
forall {a}.
(MVar (ClientState conn sess st, Maybe ByteString) -> IO a) -> m a
withCell ((MVar (ClientState conn sess st, Maybe ByteString) -> IO a)
 -> m a)
-> (MVar (ClientState conn sess st, Maybe ByteString) -> IO a)
-> m a
forall a b. (a -> b) -> a -> b
$ SessionCfg conn sess st
-> ClientSessionCfg sess
-> Bool
-> (Session conn sess st -> IO (Session conn sess st, a))
-> MVar (ClientState conn sess st, Maybe ByteString)
-> IO a
forall conn sess st a.
SessionCfg conn sess st
-> ClientSessionCfg sess
-> Bool
-> (Session conn sess st -> IO (Session conn sess st, a))
-> ClientCell conn sess st
-> IO a
operate SessionCfg conn sess st
cfg ClientSessionCfg sess
client Bool
True Session conn sess st -> IO (Session conn sess st, a)
f
      middleware Request -> (Response -> IO b) -> IO b
app Request
req Response -> IO b
respond
        | SessionCfg conn sess st -> SessionMode
forall conn a st. SessionCfg conn a st -> SessionMode
sc_sessionMode SessionCfg conn sess st
cfg SessionMode -> SessionMode -> Bool
forall a. Eq a => a -> a -> Bool
== SessionMode
SessionsDisabled = Request -> (Response -> IO b) -> IO b
app Request
req Response -> IO b
respond
        | Bool
otherwise = do
            let raw :: Maybe ByteString
raw = CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"Cookie" (Request -> [(CI ByteString, ByteString)]
Wai.requestHeaders Request
req) Maybe ByteString
-> (ByteString -> Maybe ByteString) -> Maybe ByteString
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                  ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ SessionCfg conn sess st -> Text
forall conn a st. SessionCfg conn a st -> Text
sc_cookieName SessionCfg conn sess st
cfg) ([(ByteString, ByteString)] -> Maybe ByteString)
-> (ByteString -> [(ByteString, ByteString)])
-> ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, ByteString)]
Cookie.parseCookies
                incoming :: Maybe ByteString
incoming = Maybe ByteString
raw Maybe ByteString
-> (ByteString -> Maybe ByteString) -> Maybe ByteString
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
v -> if ByteString -> Int
BS.length ByteString
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= ClientSessionCfg sess -> Int
forall sess. ClientSessionCfg sess -> Int
csc_maxCookieBytes ClientSessionCfg sess
client
                  then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Bool -> ByteString -> ByteString
urlDecode Bool
False ByteString
v) else Maybe ByteString
forall a. Maybe a
Nothing
            cell <- (ClientState conn sess st, Maybe ByteString)
-> IO (MVar (ClientState conn sess st, Maybe ByteString))
forall a. a -> IO (MVar a)
newMVar (Maybe ByteString -> ClientState conn sess st
forall conn sess st. Maybe ByteString -> ClientState conn sess st
Unloaded Maybe ByteString
incoming, Maybe ByteString
forall a. Maybe a
Nothing)
            when (sc_sessionMode cfg == SessionsAlways) $
              operate cfg client False (\Session conn sess st
s -> (Session conn sess st, ()) -> IO (Session conn sess st, ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Session conn sess st
s, ())) cell
            app (req { Wai.vault = V.insert key cell (Wai.vault req) }) $ \Response
response -> do
              (_, pending) <- MVar (ClientState conn sess st, Maybe ByteString)
-> IO (ClientState conn sess st, Maybe ByteString)
forall a. MVar a -> IO a
readMVar MVar (ClientState conn sess st, Maybe ByteString)
cell
              respond $ maybe response (\ByteString
v -> ([(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)])
-> Response -> Response
mapReqHeaders ((CI ByteString
"Set-Cookie", ByteString
v) (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
:) Response
response) pending
  pure SessionManager
    { sm_getSessionId = sess_id <$> readCurrent,
      sm_getCsrfToken = sess_csrfToken <$> readCurrent,
      sm_readSession = sess_data <$> readCurrent,
      sm_writeSession = \sess
value -> (Session conn sess st -> IO (Session conn sess st, ())) -> m ()
forall {a}.
(Session conn sess st -> IO (Session conn sess st, a)) -> m a
change ((Session conn sess st -> IO (Session conn sess st, ())) -> m ())
-> (Session conn sess st -> IO (Session conn sess st, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \Session conn sess st
s -> (Session conn sess st, ()) -> IO (Session conn sess st, ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Session conn sess st
s { sess_data = value }, ()),
      sm_modifySession = \sess -> (sess, a)
f -> (Session conn sess st -> IO (Session conn sess st, a)) -> m a
forall {a}.
(Session conn sess st -> IO (Session conn sess st, a)) -> m a
change ((Session conn sess st -> IO (Session conn sess st, a)) -> m a)
-> (Session conn sess st -> IO (Session conn sess st, a)) -> m a
forall a b. (a -> b) -> a -> b
$ \Session conn sess st
s ->
        let (sess
value, a
result) = sess -> (sess, a)
f (Session conn sess st -> sess
forall conn sess st. Session conn sess st -> sess
sess_data Session conn sess st
s) in (Session conn sess st, a) -> IO (Session conn sess st, a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Session conn sess st
s { sess_data = value }, a
result),
      sm_regenerateSessionId = change $ \Session conn sess st
s -> do
        now <- ClientSessionCfg sess -> IO UTCTime
forall sess. ClientSessionCfg sess -> IO UTCTime
csc_clock ClientSessionCfg sess
client
        fresh <- createSessionAt cfg now (sess_data s)
        pure (fresh, ()),
      sm_destroySession = withCell $ \MVar (ClientState conn sess st, Maybe ByteString)
cell -> MVar (ClientState conn sess st, Maybe ByteString)
-> ((ClientState conn sess st, Maybe ByteString)
    -> IO (ClientState conn sess st, Maybe ByteString))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (ClientState conn sess st, Maybe ByteString)
cell (((ClientState conn sess st, Maybe ByteString)
  -> IO (ClientState conn sess st, Maybe ByteString))
 -> IO ())
-> ((ClientState conn sess st, Maybe ByteString)
    -> IO (ClientState conn sess st, Maybe ByteString))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(ClientState conn sess st, Maybe ByteString)
_ -> do
        now <- ClientSessionCfg sess -> IO UTCTime
forall sess. ClientSessionCfg sess -> IO UTCTime
csc_clock ClientSessionCfg sess
client
        let settings = (SessionCfg conn sess st -> CookieSettings
forall conn a st. SessionCfg conn a st -> CookieSettings
sc_cookieSettings SessionCfg conn sess st
cfg) { cs_EOL = CookieValidFor 0 }
        header <- checkedHeader client $ generateCookieHeaderString (sc_cookieName cfg) "" settings now
        pure (Destroyed, Just header),
      sm_serverSessions = Nothing,
      sm_middleware = middleware,
      sm_closeSessionManager = pure ()
    }

operate :: SessionCfg conn sess st -> ClientSessionCfg sess -> Bool ->
  (Session conn sess st -> IO (Session conn sess st, a)) -> ClientCell conn sess st -> IO a
operate :: forall conn sess st a.
SessionCfg conn sess st
-> ClientSessionCfg sess
-> Bool
-> (Session conn sess st -> IO (Session conn sess st, a))
-> ClientCell conn sess st
-> IO a
operate SessionCfg conn sess st
cfg ClientSessionCfg sess
client Bool
changed Session conn sess st -> IO (Session conn sess st, a)
f ClientCell conn sess st
cell = ClientCell conn sess st
-> ((ClientState conn sess st, Maybe ByteString)
    -> IO ((ClientState conn sess st, Maybe ByteString), a))
-> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar ClientCell conn sess st
cell (((ClientState conn sess st, Maybe ByteString)
  -> IO ((ClientState conn sess st, Maybe ByteString), a))
 -> IO a)
-> ((ClientState conn sess st, Maybe ByteString)
    -> IO ((ClientState conn sess st, Maybe ByteString), a))
-> IO a
forall a b. (a -> b) -> a -> b
$ \(ClientState conn sess st
state, Maybe ByteString
pending) -> do
  now <- ClientSessionCfg sess -> IO UTCTime
forall sess. ClientSessionCfg sess -> IO UTCTime
csc_clock ClientSessionCfg sess
client
  (session, reissue) <- resolve now state
  (updated, result) <- f session
  cookie <- if changed || reissue
    then do
      encoded <- csc_encode (csc_codec client) (sc_cookieName cfg) updated
      value <- either (const $ throwIO InvalidClientSessionConfig) pure (T.decodeUtf8' encoded)
      header <- checkedHeader client $ generateCookieHeaderString (sc_cookieName cfg) value (sc_cookieSettings cfg) now
      pure (Just header)
    else pure pending
  pure ((Loaded updated, cookie), result)
  where
    fresh :: UTCTime -> IO (Session conn sess st, Bool)
fresh UTCTime
now = do
      session <- SessionCfg conn sess st
-> UTCTime -> sess -> IO (Session conn sess st)
forall conn sess st.
SessionCfg conn sess st
-> UTCTime -> sess -> IO (Session conn sess st)
createSessionAt SessionCfg conn sess st
cfg UTCTime
now (SessionCfg conn sess st -> sess
forall conn a st. SessionCfg conn a st -> a
sc_emptySession SessionCfg conn sess st
cfg)
      pure (session, True)
    resolve :: UTCTime
-> ClientState conn sess st -> IO (Session conn sess st, Bool)
resolve UTCTime
now (Unloaded Maybe ByteString
raw) = do
      decoded <- IO (Maybe (Session conn sess st, Bool))
-> (ByteString -> IO (Maybe (Session conn sess st, Bool)))
-> Maybe ByteString
-> IO (Maybe (Session conn sess st, Bool))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Session conn sess st, Bool)
-> IO (Maybe (Session conn sess st, Bool))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Session conn sess st, Bool)
forall a. Maybe a
Nothing) (ClientSessionCodec sess
-> forall conn st.
   Text -> ByteString -> IO (Maybe (Session conn sess st, Bool))
forall sess.
ClientSessionCodec sess
-> forall conn st.
   Text -> ByteString -> IO (Maybe (Session conn sess st, Bool))
csc_decode (ClientSessionCfg sess -> ClientSessionCodec sess
forall sess. ClientSessionCfg sess -> ClientSessionCodec sess
csc_codec ClientSessionCfg sess
client) (SessionCfg conn sess st -> Text
forall conn a st. SessionCfg conn a st -> Text
sc_cookieName SessionCfg conn sess st
cfg)) Maybe ByteString
raw
      case decoded of
        Just (Session conn sess st
s, Bool
rotate) | Session conn sess st -> UTCTime
forall conn sess st. Session conn sess st -> UTCTime
sess_validUntil Session conn sess st
s UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now ->
          if SessionCfg conn sess st -> Bool
forall conn a st. SessionCfg conn a st -> Bool
sc_sessionExpandTTL SessionCfg conn sess st
cfg
            then (Session conn sess st, Bool) -> IO (Session conn sess st, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Session conn sess st
s { sess_validUntil = max (sess_validUntil s) (addUTCTime (sc_sessionTTL cfg) now) }, Bool
True)
            else (Session conn sess st, Bool) -> IO (Session conn sess st, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Session conn sess st
s, Bool
rotate)
        Maybe (Session conn sess st, Bool)
_ -> UTCTime -> IO (Session conn sess st, Bool)
fresh UTCTime
now
    resolve UTCTime
now (Loaded Session conn sess st
s)
      | Session conn sess st -> UTCTime
forall conn sess st. Session conn sess st -> UTCTime
sess_validUntil Session conn sess st
s UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now = (Session conn sess st, Bool) -> IO (Session conn sess st, Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Session conn sess st
s, Bool
False)
      | Bool
otherwise = UTCTime -> IO (Session conn sess st, Bool)
fresh UTCTime
now
    resolve UTCTime
now ClientState conn sess st
Destroyed = UTCTime -> IO (Session conn sess st, Bool)
fresh UTCTime
now

checkedHeader :: ClientSessionCfg sess -> BS.ByteString -> IO BS.ByteString
checkedHeader :: forall sess. ClientSessionCfg sess -> ByteString -> IO ByteString
checkedHeader ClientSessionCfg sess
client ByteString
header
  | ByteString -> Int
BS.length ByteString
header Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ClientSessionCfg sess -> Int
forall sess. ClientSessionCfg sess -> Int
csc_maxCookieBytes ClientSessionCfg sess
client = SessionError -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SessionError
ClientSessionCookieTooLarge
  | Bool
otherwise = ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
header