diff --git a/mysnapsession.cabal b/mysnapsession.cabal --- a/mysnapsession.cabal +++ b/mysnapsession.cabal @@ -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 @@ -41,3 +46,4 @@ Snap.Dialogues Ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-orphans diff --git a/src/Snap/Extension/Session.hs b/src/Snap/Extension/Session.hs --- a/src/Snap/Extension/Session.hs +++ b/src/Snap/Extension/Session.hs @@ -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 diff --git a/src/Snap/Extension/Session/Client.hs b/src/Snap/Extension/Session/Client.hs --- a/src/Snap/Extension/Session/Client.hs +++ b/src/Snap/Extension/Session/Client.hs @@ -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" diff --git a/src/Snap/Extension/Session/Memory.hs b/src/Snap/Extension/Session/Memory.hs --- a/src/Snap/Extension/Session/Memory.hs +++ b/src/Snap/Extension/Session/Memory.hs @@ -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" diff --git a/src/Snap/SessionUtil.hs b/src/Snap/SessionUtil.hs --- a/src/Snap/SessionUtil.hs +++ b/src/Snap/SessionUtil.hs @@ -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.