module Web.ServerSession.Frontend.Snap.Internal
( initServerSessionManager
, simpleServerSessionManager
, SnapSession(..)
, ServerSessionManager(..)
, currentSessionMap
, modifyCurrentSession
, createCookie
, csrfKey
, forceInvalidate
) where
import Control.Applicative as A
import Control.Arrow (first, second)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Web.PathPieces (toPathPiece)
import Web.ServerSession.Core
import qualified Crypto.Nonce as N
import qualified Data.ByteString.Char8 as B8
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Time as TI
import qualified Snap.Core as S
import qualified Snap.Snaplet as S
import qualified Snap.Snaplet.Session as S
import qualified Snap.Snaplet.Session.SessionManager as S
initServerSessionManager
:: (Storage sto, SnapSession (SessionData sto))
=> IO (State sto)
-> S.SnapletInit b S.SessionManager
initServerSessionManager mkState =
S.makeSnaplet "ServerSession"
"Snaplet providing sessions via server-side storage."
Nothing $ liftIO $ do
gen <- N.new
st <- mkState
let ssm = ServerSessionManager
{ currentSession = Nothing
, state = st
, cookieName = TE.encodeUtf8 $ getCookieName st
, nonceGen = gen
}
return $ S.SessionManager ssm
simpleServerSessionManager
:: (Storage sto, SessionData sto ~ SessionMap)
=> IO sto
-> (State sto -> State sto)
-> S.SnapletInit b S.SessionManager
simpleServerSessionManager mkStorage opts =
initServerSessionManager (fmap opts . createState =<< mkStorage)
class IsSessionData sess => SnapSession sess where
ssInsert :: Text -> Text -> sess -> sess
ssLookup :: Text -> sess -> Maybe Text
ssDelete :: Text -> sess -> sess
ssToList :: sess -> [(Text, Text)]
ssInsertCsrf :: Text -> sess -> sess
ssLookupCsrf :: sess -> Maybe Text
ssForceInvalidate :: ForceInvalidate -> sess -> sess
instance SnapSession SessionMap where
ssInsert key val = onSM (HM.insert key (TE.encodeUtf8 val))
ssLookup key = fmap TE.decodeUtf8 . HM.lookup key . unSessionMap
ssDelete key = onSM (HM.delete key)
ssToList =
fmap (second TE.decodeUtf8) .
HM.toList .
HM.delete csrfKey .
unSessionMap
ssInsertCsrf = ssInsert csrfKey
ssLookupCsrf = ssLookup csrfKey
ssForceInvalidate force = onSM (HM.insert forceInvalidateKey (B8.pack $ show force))
onSM
:: (HM.HashMap Text ByteString -> HM.HashMap Text ByteString)
-> (SessionMap -> SessionMap)
onSM f = SessionMap . f . unSessionMap
data ServerSessionManager sto =
ServerSessionManager
{ currentSession :: Maybe (SessionData sto, SaveSessionToken sto)
, state :: State sto
, cookieName :: ByteString
, nonceGen :: N.Generator
} deriving (Typeable)
instance ( Storage sto
, SnapSession (SessionData sto)
) => S.ISessionManager (ServerSessionManager sto) where
load ssm@ServerSessionManager { currentSession = Just _ } =
return ssm
load ssm = do
mcookie <- S.getCookie (cookieName ssm)
(data1, saveSessionToken) <-
liftIO $ loadSession (state ssm) (S.cookieValue A.<$> mcookie)
data2 <-
maybe
(flip ssInsertCsrf data1 <$> N.nonce128urlT (nonceGen ssm))
(const $ return data1)
(ssLookupCsrf data1)
return ssm { currentSession = Just (data2, saveSessionToken) }
commit ssm = do
let Just (data_, saveSessionToken) = currentSession ssm
msession <- liftIO $ saveSession (state ssm) saveSessionToken data_
S.modifyResponse $ S.addResponseCookie $
maybe
(deleteCookie (state ssm) (cookieName ssm))
(createCookie (state ssm) (cookieName ssm))
msession
reset ssm = do
csrfToken <- N.nonce128urlT (nonceGen ssm)
let newSession =
ssInsertCsrf csrfToken $
ssForceInvalidate CurrentSessionId $
emptySession
return $ modifyCurrentSession (const newSession) ssm
touch =
id
insert key value = modifyCurrentSession (ssInsert key value)
lookup key =
ssLookup key . currentSessionMap "lookup"
delete key = modifyCurrentSession (ssDelete key)
csrf =
fromMaybe (error "serversession-frontend-snap/csrf: never here") .
ssLookupCsrf . currentSessionMap "csrf"
toList = ssToList . currentSessionMap "toList"
currentSessionMap :: String -> ServerSessionManager sto -> SessionData sto
currentSessionMap fn ssm = maybe (error err) fst (currentSession ssm)
where err = "serversession-frontend-snap/" ++ fn ++
": currentSession is Nothing, did you call 'load'?"
modifyCurrentSession
:: (SessionData sto -> SessionData sto)
-> ServerSessionManager sto
-> ServerSessionManager sto
modifyCurrentSession f ssm = ssm { currentSession = fmap (first f) (currentSession ssm) }
createCookie :: State sto -> ByteString -> Session sess -> S.Cookie
createCookie st cookieNameBS session =
S.Cookie
{ S.cookieName = cookieNameBS
, S.cookieValue = TE.encodeUtf8 $ toPathPiece $ sessionKey session
, S.cookiePath = Just "/"
, S.cookieExpires = cookieExpires st session
, S.cookieDomain = Nothing
, S.cookieHttpOnly = getHttpOnlyCookies st
, S.cookieSecure = getSecureCookies st
}
deleteCookie :: State sto -> ByteString -> S.Cookie
deleteCookie st cookieNameBS =
S.Cookie
{ S.cookieName = cookieNameBS
, S.cookieValue = ""
, S.cookiePath = Just "/"
, S.cookieExpires = Just aLongTimeAgo
, S.cookieDomain = Nothing
, S.cookieHttpOnly = getHttpOnlyCookies st
, S.cookieSecure = getSecureCookies st
}
where aLongTimeAgo = read "1970-01-01 00:00:01 UTC" :: TI.UTCTime
csrfKey :: Text
csrfKey = "_CSRF"
forceInvalidate :: ForceInvalidate -> S.Handler b S.SessionManager ()
forceInvalidate = S.setInSession forceInvalidateKey . T.pack . show