mysnapsession 0.2 → 0.3
raw patch · 5 files changed
+73/−30 lines, 5 files
Files
- mysnapsession.cabal +17/−11
- src/Snap/Extension/Session.hs +34/−2
- src/Snap/Extension/Session/Client.hs +3/−1
- src/Snap/Extension/Session/Memory.hs +6/−7
- src/Snap/SessionUtil.hs +13/−9
mysnapsession.cabal view
@@ -1,16 +1,21 @@ Name: mysnapsession-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- each client. The session object type is user-defined.- Because sessions are memory-backed, sticky session routing- is needed to use this extension with load balancing.+Version: 0.3+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+ client-side cookie-backed serializable types. The latter+ uses the @clientsession@ package to encrypt the cookie for+ security. In both extensions, sessions are protected from+ session stealing by checking the source IP address, and+ have a configurable timeout (optional for the cookie-+ backed back end). The session type is user-defined. .- The second extension provides a continuation-based- programming model called dialogues, which allow natural- specification of stateful interactions with the client- that span multiple requests.+ In addition, a library is provided for a continuation-+ based programming model called dialogues, which allows+ natural specification of stateful interactions with the+ client that span multiple requests. Because the session+ type is not serializable, this requires the memory-backed+ implementation. License: BSD3 License-file: LICENSE Author: Chris Smith <cdsmith@gmail.com>@@ -41,3 +46,4 @@ Snap.Dialogues Ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ -fno-warn-orphans
src/Snap/Extension/Session.hs view
@@ -6,13 +6,45 @@ of a web application. -} -module Snap.Extension.Session ( MonadSession(..) ) where+module Snap.Extension.Session (+ MonadSession(..),+ inSession,+ withSession,+ getFromSession,+ deleteFromSession,+ setInSession+ ) where import Snap.Types +import Data.Map (Map)+import qualified Data.Map as M+ class MonadSnap m => MonadSession m where type SessionValue m getSession :: m (SessionValue m)- putSession :: SessionValue m -> m ()+ setSession :: SessionValue m -> m ()+ clearSession :: m () touchSession :: m ()++{-|+ Insert this into your routes to renew sessions on each request.+-}+inSession :: MonadSession m => m a -> m a+inSession handler = touchSession >> handler++withSession :: MonadSession m => (SessionValue m -> m a) -> m a+withSession handler = touchSession >> getSession >>= handler++getFromSession :: (Ord k, MonadSession m, SessionValue 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)+ => k -> m ()+deleteFromSession key = withSession $ setSession . M.delete key++setInSession :: (Ord k, MonadSession m, SessionValue m ~ Map k a)+ => k -> a -> m ()+setInSession k v = withSession $ setSession . M.insert k v
src/Snap/Extension/Session/Client.hs view
@@ -103,7 +103,7 @@ v <- recordToVal mgr =<< getSessionRecord mgr return v - putSession v = do+ setSession v = do mgr <- asks clientSessionMgr putSessionRecord mgr =<< valToRecord v @@ -112,4 +112,6 @@ v <- recordToVal mgr =<< getSessionRecord mgr when (isJust (clientSessionTimeout mgr)) $ do putSessionRecord mgr =<< valToRecord v++ clearSession = clearCookie "sessionval"
src/Snap/Extension/Session/Memory.hs view
@@ -51,11 +51,8 @@ {- A SessionManager keeps track of local sessions. -}-data MemorySessionManager obj = MemorySessionManager {- sessionMgrClosed :: MVar Bool,- sessionMgrMap :: MVar (Map SessionKey (SessionWrapper obj)),- sessionMgrDefault :: IO obj- }+data MemorySessionManager obj = MemorySessionManager+ (MVar Bool) (MVar (Map SessionKey (SessionWrapper obj))) (IO obj) {- A session contains the user session object and the dialogue map.@@ -165,7 +162,7 @@ ses <- getAnySession mgr liftIO $ readMVar $ sessionObject ses - putSession val = do+ setSession val = do mgr <- asks memorySessionMgr ses <- getAnySession mgr _ <- liftIO $ swapMVar (sessionLastTouched ses) =<< getCurrentTime@@ -175,6 +172,8 @@ touchSession = do mgr <- asks memorySessionMgr ses <- getAnySession mgr- liftIO $ swapMVar (sessionLastTouched ses) =<< getCurrentTime+ _ <- liftIO $ swapMVar (sessionLastTouched ses) =<< getCurrentTime return ()++ clearSession = clearCookie "sessionid"
src/Snap/SessionUtil.hs view
@@ -4,8 +4,7 @@ module Snap.SessionUtil where import Data.Word-import Snap.Extension.Session-import Snap.Iteratee hiding (map)+import Snap.Iteratee (enumBS) import Snap.Types hiding (redirect) import System.Random @@ -26,11 +25,22 @@ modifyResponse (updateHeaders (M.update cleanRsp "Set-Cookie")) modifyResponse (addCookie cookie) where- req = \r -> r { rqCookies = cookie : cleanReq (rqCookies r) }+ req | B.null (cookieValue cookie)+ = \r -> r { rqCookies = cleanReq (rqCookies r) }+ | otherwise+ = \r -> r { rqCookies = cookie : cleanReq (rqCookies r) } cleanReq = filter ((/= cookieName cookie) . cookieName) cleanRsp = Just . filter (not . ((cookieName cookie `B.append` "=") `B.isPrefixOf`)) {-|+ Clears a cookie. This involves setting the cookie to the empty string,+ with an expiration time in the past.+-}+clearCookie :: MonadSnap m => ByteString -> m ()+clearCookie name = setCookie cookie+ where cookie = Cookie name "" Nothing Nothing Nothing++{-| If there is another path component in the request path, pop it off, and pass it as a parameter to the handler. -}@@ -76,12 +86,6 @@ 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.