mysnapsession 0.3 → 0.3.1
raw patch · 5 files changed
+41/−30 lines, 5 files
Files
- mysnapsession.cabal +1/−1
- src/Snap/Dialogues.hs +4/−4
- src/Snap/Extension/Session.hs +21/−10
- src/Snap/Extension/Session/Client.hs +12/−12
- src/Snap/Extension/Session/Memory.hs +3/−3
mysnapsession.cabal view
@@ -1,5 +1,5 @@ Name: mysnapsession-Version: 0.3+Version: 0.3.1 Synopsis: Sessions and continuations for Snap web apps Description: This package provides two Snap extensions, implementing sessions as either memory-backed arbitrary types, or as
src/Snap/Dialogues.hs view
@@ -95,7 +95,7 @@ [[_, name, tok]] | name == tname -> action $ read $ B.unpack tok _ -> pass -findDlg :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)+findDlg :: (MonadSession m, HasDlgManager m t, t ~ Session m) => SessionKey -> m (Dlg m ()) findDlg tok = do@@ -103,7 +103,7 @@ dlgs <- liftIO $ readMVar dref maybe mzero return $ M.lookup tok dlgs -handle :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)+handle :: (MonadSession m, HasDlgManager m t, t ~ Session m) => ByteString -> Dlg m () -> m () handle _ (Done _) = pass handle name (Action a) = a >>= handle name@@ -115,7 +115,7 @@ p (name `B.append` "-" `B.append` B.pack (show k)) {-|- The 'dialogue' function builds a 'Snap ()' that handles a given dialogue.+ 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.@@ -124,7 +124,7 @@ 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)+dialogue :: (MonadSession m, HasDlgManager m t, t ~ Session m) => ByteString -> Dlg m () -> m ()
src/Snap/Extension/Session.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE TypeFamilies #-} {-|- 'Snap.Extension.Session.Memory' exports the 'MonadSessionMemory' interface- which allows you to keep an in-memory session object for each client session- of a web application.+ 'Snap.Extension.Session' exports the 'MonadSession' type class, which allows+ you to keep a session object for each client session of a web application.+ Convenience functions are provided for those cases where the session type+ is a 'Data.Map.Map'. -} module Snap.Extension.Session (@@ -20,10 +21,20 @@ import Data.Map (Map) import qualified Data.Map as M +{-|+ This type class captures all Snap-related monads that contain a session.+-} class MonadSnap m => MonadSession m where- type SessionValue m- getSession :: m (SessionValue m)- setSession :: SessionValue m -> m ()+ {-|+ The type of the session object. In principle, this may be any type+ that you want. However, implementations or other extensions maybe put+ additional restrictions on the type (for example, the session+ implementation in 'Snap.Extension.Session.Client' requires that the+ session type be an instance of 'Data.Serialize.Serialize'.+ -}+ type Session m+ getSession :: m (Session m)+ setSession :: Session m -> m () clearSession :: m () touchSession :: m () @@ -33,18 +44,18 @@ inSession :: MonadSession m => m a -> m a inSession handler = touchSession >> handler -withSession :: MonadSession m => (SessionValue m -> m a) -> m a+withSession :: MonadSession m => (Session m -> m a) -> m a withSession handler = touchSession >> getSession >>= handler -getFromSession :: (Ord k, MonadSession m, SessionValue m ~ Map k a)+getFromSession :: (Ord k, MonadSession m, Session m ~ Map k a) => k -> m (Maybe a) getFromSession key = fmap (M.lookup key) getSession -deleteFromSession :: (Ord k, MonadSession m, SessionValue m ~ Map k a)+deleteFromSession :: (Ord k, MonadSession m, Session m ~ Map k a) => k -> m () deleteFromSession key = withSession $ setSession . M.delete key -setInSession :: (Ord k, MonadSession m, SessionValue m ~ Map k a)+setInSession :: (Ord k, MonadSession m, Session m ~ Map k a) => k -> a -> m () setInSession k v = withSession $ setSession . M.insert k v
src/Snap/Extension/Session/Client.hs view
@@ -23,20 +23,20 @@ import Web.ClientSession class HasClientSessionManager a where- type ClientSessionValue a- clientSessionMgr :: a -> ClientSessionManager (ClientSessionValue a)+ type ClientSession a+ clientSessionMgr :: a -> ClientSessionManager (ClientSession a) data ClientSessionManager t = ClientSessionManager { clientSessionKey :: Key,- clientSessionDefault :: t,+ clientSessionDefault :: IO t, clientSessionTimeout :: Maybe NominalDiffTime } clientSessionInitializer :: Key- -> t -> Maybe NominalDiffTime+ -> IO t -> Initializer (ClientSessionManager t)-clientSessionInitializer key defaultVal timeout =+clientSessionInitializer key timeout defaultVal = mkInitializer (ClientSessionManager key defaultVal timeout) instance InitializerState (ClientSessionManager t) where@@ -67,13 +67,13 @@ recordToVal mgr (client, time, val) = do addr <- fmap rqRemoteAddr getRequest if addr /= client- then return (clientSessionDefault mgr)+ then liftIO $ 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)+ then liftIO $ clientSessionDefault mgr else return val getSessionRecord :: (MonadSnap m, Serialize t)@@ -81,11 +81,11 @@ getSessionRecord mgr = do cookie <- getCookie "sessionval" case cookie of- Nothing -> valToRecord (clientSessionDefault mgr)+ Nothing -> valToRecord =<< liftIO (clientSessionDefault mgr) Just c -> case decrypt (clientSessionKey mgr) (cookieValue c) of- Nothing -> valToRecord (clientSessionDefault mgr)+ Nothing -> valToRecord =<< liftIO (clientSessionDefault mgr) Just unenc -> case decode unenc of- Left _ -> valToRecord (clientSessionDefault mgr)+ Left _ -> valToRecord =<< liftIO (clientSessionDefault mgr) Right rec -> return rec putSessionRecord :: (MonadSnap m, Serialize t)@@ -94,9 +94,9 @@ let str = encrypt (clientSessionKey mgr) (encode record) setCookie $ Cookie "sessionval" str Nothing Nothing Nothing -instance (HasClientSessionManager s, Serialize (ClientSessionValue s))+instance (HasClientSessionManager s, Serialize (ClientSession s)) => MonadSession (SnapExtend s) where- type SessionValue (SnapExtend s) = ClientSessionValue s+ type Session (SnapExtend s) = ClientSession s getSession = do mgr <- asks clientSessionMgr
src/Snap/Extension/Session/Memory.hs view
@@ -34,8 +34,8 @@ single application state object. -} class HasMemorySessionManager a where- type MemorySessionValue a- memorySessionMgr :: a -> MemorySessionManager (MemorySessionValue a)+ type MemorySession a+ memorySessionMgr :: a -> MemorySessionManager (MemorySession a) memorySessionInitializer :: NominalDiffTime -> IO t@@ -156,7 +156,7 @@ getAnySession mgr = maybe (addSession mgr) return =<< getExistingSession mgr instance HasMemorySessionManager s => MonadSession (SnapExtend s) where- type SessionValue (SnapExtend s) = MemorySessionValue s+ type Session (SnapExtend s) = MemorySession s getSession = do mgr <- asks memorySessionMgr ses <- getAnySession mgr