module Network.Wai.Session where
import Data.Time
import qualified Data.ByteString as BS
import Blaze.ByteString.Builder (toByteString)
import Data.Vault.Lazy (Key)
import qualified Data.Vault.Lazy as V
import Network.Wai.Trans
import Network.HTTP.Types
import Web.Cookie
data SessionConfig m k v = SessionConfig
{ renderKey :: k -> BS.ByteString
, renderVal :: v -> BS.ByteString
, parseKey :: BS.ByteString -> Maybe k
, parseVal :: BS.ByteString -> Maybe v
, keyName :: BS.ByteString
, valName :: BS.ByteString
, expire :: Integer
, newVal :: k -> v -> m (Maybe v)
, vaultVar :: Key k
}
sessionMiddleware :: Monad m => SessionConfig m k v -> MiddlewareT m
sessionMiddleware cfg app req respond =
case parseSessionCookies cfg (requestHeaders req) of
Nothing -> app req respond
Just (key,val) -> do
mVal <- newVal cfg key val
case mVal of
Nothing -> app req respond
Just val' ->
let f = mapResponseHeaders (++ renderSessionCookies cfg key val')
req' = req {vault = V.insert (vaultVar cfg) key (vault req)}
in app req' (respond . f)
parseSessionCookies :: SessionConfig m k v -> RequestHeaders -> Maybe (k, v)
parseSessionCookies cfg xs = do
cookies <- parseCookies <$> lookup "Cookie" xs
key <- parseKey cfg =<< lookup (keyName cfg) cookies
val <- parseVal cfg =<< lookup (valName cfg) cookies
return (key, val)
renderSessionCookies :: SessionConfig m k v -> k -> v -> ResponseHeaders
renderSessionCookies cfg key val = repeat "Set-Cookie" `zip` cookies
where
cookies = (toByteString . renderSetCookie) <$>
[ def { setCookieName = keyName cfg
, setCookieValue = renderKey cfg key
, setCookieMaxAge = Just $ secondsToDiffTime (expire cfg)
}
, def { setCookieName = valName cfg
, setCookieValue = renderVal cfg val
, setCookieMaxAge = Just $ secondsToDiffTime (expire cfg)
}
]