diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/snaplet-typed-sessions.cabal b/snaplet-typed-sessions.cabal new file mode 100644 --- /dev/null +++ b/snaplet-typed-sessions.cabal @@ -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 +Maintainer: Chris Smith +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 diff --git a/src/Snap/Dialogues.hs b/src/Snap/Dialogues.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Dialogues.hs @@ -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 diff --git a/src/Snap/Snaplet/TypedSession.hs b/src/Snap/Snaplet/TypedSession.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/TypedSession.hs @@ -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 diff --git a/src/Snap/Snaplet/TypedSession/Client.hs b/src/Snap/Snaplet/TypedSession/Client.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/TypedSession/Client.hs @@ -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 diff --git a/src/Snap/Snaplet/TypedSession/Memory.hs b/src/Snap/Snaplet/TypedSession/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/TypedSession/Memory.hs @@ -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 diff --git a/src/Snap/Snaplet/TypedSession/SessionMap.hs b/src/Snap/Snaplet/TypedSession/SessionMap.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/TypedSession/SessionMap.hs @@ -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), ())