mysnapsession 0.1.2 → 0.2
raw patch · 8 files changed
+396/−250 lines, 8 filesdep +cerealdep +clientsession
Dependencies added: cereal, clientsession
Files
- mysnapsession.cabal +7/−4
- src/Snap/Dialogues.hs +135/−0
- src/Snap/Extension/Dialogues.hs +0/−135
- src/Snap/Extension/Session.hs +3/−2
- src/Snap/Extension/Session/Client.hs +115/−0
- src/Snap/Extension/Session/Memory.hs +25/−20
- src/Snap/Extension/SessionUtil.hs +0/−89
- src/Snap/SessionUtil.hs +111/−0
mysnapsession.cabal view
@@ -1,5 +1,5 @@ Name: mysnapsession-Version: 0.1.2+Version: 0.2 Synopsis: Memory-backed sessions and continuations for Snap web apps Description: This package provides two Snap extensions. The first is an in-memory session manager, which stores sessions for@@ -31,10 +31,13 @@ time >= 1.1 && < 1.3, random == 1.0.*, containers >= 0.3 && < 0.5,- regex-posix == 0.94.*+ regex-posix == 0.94.*,+ clientsession == 0.4.*,+ cereal == 0.3.* Exposed-modules: Snap.Extension.Session, Snap.Extension.Session.Memory,- Snap.Extension.SessionUtil,- Snap.Extension.Dialogues+ Snap.Extension.Session.Client,+ Snap.SessionUtil,+ Snap.Dialogues Ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
+ src/Snap/Dialogues.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Dialogues (+ DlgManager,+ makeDlgManager,+ HasDlgManager(..),+ Dlg,+ Page,+ showPage,+ dialogue+ )+ where++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.Trans+import Snap.Extension.Session+import Snap.SessionUtil+import Snap.Types+import Text.Regex.Posix++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B++import Data.Map (Map)+import qualified Data.Map as M++newtype DlgManager m = DlgManager {+ unDlgManager :: MVar (Map SessionKey (Dlg m ()))+ }++makeDlgManager :: IO (DlgManager m)+makeDlgManager = fmap DlgManager (newMVar M.empty)++class HasDlgManager m a | a -> m where+ getDlgManager :: a -> DlgManager m++{-|+ A value of a 'Dlg' type represents a dialogue between the user and the+ application, after which the application builds a value of type 'a'. The+ trivial case is that the value is already known. Alternatively, it may be+ that there is some action to be performed, or else that the user needs to+ be asked or told something.+-}+data Dlg m a = Done a+ | Action (m (Dlg m a))+ | Step (Page m) (Dlg m a)++{-|+ A value of 'Page' type represents a way of rendering a page, given a request URI+ that should be used for subsequent requests in order to reassociate them with the+ current dialogue.+-}+type Page m = ByteString -> m ()++{-+ Dlg is a monad in the obvious way: return represents a dialogue that has no+ steps; and (>>=) combines dialogues by doing the first part of the first+ dialogue, and then continuing with the rest.+-}+instance Monad m => Monad (Dlg m) where+ return = Done+ Done x >>= y = y x+ Action x >>= y = Action (x >>= return . (>>= y))+ Step p f >>= y = Step p (f >>= y)++{-+ Converts an action in the underlying Monad into a Dlg. This is essentially+ a mechanism for escaping the confines of the dialogue mechanism and+ performing your own processing with the request.+-}+instance MonadTrans Dlg where+ lift x = Action (x >>= return . Done)++{-+ Dlg is an instance of MonadIO by passing it through to the underlying monad. +-}+instance MonadIO m => MonadIO (Dlg m) where+ liftIO = lift . liftIO++{-|+ Converts methods for rendering and parsing the result of a page into a+ 'Dlg' step.+-}+showPage :: Monad m => Page m -> m a -> Dlg m a+showPage p r = Step p (Action (r >>= return . Done))++dlgToken :: MonadSnap m => ByteString -> (SessionKey -> m a) -> m a +dlgToken tname action = popPathTo $ \token ->+ case token =~ ("^([^\\-]*)-([0-9]+)$" :: ByteString) of+ [[_, name, tok]] | name == tname -> action $ read $ B.unpack tok+ _ -> pass++findDlg :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)+ => SessionKey+ -> m (Dlg m ())+findDlg tok = do+ dref <- fmap (unDlgManager . getDlgManager) getSession+ dlgs <- liftIO $ readMVar dref+ maybe mzero return $ M.lookup tok dlgs++handle :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)+ => ByteString -> Dlg m () -> m ()+handle _ (Done _) = pass+handle name (Action a) = a >>= handle name+handle name (Step p f) = do+ dref <- fmap (unDlgManager . getDlgManager) getSession+ dlgs <- liftIO $ takeMVar dref+ k <- liftIO $ uniqueKey dlgs+ liftIO $ putMVar dref (M.insert k f dlgs)+ p (name `B.append` "-" `B.append` B.pack (show k))++{-|+ The 'dialogue' function builds a 'Snap ()' that handles a given dialogue.+ The URLs of the dialog are of the form "/.../dlg-55555", where "dlg" is+ the prefix (passed as a parameter) and 55555 is the (numeric) dialogue ID.+ Requests to "/.../dlg" create a new dialogue.++ In general, this can be combined in normal ways with other routing constructs,+ so long as request URIs of the above forms reach this handler. When pages are+ served as part of a dialog, their relative paths are passed on to later handlers,+-}+dialogue :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)+ => ByteString+ -> Dlg m ()+ -> m ()+dialogue name dlg = new <|> continue+ where+ new = dir name $ ifTop $ handle name dlg+ continue = dlgToken name $ \key -> ifTop $ findDlg key >>= handle name+
− src/Snap/Extension/Dialogues.hs
@@ -1,135 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}--module Snap.Extension.Dialogues (- DlgManager,- makeDlgManager,- HasDlgManager(..),- Dlg,- Page,- showPage,- dialogue- )- where--import Control.Applicative-import Control.Concurrent-import Control.Monad-import Control.Monad.Trans-import Snap.Extension.Session-import Snap.Extension.SessionUtil-import Snap.Types-import Text.Regex.Posix--import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B--import Data.Map (Map)-import qualified Data.Map as M--newtype DlgManager m = DlgManager {- unDlgManager :: MVar (Map SessionKey (Dlg m ()))- }--makeDlgManager :: IO (DlgManager m)-makeDlgManager = fmap DlgManager (newMVar M.empty)--class HasDlgManager m a | a -> m where- getDlgManager :: a -> DlgManager m--{-|- A value of a 'Dlg' type represents a dialogue between the user and the- application, after which the application builds a value of type 'a'. The- trivial case is that the value is already known. Alternatively, it may be- that there is some action to be performed, or else that the user needs to- be asked or told something.--}-data Dlg m a = Done a- | Action (m (Dlg m a))- | Step (Page m) (Dlg m a)--{-|- A value of 'Page' type represents a way of rendering a page, given a request URI- that should be used for subsequent requests in order to reassociate them with the- current dialogue.--}-type Page m = ByteString -> m ()--{-- Dlg is a monad in the obvious way: return represents a dialogue that has no- steps; and (>>=) combines dialogues by doing the first part of the first- dialogue, and then continuing with the rest.--}-instance Monad m => Monad (Dlg m) where- return = Done- Done x >>= y = y x- Action x >>= y = Action (x >>= return . (>>= y))- Step p f >>= y = Step p (f >>= y)--{-- Converts an action in the underlying Monad into a Dlg. This is essentially- a mechanism for escaping the confines of the dialogue mechanism and- performing your own processing with the request.--}-instance MonadTrans Dlg where- lift x = Action (x >>= return . Done)--{-- Dlg is an instance of MonadIO by passing it through to the underlying monad. --}-instance MonadIO m => MonadIO (Dlg m) where- liftIO = lift . liftIO--{-|- Converts methods for rendering and parsing the result of a page into a- 'Dlg' step.--}-showPage :: Monad m => Page m -> m a -> Dlg m a-showPage p r = Step p (Action (r >>= return . Done))--dlgToken :: MonadSnap m => ByteString -> (SessionKey -> m a) -> m a -dlgToken tname action = popPathTo $ \token ->- case token =~ ("^([^\\-]*)-([0-9]+)$" :: ByteString) of- [[_, name, tok]] | name == tname -> action $ read $ B.unpack tok- _ -> pass--findDlg :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)- => SessionKey- -> m (Dlg m ())-findDlg tok = do- dref <- fmap (unDlgManager . getDlgManager) getSessionObject- dlgs <- liftIO $ readMVar dref- maybe mzero return $ M.lookup tok dlgs--handle :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)- => ByteString -> Dlg m () -> m ()-handle _ (Done _) = pass-handle name (Action a) = a >>= handle name-handle name (Step p f) = do- dref <- fmap (unDlgManager . getDlgManager) getSessionObject- dlgs <- liftIO $ takeMVar dref- k <- liftIO $ uniqueKey dlgs- liftIO $ putMVar dref (M.insert k f dlgs)- p (name `B.append` "-" `B.append` B.pack (show k))--{-|- The 'dialogue' function builds a 'Snap ()' that handles a given dialogue.- The URLs of the dialog are of the form "/.../dlg-55555", where "dlg" is- the prefix (passed as a parameter) and 55555 is the (numeric) dialogue ID.- Requests to "/.../dlg" create a new dialogue.-- In general, this can be combined in normal ways with other routing constructs,- so long as request URIs of the above forms reach this handler. When pages are- served as part of a dialog, their relative paths are passed on to later handlers,--}-dialogue :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)- => ByteString- -> Dlg m ()- -> m ()-dialogue name dlg = new <|> continue- where- new = dir name $ ifTop $ handle name dlg- continue = dlgToken name $ \key -> ifTop $ findDlg key >>= handle name-
src/Snap/Extension/Session.hs view
@@ -12,6 +12,7 @@ class MonadSnap m => MonadSession m where type SessionValue m- getSessionObject :: m (SessionValue m)- putSessionObject :: SessionValue m -> m ()+ getSession :: m (SessionValue m)+ putSession :: SessionValue m -> m ()+ touchSession :: m ()
+ src/Snap/Extension/Session/Client.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Snap.Extension.Session.Client (+ HasClientSessionManager(..),+ ClientSessionManager,+ clientSessionInitializer+ ) where++import Control.Applicative+import Control.Monad.Reader+import Data.ByteString.Char8 (ByteString)+import Data.Maybe+import Data.Serialize+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Snap.Extension+import Snap.Extension.Session+import Snap.SessionUtil+import Snap.Types+import Web.ClientSession++class HasClientSessionManager a where+ type ClientSessionValue a+ clientSessionMgr :: a -> ClientSessionManager (ClientSessionValue a)++data ClientSessionManager t = ClientSessionManager {+ clientSessionKey :: Key,+ clientSessionDefault :: t,+ clientSessionTimeout :: Maybe NominalDiffTime+ }++clientSessionInitializer :: Key+ -> t+ -> Maybe NominalDiffTime+ -> Initializer (ClientSessionManager t)+clientSessionInitializer key defaultVal timeout =+ mkInitializer (ClientSessionManager key defaultVal timeout)++instance InitializerState (ClientSessionManager t) where+ extensionId = const "Session/Client"+ mkCleanup = const $ return ()+ mkReload = const $ return ()++{-+ The actual value encrypted and stored in the session contains not only the+ desired value, but also the client and the current time. This protects the+ session from cross-site session stealing attacks, and prevents stale session+ attacks.+-}+type SessionRecord t = (ByteString, UTCTime, t)++instance Serialize UTCTime where+ put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)+ get = posixSecondsToUTCTime . fromInteger <$> get++valToRecord :: (MonadSnap m, Serialize t) => t -> m (SessionRecord t)+valToRecord val = do+ rq <- getRequest+ t <- liftIO getCurrentTime+ return (rqRemoteAddr rq, t, val)++recordToVal :: (MonadSnap m, Serialize t)+ => ClientSessionManager t -> SessionRecord t -> m t+recordToVal mgr (client, time, val) = do+ addr <- fmap rqRemoteAddr getRequest+ if addr /= client+ then return (clientSessionDefault mgr)+ else do+ t <- liftIO getCurrentTime+ case clientSessionTimeout mgr of+ Nothing -> return val+ Just lim-> if t `diffUTCTime` time > lim+ then return (clientSessionDefault mgr)+ else return val++getSessionRecord :: (MonadSnap m, Serialize t)+ => ClientSessionManager t -> m (SessionRecord t)+getSessionRecord mgr = do+ cookie <- getCookie "sessionval"+ case cookie of+ Nothing -> valToRecord (clientSessionDefault mgr)+ Just c -> case decrypt (clientSessionKey mgr) (cookieValue c) of+ Nothing -> valToRecord (clientSessionDefault mgr)+ Just unenc -> case decode unenc of+ Left _ -> valToRecord (clientSessionDefault mgr)+ Right rec -> return rec++putSessionRecord :: (MonadSnap m, Serialize t)+ => ClientSessionManager t -> SessionRecord t -> m ()+putSessionRecord mgr record = do+ let str = encrypt (clientSessionKey mgr) (encode record)+ setCookie $ Cookie "sessionval" str Nothing Nothing Nothing++instance (HasClientSessionManager s, Serialize (ClientSessionValue s))+ => MonadSession (SnapExtend s) where+ type SessionValue (SnapExtend s) = ClientSessionValue s++ getSession = do+ mgr <- asks clientSessionMgr+ v <- recordToVal mgr =<< getSessionRecord mgr+ return v++ putSession v = do+ mgr <- asks clientSessionMgr+ putSessionRecord mgr =<< valToRecord v++ touchSession = do+ mgr <- asks clientSessionMgr+ v <- recordToVal mgr =<< getSessionRecord mgr+ when (isJust (clientSessionTimeout mgr)) $ do+ putSessionRecord mgr =<< valToRecord v+
src/Snap/Extension/Session/Memory.hs view
@@ -20,7 +20,7 @@ import Data.Time.Clock import Snap.Extension import Snap.Extension.Session-import Snap.Extension.SessionUtil+import Snap.SessionUtil import Snap.Types import Data.Map (Map)@@ -53,14 +53,14 @@ -} data MemorySessionManager obj = MemorySessionManager { sessionMgrClosed :: MVar Bool,- sessionMgrMap :: MVar (Map SessionKey (Session obj)),+ sessionMgrMap :: MVar (Map SessionKey (SessionWrapper obj)), sessionMgrDefault :: IO obj } {- A session contains the user session object and the dialogue map. -}-data Session obj = Session {+data SessionWrapper obj = SessionWrapper { sessionClient :: ByteString, sessionLastTouched :: MVar UTCTime, sessionObject :: MVar obj@@ -69,7 +69,7 @@ {-| Determines whether a session is still valid or not. -}-goodSession :: NominalDiffTime -> (SessionKey, Session obj) -> IO Bool+goodSession :: NominalDiffTime -> (SessionKey, SessionWrapper obj) -> IO Bool goodSession timeout (_, session) = do st <- readMVar (sessionLastTouched session) ct <- getCurrentTime @@ -113,19 +113,17 @@ Adds a 'Session' and associated cookie. This always sets a new blank session, so should only be used when there is no session already. -}-addSession :: MonadSnap m => MemorySessionManager obj -> m (Session obj)+addSession :: MonadSnap m => MemorySessionManager obj -> m (SessionWrapper obj) addSession (MemorySessionManager _ sref def) = do client <- fmap rqRemoteAddr getRequest (k, session) <- liftIO $ do smap <- takeMVar sref k <- uniqueKey smap ct <- getCurrentTime- session <- Session client <$> newMVar ct <*> (newMVar =<< def)+ session <- SessionWrapper client <$> newMVar ct <*> (newMVar =<< def) putMVar sref (M.insert k session smap) return (k, session)- let cookie = Cookie "sessionid" (B.pack $ show k) Nothing Nothing Nothing- modifyRequest $ \r -> r { rqCookies = cookie : rqCookies r }- modifyResponse $ addCookie cookie+ setCookie $ Cookie "sessionid" (B.pack $ show k) Nothing Nothing Nothing return session {-@@ -134,7 +132,7 @@ -} getExistingSession :: MonadSnap m => MemorySessionManager obj- -> m (Maybe (Session obj))+ -> m (Maybe (SessionWrapper obj)) getExistingSession (MemorySessionManager oref sref _) = do liftIO (readMVar oref) >>= flip unless mzero cookies <- fmap rqCookies getRequest@@ -148,28 +146,35 @@ Just s -> do if client /= sessionClient s then return Nothing- else liftIO $ do- _ <- swapMVar (sessionLastTouched s) =<< getCurrentTime- return (Just s)+ else return (Just s) {-| Ensures that there is a 'Session' in place, and returns it. Adds a blank one if necessary. This also updates the last touched time for the session, preventing it from being removed by the reaper thread for a while. -}-getSession :: MonadSnap m => MemorySessionManager obj -> m (Session obj)-getSession mgr = maybe (addSession mgr) return =<< getExistingSession mgr+getAnySession :: MonadSnap m+ => MemorySessionManager obj+ -> m (SessionWrapper obj)+getAnySession mgr = maybe (addSession mgr) return =<< getExistingSession mgr instance HasMemorySessionManager s => MonadSession (SnapExtend s) where type SessionValue (SnapExtend s) = MemorySessionValue s- getSessionObject = do+ getSession = do mgr <- asks memorySessionMgr- ses <- getSession mgr+ ses <- getAnySession mgr liftIO $ readMVar $ sessionObject ses - putSessionObject val = do+ putSession val = do mgr <- asks memorySessionMgr- ses <- getSession mgr- _ <- liftIO $ swapMVar (sessionObject ses) val+ ses <- getAnySession mgr+ _ <- liftIO $ swapMVar (sessionLastTouched ses) =<< getCurrentTime+ _ <- liftIO $ swapMVar (sessionObject ses) val+ return ()++ touchSession = do+ mgr <- asks memorySessionMgr+ ses <- getAnySession mgr+ liftIO $ swapMVar (sessionLastTouched ses) =<< getCurrentTime return ()
− src/Snap/Extension/SessionUtil.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}--module Snap.Extension.SessionUtil where--import Data.Word-import Snap.Iteratee hiding (map)-import Snap.Types hiding (redirect)-import System.Random--import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B--import Data.Map (Map)-import qualified Data.Map as M--{-|- If there is another path component in the request path, pop it off, and- pass it as a parameter to the handler.--}-popPathTo :: MonadSnap m => (ByteString -> m a) -> m a-popPathTo handler = do- req <- getRequest- let (x,y) = B.break (== '/') (rqPathInfo req)- if B.null x- then pass- else localRequest (\r -> r {rqPathInfo = B.drop 1 y}) (handler x)--{-- Temporarily here, in the hopes that the type of the original will be fixed- in a future version of Snap.--}-redirect :: MonadSnap m => ByteString -> m a-redirect target = do- r <- getResponse- finishWith- $ setResponseCode 302- $ setContentLength 0- $ modifyResponseBody (const $ enumBS "")- $ setHeader "Location" target r--{-|- Ensure that we're at the top level of a request, and expect that it be a- directory. As with standard HTTP behavior, if a path to a directory is- given and the request URI doesn't end in a slash, then the user is- redirected to a path ending in a slash.--}-ifTopDir :: MonadSnap m => m a -> m a-ifTopDir handler = ifTop $ do- req <- getRequest- if (B.last (rqURI req) /= '/')- then redirect $ rqURI req `B.append` "/" `B.append` rqQueryString req- else handler--{-|- Ensure that we're at the top level of a request, and expect that it be a- file. If a trailing slash is given, we pass on the request.--}-ifTopFile :: MonadSnap m => m a -> m a-ifTopFile handler = ifTop $ do- req <- getRequest- if (B.last (rqURI req) == '/') then pass else handler--{-|- Session keys are 64-bit integers with standard numeric type classes.--}-newtype SessionKey = K Word64- deriving (Eq, Ord, Enum, Bounded, Num, Real, Integral)--instance Random SessionKey where- randomR (l, h) g = let (r, g') = randomR (toInteger l, toInteger h) g- in (fromInteger r, g')- random = randomR (minBound, maxBound)--instance Show SessionKey where- show (K n) = show n--instance Read SessionKey where- readsPrec n s = map (\(a,t) -> (K a, t)) (readsPrec n s)--{-|- Generates a random key that is not already used in the given map. Though- not technically speaking guaranteed to terminate, this should be fast in- practice.--}-uniqueKey :: (Random k, Ord k) => Map k a -> IO k-uniqueKey m = do k <- randomIO- if M.member k m then uniqueKey m else return k-
+ src/Snap/SessionUtil.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.SessionUtil where++import Data.Word+import Snap.Extension.Session+import Snap.Iteratee hiding (map)+import Snap.Types hiding (redirect)+import System.Random++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B++import Data.Map (Map)+import qualified Data.Map as M++{-|+ Sets a cookie in both the request and the response. This modifies the+ list of cookies in the request, so that later attempts to get cookies will+ find this one even within the same request.+-}+setCookie :: MonadSnap m => Cookie -> m ()+setCookie cookie = do+ modifyRequest req+ modifyResponse (updateHeaders (M.update cleanRsp "Set-Cookie"))+ modifyResponse (addCookie cookie)+ where+ req = \r -> r { rqCookies = cookie : cleanReq (rqCookies r) }+ cleanReq = filter ((/= cookieName cookie) . cookieName)+ cleanRsp = Just . filter (not . ((cookieName cookie `B.append` "=") `B.isPrefixOf`))++{-|+ If there is another path component in the request path, pop it off, and+ pass it as a parameter to the handler.+-}+popPathTo :: MonadSnap m => (ByteString -> m a) -> m a+popPathTo handler = do+ req <- getRequest+ let (x,y) = B.break (== '/') (rqPathInfo req)+ if B.null x+ then pass+ else localRequest (\r -> r {rqPathInfo = B.drop 1 y}) (handler x)++{-|+ Temporarily here, in the hopes that the type of the original will be fixed+ in a future version of Snap.+-}+redirect :: MonadSnap m => ByteString -> m a+redirect target = do+ r <- getResponse+ finishWith+ $ setResponseCode 302+ $ setContentLength 0+ $ modifyResponseBody (const $ enumBS "")+ $ setHeader "Location" target r++{-|+ Ensure that we're at the top level of a request, and expect that it be a+ directory. As with standard HTTP behavior, if a path to a directory is+ given and the request URI doesn't end in a slash, then the user is+ redirected to a path ending in a slash.+-}+ifTopDir :: MonadSnap m => m a -> m a+ifTopDir handler = ifTop $ do+ req <- getRequest+ if (B.last (rqURI req) /= '/')+ then redirect $ rqURI req `B.append` "/" `B.append` rqQueryString req+ else handler++{-|+ Ensure that we're at the top level of a request, and expect that it be a+ file. If a trailing slash is given, we pass on the request.+-}+ifTopFile :: MonadSnap m => m a -> m a+ifTopFile handler = ifTop $ do+ req <- getRequest+ if (B.last (rqURI req) == '/') then pass else handler++{-|+ Insert this into your routes to renew sessions on each request.+-}+inSession :: MonadSession m => m a -> m a+inSession handler = touchSession >> handler++{-|+ Session keys are 64-bit integers with standard numeric type classes.+-}+newtype SessionKey = K Word64+ deriving (Eq, Ord, Enum, Bounded, Num, Real, Integral)++instance Random SessionKey where+ randomR (l, h) g = let (r, g') = randomR (toInteger l, toInteger h) g+ in (fromInteger r, g')+ random = randomR (minBound, maxBound)++instance Show SessionKey where+ show (K n) = show n++instance Read SessionKey where+ readsPrec n s = map (\(a,t) -> (K a, t)) (readsPrec n s)++{-|+ Generates a random key that is not already used in the given map. Though+ not technically speaking guaranteed to terminate, this should be fast in+ practice.+-}+uniqueKey :: (Random k, Ord k) => Map k a -> IO k+uniqueKey m = do k <- randomIO+ if M.member k m then uniqueKey m else return k+