snaplet-typed-sessions (empty) → 0.5
raw patch · 8 files changed
+817/−0 lines, 8 filesdep +PSQueuedep +basedep +bytestringsetup-changed
Dependencies added: PSQueue, base, bytestring, cereal, clientsession, containers, hashtables, mtl, random, regex-posix, snap, snap-core, time
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- snaplet-typed-sessions.cabal +56/−0
- src/Snap/Dialogues.hs +159/−0
- src/Snap/Snaplet/TypedSession.hs +85/−0
- src/Snap/Snaplet/TypedSession/Client.hs +103/−0
- src/Snap/Snaplet/TypedSession/Memory.hs +158/−0
- src/Snap/Snaplet/TypedSession/SessionMap.hs +223/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Chris Smith++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Chris Smith nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/runhaskell+> import Distribution.Simple+> main = defaultMain
+ snaplet-typed-sessions.cabal view
@@ -0,0 +1,56 @@+Name: snaplet-typed-sessions +Version: 0.5 +Synopsis: Typed session snaplets and continuation-based + programming for the Snap web framework +Description: This package provides two Snaplets implementing + typed sessions in the Snap web framework, as either + memory-backed arbitrary types, or as client-side + cookie-backed serializable types. Unlike the + standard session snaplet, sessions can be of an + arbitrary type appropriate to the application. + Client-side session data is encrypted for security, + and sessions have a configurable timeout (optional + for the client-side back end). + . + In addition, a library is provided for a + continuation-based programming model called + Snap Dialogues. Dialogues allow natural + specification of stateful interactions with the + client that span multiple requests. Because the + session type is not serializable, this requires the + memory-backed session implementation. +License: BSD3 +License-file: LICENSE +Author: Chris Smith <cdsmith@gmail.com> +Maintainer: Chris Smith <cdsmith@gmail.com> +Stability: Experimental +Category: Web +Build-type: Simple +Cabal-version: >=1.6 + +Library + Hs-source-dirs: src + Build-depends: + base == 4.*, + bytestring >= 0.9.1 && < 0.10, + cereal == 0.3.*, + clientsession >= 0.7 && < 0.8, + containers >= 0.3 && < 0.5, + hashtables >= 1.0 && < 1.1, + mtl >= 2.0 && < 2.2, + PSQueue >= 1.0 && < 1.2, + random == 1.0.*, + regex-posix >= 0.94 && < 0.96, + snap >= 0.6 && < 0.10, + snap-core >= 0.6 && < 0.10, + time >= 1.1 && < 1.5 + + Exposed-modules: Snap.Snaplet.TypedSession, + Snap.Snaplet.TypedSession.Memory, + Snap.Snaplet.TypedSession.Client, + Snap.Dialogues + + Other-modules: Snap.Snaplet.TypedSession.SessionMap + + Ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-orphans
+ src/Snap/Dialogues.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+ This module provides an easy to use continuation-backed programming+ model for interactive web applications, called Snap Dialogues. A+ dialogue is a procedural description of an interaction with the+ user, which generally spans across many requests. Dialogues are+ specified in a monadic embedded domain-specific language.+-}+module Snap.Dialogues (+ DlgManager,+ makeDlgManager,+ HasDlgManager(..),+ Dlg,+ Page,+ showPage,+ dialogue+ )+ where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import qualified Snap.Snaplet.TypedSession.SessionMap as SM+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.TypedSession+import Text.Regex.Posix++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+++{-|+ A utility function to pop the next path component off the request+ URI 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)+++{-|+ A 'DlgManager' is user to keep track of ongoing dialogues with a+ given user. One of them should be stored in the user's session.+ The manager is parameterized on the base and value types for the+ underlying request handling monad.+-}+newtype DlgManager b v = DlgManager {+ unDlgManager :: SM.SessionMap (Dlg (Handler b v) ())+ }+++{-|+ Creates a new 'DlgManager' with the given timeout in seconds for+ abandoned dialogues.+-}+makeDlgManager :: Int -> IO (DlgManager b v)+makeDlgManager timeout = DlgManager <$> SM.new timeout+++{-|+ This type class identifies the location of the 'DlgManager' in the+ session object. In order to use dialogues, your session type must+ be an instance of 'HasDlgManager'.+-}+class HasDlgManager b v a | a -> b v where+ {-|+ Extracts the 'DlgManager' from a session object.+ -}+ getDlgManager :: a -> DlgManager b v+++{-|+ A value of a 'Dlg' type represents a (possibly partial) dialogue+ between the user and the application, producing a result of type+ @a@. Dialogues can be composed using the monadic interface to+ describe complex interactions.+-}+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+ the request URI for continuing the dialogue in the future.+ Typically you will build pages using some kind of templating system+ such as Heist.+-}+type Page m = ByteString -> m ()+++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)+instance MonadTrans Dlg where lift x = Action (x >>= return . Done)+instance MonadIO m => MonadIO (Dlg m) where liftIO = lift . liftIO+++{-|+ Converts the combination of rendering and parsing a page into a+ step of a 'Dlg'.+-}+showPage :: Monad m => Page m -> m a -> Dlg m a+showPage p r = Step p (Action (liftM Done r))+++dlgToken :: ByteString -> (ByteString -> Handler b v a) -> Handler b v a+dlgToken tname action = popPathTo $ \token ->+ case token =~ ("^([^\\-]*)-([0-9]+)$" :: ByteString) of+ [[_, name, tok]] | name == tname -> action $ read $ B.unpack tok+ _ -> pass+++findDlg :: (HasTypedSession v t, HasDlgManager b v t)+ => ByteString -> Handler b v (Dlg (Handler b v) ())+findDlg tok = do+ dmap <- fmap (unDlgManager . getDlgManager) getSession+ maybe mzero return =<< liftIO (SM.lookup dmap tok)+++handle :: (HasTypedSession v t, HasDlgManager b v t)+ => ByteString -> Dlg (Handler b v) () -> Handler b v ()+handle _ (Done _) = pass+handle name (Action a) = a >>= handle name+handle name (Step p f) = do+ dmap <- fmap (unDlgManager . getDlgManager) getSession+ k <- liftIO (SM.insert dmap f)+ p (name `B.append` "-" `B.append` B.pack (show k))+++{-|+ The 'dialogue' function builds a 'Handler' 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, so images, stylesheets, etc.+ can be served using 'serveDirectory' just as you normally would.+-}+dialogue :: (HasTypedSession v t, HasDlgManager b v t)+ => ByteString -> Dlg (Handler b v) () -> Handler b v ()+dialogue name dlg = new <|> continue+ where+ new = dir name $ ifTop $ handle name dlg+ continue = dlgToken name $ \key -> ifTop $ findDlg key >>= handle name
+ src/Snap/Snaplet/TypedSession.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}++{-|+ This module provides the generic interface to the various typed+ session implementations, including both server-side and client-side+ typed sessions.+-}+module Snap.Snaplet.TypedSession (+ HasTypedSession(..),+ withSession,+ getFromSession,+ setInSession,+ deleteFromSession+ ) where++import Snap.Snaplet++import Data.Map (Map)+import qualified Data.Map as M++{-|+ The generic interface to typed session implementations. Both the+ client-side and server-side implementations of sessions implement+ the common interface specified here.+-}+class HasTypedSession v t | v -> t where+ {-|+ Retrieves the session for the current request, always creating+ it if necessary.+ -}+ getSession :: Handler b v t+++ {-|+ Stores a new value for the current session.+ -}+ setSession :: t -> Handler b v ()+++ {-|+ Completely clears the current session, removing all associated+ cookies and server-side storage if applicable.+ -}+ clearSession :: Handler b v ()+++ {-|+ Marks a session as recently used, resetting the session timeout+ counter.+ -}+ touchSession :: Handler b v ()+++{-|+ A convenience function for gaining access to the session. The+ session is touched and then passed to the nested 'Handler'.+-}+withSession :: HasTypedSession v t => (t -> Handler b v a) -> Handler b v a+withSession handler = touchSession >> getSession >>= handler+++{-|+ Gets a named value from a session that happens to be a 'Map'.+-}+getFromSession :: (Ord k, HasTypedSession v (Map k a))+ => k -> Handler b v (Maybe a)+getFromSession key = fmap (M.lookup key) getSession+++{-|+ Sets a named value in a session that happens to be a 'Map'.+-}+setInSession :: (Ord k, HasTypedSession v (Map k a))+ => k -> a -> Handler b v ()+setInSession k v = withSession $ setSession . M.insert k v+++{-|+ Deletes a named value from a session that happens to be a 'Map'.+-}+deleteFromSession :: (Ord k, HasTypedSession v (Map k a))+ => k -> Handler b v ()+deleteFromSession key = withSession $ setSession . M.delete key
+ src/Snap/Snaplet/TypedSession/Client.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+ This is the client-side cookie-backed implementation of typed+ sessions. Because all data is stored on the client, this session+ back-end is easier to use in load balanced settings, and session+ timeouts are optional. All session data is encrypted so that it+ cannot be read by the client itself. However, it has the+ disadvantage of only being able to store serializable data types.+-}+module Snap.Snaplet.TypedSession.Client (+ ClientSessionManager,+ initClientSessions,+ module Snap.Snaplet.TypedSession+ ) where++import Control.Monad.State+import Data.ByteString (ByteString)+import Data.Serialize (Serialize)+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.Session (getSecureCookie, setSecureCookie)+import Snap.Snaplet.TypedSession+import Web.ClientSession+++{-|+ The typed session manager that stores session data directly in+ encrypted client-side cookies.+-}+data ClientSessionManager t = ClientSessionManager {+ clientSessionCache :: Maybe t,+ clientSessionName :: ByteString,+ clientSessionKey :: Key,+ clientSessionDefault :: IO t,+ clientSessionTimeout :: Maybe Int+ }+++{-|+ Initializer for the cookie-backed typed session snaplet.+-}+initClientSessions :: Serialize t+ => FilePath -- ^ Location of an encryption key+ -> ByteString -- ^ Name for the session cookie+ -> Maybe Int -- ^ Optional session timeout in seconds+ -> IO t -- ^ Initializer for new sessions+ -> SnapletInit b (ClientSessionManager t)+initClientSessions fp name timeout defaulter =+ makeSnaplet "TypedSession.Client"+ "Typed sessions stored in client-side cookies"+ Nothing $ liftIO $ do+ key <- getKey fp+ return $! ClientSessionManager Nothing name key defaulter timeout+ -- TODO: Maybe wrap routes with touchSession?+++getSessionImpl :: Serialize t => Handler b (ClientSessionManager t) t+getSessionImpl = do+ mgr <- get+ case clientSessionCache mgr of+ Just val -> return val+ Nothing -> do+ mval <- getSecureCookie (clientSessionName mgr)+ (clientSessionKey mgr)+ (clientSessionTimeout mgr)+ case mval of+ Just v -> do+ put (mgr { clientSessionCache = Just v })+ return v+ Nothing -> do+ v <- liftIO (clientSessionDefault mgr)+ setSession v+ return v+++setSessionImpl :: Serialize t => t -> Handler b (ClientSessionManager t) ()+setSessionImpl val = do+ mgr <- get+ put (mgr { clientSessionCache = Just val })+ setSecureCookie (clientSessionName mgr)+ (clientSessionKey mgr)+ (clientSessionTimeout mgr)+ val+++touchSessionImpl :: Serialize t => Handler b (ClientSessionManager t) ()+touchSessionImpl = getSession >>= setSession+++clearSessionImpl :: Serialize t => Handler b (ClientSessionManager t) ()+clearSessionImpl = do+ mgr <- get+ put (mgr { clientSessionCache = Nothing })+ expireCookie (clientSessionName mgr) Nothing++instance Serialize t => HasTypedSession (ClientSessionManager t) t where+ getSession = getSessionImpl+ setSession = setSessionImpl+ touchSession = touchSessionImpl+ clearSession = clearSessionImpl
+ src/Snap/Snaplet/TypedSession/Memory.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+ This is the server-side memory-backed implementation of typed+ sessions. It has the advantage of being able to store arbitrary+ data structures including functions and other non-serializable data.+ As a result, though, it is limited to a single server-side process+ since it's not possible to migrate arbitrary data between nodes.+ Load balancing with this snaplet requires "sticky sessions" or a+ similar technique to ensure that a given client always reaches the+ same server-side node.+-}+module Snap.Snaplet.TypedSession.Memory (+ MemorySessionManager,+ initMemorySessions,+ module Snap.Snaplet.TypedSession+ ) where++import Control.Monad.State+import Data.ByteString (ByteString)+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.Session (getSecureCookie, setSecureCookie)+import Snap.Snaplet.TypedSession+import Web.ClientSession++import Snap.Snaplet.TypedSession.SessionMap (SessionMap)+import qualified Snap.Snaplet.TypedSession.SessionMap as SM++{-|+ A typed session manager that stores session data by session key in+ a server-side map.+-}+data MemorySessionManager t = MemorySessionManager {+ memorySessionCache :: !(Maybe (ByteString, t)),+ memorySessionName :: !ByteString,+ memorySessionKey :: !Key,+ memorySessionDefault :: !(IO t),+ memorySessionTimeout :: !Int,+ memorySessionData :: !(SessionMap t)+ }+++{-|+ Initializer for the memory-backed typed session snaplet.+-}+initMemorySessions :: FilePath -- ^ Location of an encryption key+ -> ByteString -- ^ Name for the session ID cookie+ -> Int -- ^ Session timeout in seconds+ -> IO t -- ^ Initializer for new sessions+ -> SnapletInit b (MemorySessionManager t)+initMemorySessions fp name timeout defaulter =+ makeSnaplet "TypedSession.Memory"+ "Typed sessions stored in server-side memory"+ Nothing $ liftIO $ do+ key <- getKey fp+ sm <- SM.new timeout+ return $! MemorySessionManager Nothing name key defaulter timeout sm+ -- TODO: Maybe wrap routes with touchSession?+++getSessionImpl :: Handler b (MemorySessionManager t) t+getSessionImpl = do+ mgr <- get+ case memorySessionCache mgr of+ Just (_, val) -> return val+ Nothing -> do+ msid <- getSecureCookie (memorySessionName mgr)+ (memorySessionKey mgr)+ (Just (memorySessionTimeout mgr))+ case msid of+ Nothing -> newSession+ Just sid -> do+ mval <- liftIO (SM.lookup (memorySessionData mgr) sid)+ case mval of+ Nothing -> newSession+ Just val -> do+ put (mgr { memorySessionCache = Just (sid,val) })+ return val+++newSession :: Handler b (MemorySessionManager t) t+newSession = do+ mgr <- get+ val <- liftIO (memorySessionDefault mgr)+ sid <- liftIO (SM.insert (memorySessionData mgr) val)+ put (mgr { memorySessionCache = Just (sid,val) })+ setSecureCookie (memorySessionName mgr)+ (memorySessionKey mgr)+ (Just (memorySessionTimeout mgr))+ sid+ return val+++setSessionImpl :: t -> Handler b (MemorySessionManager t) ()+setSessionImpl val = do+ mgr <- get+ msid <- getSessionId+ sid <- case msid of+ Nothing -> liftIO (SM.insert (memorySessionData mgr) val)+ Just sid -> do+ liftIO (SM.update (memorySessionData mgr) sid val)+ return sid+ put (mgr { memorySessionCache = Just (sid, val) })+ setSecureCookie (memorySessionName mgr)+ (memorySessionKey mgr)+ (Just (memorySessionTimeout mgr))+ sid+++getSessionId :: Handler b (MemorySessionManager t) (Maybe ByteString)+getSessionId = do+ mgr <- get+ case memorySessionCache mgr of+ Just (sid, _) -> return (Just sid)+ Nothing -> do+ msid <- getSecureCookie (memorySessionName mgr)+ (memorySessionKey mgr)+ (Just (memorySessionTimeout mgr))+ case msid of+ Nothing -> return Nothing+ Just sid -> return (Just sid)+++touchSessionImpl :: Handler b (MemorySessionManager t) ()+touchSessionImpl = do+ msid <- getSessionId+ case msid of+ Nothing -> return ()+ Just sid -> do+ mgr <- get+ liftIO (SM.touch (memorySessionData mgr) sid)+ setSecureCookie (memorySessionName mgr)+ (memorySessionKey mgr)+ (Just (memorySessionTimeout mgr))+ sid+++clearSessionImpl :: Handler b (MemorySessionManager t) ()+clearSessionImpl = do+ mgr <- get+ put (mgr { memorySessionCache = Nothing })++ msid <- getSessionId+ case msid of+ Nothing -> return ()+ Just sid -> do+ liftIO (SM.delete (memorySessionData mgr) sid)+ expireCookie (memorySessionName mgr) Nothing+++instance HasTypedSession (MemorySessionManager t) t where+ getSession = getSessionImpl+ setSession = setSessionImpl+ touchSession = touchSessionImpl+ clearSession = clearSessionImpl
+ src/Snap/Snaplet/TypedSession/SessionMap.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-|+ An implementation of a mutable map with randomly generated keys and+ values that time out and must be cleaned up when not in use. This+ pattern occurs in a number of situations related to session+ management, so it is useful to have the code in one place.+-}+module Snap.Snaplet.TypedSession.SessionMap (+ SessionMap,+ new,+ close,+ insert,+ update,+ delete,+ lookup,+ touch+ ) where++import Prelude hiding (lookup, catch)++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.ByteString (ByteString)+import Data.Time+import Data.Typeable+import Snap.Snaplet.Session (RNG, mkRNG, randomToken)++import qualified Data.HashTable.IO as HT+import qualified Data.PSQueue as PQ+++{-|+ A SessionMap is a mutable map with ByteString keys and values of a+ user-defined type. The values in the map are associated with+ timeouts, after which they will automatically be deleted.++ A SessionMap is in one of two states: active or closed. When first+ created, the map is active. Values can be inserted, queried, and+ removed, and will be automatically removed once time has expired.+ When the map is closed, it changes to the closed state. Attempts+ to use it will result in exceptions, and all data and resources+ associated with value timeout are freed. There is no way to reopen+ a closed SessionMap.+-}+data SessionMap v = SessionMap+ !(MVar (Maybe (PQ.PSQ ByteString UTCTime)))+ -- In addition to holding the priority queue, this also acts+ -- as the lock for the entire data structure. The hash table+ -- should not be modified except when holding this lock.+ !(HT.BasicHashTable ByteString v)+ !ThreadId+ !RNG+ !Int+++{-|+ This exception type is created specifically for the purpose of+ poking the watcher thread when new values are inserted into the+ map.+-}+data PokeWatcher = PokeWatcher deriving (Typeable, Show)+instance Exception PokeWatcher+++{-|+ Creates a new random map, which is initially empty but active.+-}+new :: Int -> IO (SessionMap v)+new to = do+ q <- newMVar (Just PQ.empty)+ ht <- HT.new+ w <- forkIO (doWatcher q ht)+ gen <- mkRNG+ return (SessionMap q ht w gen to)+++{-|+ The watcher thread. This thread loops, checking for expired+ elements and removing them from the map. When there are no expired+ elements, it sleeps until the next expiration time. It should be+ thrown a PokeWatcher exception when the expiration queue is changed+ in order to get it to notice earlier expiration times.+-}+doWatcher :: MVar (Maybe (PQ.PSQ ByteString UTCTime))+ -> HT.BasicHashTable ByteString v+ -> IO ()+doWatcher q ht = mask $ \_ -> do+ nxt <- modifyMVar q (cleanExpired ht)+ case nxt of+ Nothing -> return ()+ Just del -> do threadDelay del+ `catch` \PokeWatcher -> return ()+ doWatcher q ht+++{-+ The inner portion of the watcher thread, which removes expired+ elements and returns the amopunt of time to wait before cleaning+ again.+-}+cleanExpired :: HT.BasicHashTable ByteString v+ -> Maybe (PQ.PSQ ByteString UTCTime)+ -> IO (Maybe (PQ.PSQ ByteString UTCTime), Maybe Int)+cleanExpired _ Nothing = return (Nothing, Nothing)+cleanExpired ht (Just q) = case PQ.minView q of+ Nothing -> return (Just q, Just maxBound)+ Just (k PQ.:-> e, q') -> do+ t <- getCurrentTime+ if e <= t then do+ HT.delete ht k+ cleanExpired ht (Just q')+ else return (Just q, Just (round (1000000 * diffUTCTime e t)))+++{-|+ Performs some action with the MVar held for the priority queue.+ That MVar serves as a lock for the entire data structure, ensuring+ thread safety.+-}+withOpenMap :: MVar (Maybe (PQ.PSQ ByteString UTCTime))+ -> (PQ.PSQ ByteString UTCTime -> IO (Maybe (PQ.PSQ ByteString UTCTime), a))+ -> IO a+withOpenMap qq f = modifyMVar qq go+ where go Nothing = error "Session map is already closed"+ go (Just q) = f q+++{-|+ Closes a SessionMap, moving it to the closed state. Once in the+ closed state, and data contained in the map is lost and resources+ are freed, and any attempt to use the map will result in an error.+ A closed SessionMap cannot be reopened.+-}+close :: SessionMap v -> IO ()+close (SessionMap qq ht w _ _) = withOpenMap qq $ \_ -> do+ throwTo w PokeWatcher+ vals <- HT.toList ht+ forM_ vals $ \(k,_) -> HT.delete ht k+ return (Nothing, ())+++{-|+ Inserts a new value into the map, choosing and returning a new+ unused session key in the process.+-}+insert :: SessionMap v -> v -> IO ByteString+insert m@(SessionMap qq ht _ gen _) v = withOpenMap qq $ \q -> do+ k <- uniqueKey gen ht+ (q', _) <- update' m k v q+ return (q', k)+++{-|+ Chooses a new session key that is unused by the map. While this+ technically could loop arbitrarily long, in practice the space of+ keys is so large that it's extremely unlikely to run into a+ conflict at all.+-}+uniqueKey :: RNG -> HT.BasicHashTable ByteString v -> IO ByteString+uniqueKey gen ht = do+ k <- randomToken 40 gen+ maybe (return k) (const (uniqueKey gen ht)) =<< HT.lookup ht k+++{-|+ Replaces the value associated with a key in the session map. The+ expiration time for the key is reset at the same time.+-}+update :: SessionMap v -> ByteString -> v -> IO ()+update m@(SessionMap q _ _ _ _) k v =+ withOpenMap q (update' m k v)+++update' :: SessionMap v -> ByteString -> v+ -> PQ.PSQ ByteString UTCTime+ -> IO (Maybe (PQ.PSQ ByteString UTCTime), ())+update' m@(SessionMap _ ht _ _ _) k v q = do+ HT.insert ht k v+ touch' m k q+++{-|+ Removes a value from the map.+-}+delete :: SessionMap v -> ByteString -> IO ()+delete (SessionMap qq ht _ _ _) k = withOpenMap qq $ \q -> do+ HT.delete ht k+ return (Just (PQ.delete k q), ())+++{-|+ Looks up a session key in the map, and returns the associated value.+ This does NOT reset the expiration time. If that's what you want,+ see 'touch'.+-}+lookup :: SessionMap v -> ByteString -> IO (Maybe v)+lookup (SessionMap qq ht _ _ _) k = withOpenMap qq $ \q -> do+ v <- HT.lookup ht k+ return (Just q, v)+++{-|+ Resets the expiration time in a key in the map.+-}+touch :: SessionMap v -> ByteString -> IO ()+touch m@(SessionMap q _ _ _ _) k =+ withOpenMap q (touch' m k)+++touch' :: SessionMap v -> ByteString+ -> PQ.PSQ ByteString UTCTime+ -> IO (Maybe (PQ.PSQ ByteString UTCTime), ())+touch' (SessionMap _ ht w _ to) k q = do+ throwTo w PokeWatcher+ t <- getCurrentTime+ let p = addUTCTime (fromIntegral to) t+ ans <- HT.lookup ht k+ case ans of+ Nothing -> return (Just q, ())+ Just _ -> return (Just (PQ.insert k p q), ())