module Web.ServerSession.Frontend.Wai.Internal
( withServerSession
, sessionStore
, mkSession
, KeyValue(..)
, createCookieTemplate
, calculateMaxAge
, forceInvalidate
) where
import Control.Applicative ((<$>))
import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString)
import Data.Default (def)
import Data.Text (Text)
import Web.PathPieces (toPathPiece)
import Web.ServerSession.Core
import Web.ServerSession.Core.Internal (absoluteTimeout, idleTimeout, persistentCookies)
import qualified Data.ByteString.Char8 as B8
import qualified Data.HashMap.Strict as HM
import qualified Data.IORef as I
import qualified Data.Text.Encoding as TE
import qualified Data.Time as TI
import qualified Data.Vault.Lazy as V
import qualified Network.Wai as W
import qualified Network.Wai.Session as WS
import qualified Web.Cookie as C
withServerSession
:: (Functor m, MonadIO m, MonadIO n, Storage sto, SessionData sto ~ SessionMap)
=> V.Key (WS.Session m Text ByteString)
-> (State sto -> State sto)
-> sto
-> n W.Middleware
withServerSession key opts storage = liftIO $ do
st <- opts <$> createState storage
return $
WS.withSession
(sessionStore st)
(TE.encodeUtf8 $ getCookieName st)
(createCookieTemplate st)
key
sessionStore
:: (Functor m, MonadIO m, Storage sto, KeyValue (SessionData sto))
=> State sto
-> WS.SessionStore m (Key (SessionData sto)) (Value (SessionData sto))
sessionStore state =
\mcookieVal -> do
(data1, saveSessionToken) <- loadSession state mcookieVal
sessionRef <- I.newIORef data1
let save = do
data2 <- I.atomicModifyIORef' sessionRef $ \a -> (a, a)
msession <- saveSession state saveSessionToken data2
return $ maybe "" (TE.encodeUtf8 . toPathPiece . sessionKey) msession
return (mkSession sessionRef, save)
mkSession :: (Functor m, MonadIO m, KeyValue sess) => I.IORef sess -> WS.Session m (Key sess) (Value sess)
mkSession sessionRef =
( \k -> kvLookup k <$> liftIO (I.atomicModifyIORef' sessionRef $ \a -> (a, a))
, \k v -> liftIO (I.atomicModifyIORef' sessionRef $ flip (,) () . kvInsert k v)
)
class IsSessionData sess => KeyValue sess where
type Key sess :: *
type Value sess :: *
kvLookup :: Key sess -> sess -> Maybe (Value sess)
kvInsert :: Key sess -> Value sess -> sess -> sess
instance KeyValue SessionMap where
type Key SessionMap = Text
type Value SessionMap = ByteString
kvLookup k = HM.lookup k . unSessionMap
kvInsert k v (SessionMap m) = SessionMap (HM.insert k v m)
createCookieTemplate :: State sto -> C.SetCookie
createCookieTemplate state =
def
{ C.setCookiePath = Just "/"
, C.setCookieMaxAge = calculateMaxAge state
, C.setCookieDomain = Nothing
, C.setCookieHttpOnly = getHttpOnlyCookies state
, C.setCookieSecure = getSecureCookies state
}
calculateMaxAge :: State sto -> Maybe TI.DiffTime
calculateMaxAge st = do
guard (persistentCookies st)
return $ maybe (60*60*24*3652) realToFrac
$ idleTimeout st `max` absoluteTimeout st
forceInvalidate :: WS.Session m Text ByteString -> ForceInvalidate -> m ()
forceInvalidate (_, insert) = insert forceInvalidateKey . B8.pack . show