mysnapsession (empty) → 0.1
raw patch · 7 files changed
+494/−0 lines, 7 filesdep +MonadCatchIO-transformersdep +basedep +bytestringsetup-changed
Dependencies added: MonadCatchIO-transformers, base, bytestring, containers, heist, hexpat, mtl, random, regex-posix, snap, snap-core, snap-server, text, time
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- mysnapsession.cabal +45/−0
- src/Snap/Extension/Dialogues.hs +135/−0
- src/Snap/Extension/Session.hs +17/−0
- src/Snap/Extension/Session/Memory.hs +175/−0
- src/Snap/Extension/SessionUtil.hs +89/−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
+ mysnapsession.cabal view
@@ -0,0 +1,45 @@+Name: mysnapsession+Version: 0.1+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.+ .+ 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.+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,+ heist == 0.4.*,+ hexpat == 0.19.*,+ MonadCatchIO-transformers >= 0.2.1 && < 0.3,+ mtl == 2.*,+ snap == 0.3.*,+ snap-core == 0.3.*,+ snap-server == 0.3.*,+ text == 0.11.*,+ time >= 1.1 && < 1.3,+ random == 1.0.*,+ containers == 0.3.*,+ regex-posix == 0.94.*+ Exposed-modules: Snap.Extension.Session,+ Snap.Extension.Session.Memory,+ Snap.Extension.SessionUtil,+ Snap.Extension.Dialogues++ Ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
+ src/Snap/Extension/Dialogues.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Extension.Dialogues (+ DlgManager,+ makeDlgManager,+ HasDlgManager(..),+ Dlg,+ Page,+ showPage,+ dialogue+ )+ where++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.Trans+import Snap.Extension.Session+import Snap.Extension.SessionUtil+import Snap.Types+import Text.Regex.Posix++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B++import Data.Map (Map)+import qualified Data.Map as M++newtype DlgManager m = DlgManager {+ unDlgManager :: MVar (Map SessionKey (Dlg m ()))+ }++makeDlgManager :: IO (DlgManager m)+makeDlgManager = fmap DlgManager (newMVar M.empty)++class HasDlgManager m a | a -> m where+ getDlgManager :: a -> DlgManager m++{-|+ A value of a 'Dlg' type represents a dialogue between the user and the+ application, after which the application builds a value of type 'a'. The+ trivial case is that the value is already known. Alternatively, it may be+ that there is some action to be performed, or else that the user needs to+ be asked or told something.+-}+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 a request URI+ that should be used for subsequent requests in order to reassociate them with the+ current dialogue.+-}+type Page m = ByteString -> m ()++{-+ Dlg is a monad in the obvious way: return represents a dialogue that has no+ steps; and (>>=) combines dialogues by doing the first part of the first+ dialogue, and then continuing with the rest.+-}+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)++{-+ Converts an action in the underlying Monad into a Dlg. This is essentially+ a mechanism for escaping the confines of the dialogue mechanism and+ performing your own processing with the request.+-}+instance MonadTrans Dlg where+ lift x = Action (x >>= return . Done)++{-+ Dlg is an instance of MonadIO by passing it through to the underlying monad. +-}+instance MonadIO m => MonadIO (Dlg m) where+ liftIO = lift . liftIO++{-|+ Converts methods for rendering and parsing the result of a page into a+ 'Dlg' step.+-}+showPage :: Monad m => Page m -> m a -> Dlg m a+showPage p r = Step p (Action (r >>= return . Done))++dlgToken :: MonadSnap m => ByteString -> (SessionKey -> m a) -> m a +dlgToken tname action = popPathTo $ \token ->+ case token =~ ("^([^\\-]*)-([0-9]+)$" :: ByteString) of+ [[_, name, tok]] | name == tname -> action $ read $ B.unpack tok+ _ -> pass++findDlg :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)+ => SessionKey+ -> m (Dlg m ())+findDlg tok = do+ dref <- fmap (unDlgManager . getDlgManager) getSessionObject+ dlgs <- liftIO $ readMVar dref+ maybe mzero return $ M.lookup tok dlgs++handle :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)+ => ByteString -> Dlg m () -> m ()+handle _ (Done _) = pass+handle name (Action a) = a >>= handle name+handle name (Step p f) = do+ dref <- fmap (unDlgManager . getDlgManager) getSessionObject+ dlgs <- liftIO $ takeMVar dref+ k <- liftIO $ uniqueKey dlgs+ liftIO $ putMVar dref (M.insert k f dlgs)+ p (name `B.append` "-" `B.append` B.pack (show k))++{-|+ 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.++ 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,+-}+dialogue :: (MonadSession m, HasDlgManager m t, t ~ SessionValue m)+ => ByteString+ -> Dlg m ()+ -> m ()+dialogue name dlg = new <|> continue+ where+ new = dir name $ ifTop $ handle name dlg+ continue = dlgToken name $ \key -> ifTop $ findDlg key >>= handle name+
+ src/Snap/Extension/Session.hs view
@@ -0,0 +1,17 @@+{-# 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.+-}++module Snap.Extension.Session ( MonadSession(..) ) where++import Snap.Types++class MonadSnap m => MonadSession m where+ type SessionValue m+ getSessionObject :: m (SessionValue m)+ putSessionObject :: SessionValue m -> m ()+
+ src/Snap/Extension/Session/Memory.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}+{-# 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.+-}++module Snap.Extension.Session.Memory (+ HasMemorySessionManager(..),+ MemorySessionManager,+ memorySessionInitializer+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Monad.Reader+import Data.List+import Data.Time.Clock+import Snap.Extension+import Snap.Extension.Session+import Snap.Extension.SessionUtil+import Snap.Types++import Data.Map (Map)+import qualified Data.Map as M++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B++{-+ This type class lets one bundle the memory-based session manager into a+ single application state object.+-}+class HasMemorySessionManager a where+ type MemorySessionValue a+ memorySessionMgr :: a -> MemorySessionManager (MemorySessionValue a)++memorySessionInitializer :: NominalDiffTime+ -> IO t+ -> Initializer (MemorySessionManager t)+memorySessionInitializer time def =+ mkInitializer =<< liftIO (makeSessionManager time def)++instance InitializerState (MemorySessionManager t) where+ extensionId = const "Session/Memory"+ mkCleanup = closeSessionManager+ mkReload = const $ return ()++{-+ A SessionManager keeps track of local sessions.+-}+data MemorySessionManager obj = MemorySessionManager {+ sessionMgrClosed :: MVar Bool,+ sessionMgrMap :: MVar (Map SessionKey (Session obj)),+ sessionMgrDefault :: IO obj+ }++{-+ A session contains the user session object and the dialogue map.+-}+data Session obj = Session {+ sessionClient :: ByteString,+ sessionLastTouched :: MVar UTCTime,+ sessionObject :: MVar obj+ }++{-|+ Determines whether a session is still valid or not.+-}+goodSession :: NominalDiffTime -> (SessionKey, Session obj) -> IO Bool+goodSession timeout (_, session) = do+ st <- readMVar (sessionLastTouched session)+ ct <- getCurrentTime + return (diffUTCTime ct st <= timeout)++{-|+ Monadic while statement, for convenience.+-}+whileM :: Monad m => m Bool -> m a -> m ()+whileM cond action = do+ b <- cond+ if b then action >> whileM cond action else return ()++{-|+ Creates a new 'SessionManager' to manage a sessions in the web application.+ This also spawns the session reaper, which cleans up sessions that haven't+ been touched for a given time period.+-}+makeSessionManager :: NominalDiffTime -> IO obj -> IO (MemorySessionManager obj)+makeSessionManager timeout def = do+ oref <- newMVar True+ sref <- newMVar M.empty+ _ <- forkIO $ whileM (readMVar oref) $ do+ sess <- takeMVar sref+ good <- filterM (goodSession timeout) (M.assocs sess)+ putMVar sref (M.fromList good)+ threadDelay 5000+ return $ MemorySessionManager oref sref def++{-|+ Closes a SessionManager, which will cause it to cease accepting any+ incoming requests, and also to terminate the session reaper thread.+-}+closeSessionManager :: MemorySessionManager obj -> IO ()+closeSessionManager (MemorySessionManager oref sref _) = do+ _ <- swapMVar oref False+ _ <- swapMVar sref M.empty+ return ()++{-|+ Adds a 'Session' and associated cookie. This always sets a new+ blank session, so should only be used when there is no session already.+-}+addSession :: MonadSnap m => MemorySessionManager obj -> m (Session obj)+addSession (MemorySessionManager _ sref def) = do+ client <- fmap rqRemoteAddr getRequest+ (k, session) <- liftIO $ do+ smap <- takeMVar sref+ k <- uniqueKey smap+ ct <- getCurrentTime+ session <- Session client <$> newMVar ct <*> (newMVar =<< def)+ putMVar sref (M.insert k session smap)+ return (k, session)+ let cookie = Cookie "sessionid" (B.pack $ show k) Nothing Nothing Nothing+ modifyRequest $ \r -> r { rqCookies = cookie : rqCookies r }+ modifyResponse $ addCookie cookie+ return session++{-+ Retrieves an existing session, if one exists. If there is no session, the+ result is Nothing.+-}+getExistingSession :: MonadSnap m+ => MemorySessionManager obj+ -> m (Maybe (Session obj))+getExistingSession (MemorySessionManager oref sref _) = do+ liftIO (readMVar oref) >>= flip unless mzero+ cookies <- fmap rqCookies getRequest+ client <- fmap rqRemoteAddr getRequest+ case find ((== "sessionid") . cookieName) cookies of+ Nothing -> return Nothing+ Just sid -> do+ smap <- liftIO $ readMVar sref+ case M.lookup (read (B.unpack (cookieValue sid))) smap of+ Nothing -> return Nothing+ Just s -> do+ if client /= sessionClient s+ then return Nothing+ else liftIO $ do+ _ <- swapMVar (sessionLastTouched s) =<< getCurrentTime+ return (Just s)++{-|+ Ensures that there is a 'Session' in place, and returns it. Adds a blank+ one if necessary. This also updates the last touched time for the session,+ preventing it from being removed by the reaper thread for a while.+-}+getSession :: MonadSnap m => MemorySessionManager obj -> m (Session obj)+getSession mgr = maybe (addSession mgr) return =<< getExistingSession mgr++instance HasMemorySessionManager s => MonadSession (SnapExtend s) where+ type SessionValue (SnapExtend s) = MemorySessionValue s+ getSessionObject = do+ mgr <- asks memorySessionMgr+ ses <- getSession mgr+ liftIO $ readMVar $ sessionObject ses++ putSessionObject val = do+ mgr <- asks memorySessionMgr+ ses <- getSession mgr+ _ <- liftIO $ swapMVar (sessionObject ses) val+ return ()+
+ src/Snap/Extension/SessionUtil.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Extension.SessionUtil where++import Data.Word+import Snap.Iteratee hiding (map)+import Snap.Types hiding (redirect)+import System.Random++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B++import Data.Map (Map)+import qualified Data.Map as M++{-|+ If there is another path component in the request path, pop it off, 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)++{-+ Temporarily here, in the hopes that the type of the original will be fixed+ in a future version of Snap.+-}+redirect :: MonadSnap m => ByteString -> m a+redirect target = do+ r <- getResponse+ finishWith+ $ setResponseCode 302+ $ setContentLength 0+ $ modifyResponseBody (const $ enumBS "")+ $ setHeader "Location" target r++{-|+ Ensure that we're at the top level of a request, and expect that it be a+ directory. As with standard HTTP behavior, if a path to a directory is+ given and the request URI doesn't end in a slash, then the user is+ redirected to a path ending in a slash.+-}+ifTopDir :: MonadSnap m => m a -> m a+ifTopDir handler = ifTop $ do+ req <- getRequest+ if (B.last (rqURI req) /= '/')+ then redirect $ rqURI req `B.append` "/" `B.append` rqQueryString req+ else handler++{-|+ Ensure that we're at the top level of a request, and expect that it be a+ file. If a trailing slash is given, we pass on the request.+-}+ifTopFile :: MonadSnap m => m a -> m a+ifTopFile handler = ifTop $ do+ req <- getRequest+ if (B.last (rqURI req) == '/') then pass else handler++{-|+ Session keys are 64-bit integers with standard numeric type classes.+-}+newtype SessionKey = K Word64+ deriving (Eq, Ord, Enum, Bounded, Num, Real, Integral)++instance Random SessionKey where+ randomR (l, h) g = let (r, g') = randomR (toInteger l, toInteger h) g+ in (fromInteger r, g')+ random = randomR (minBound, maxBound)++instance Show SessionKey where+ show (K n) = show n++instance Read SessionKey where+ readsPrec n s = map (\(a,t) -> (K a, t)) (readsPrec n s)++{-|+ Generates a random key that is not already used in the given map. Though+ not technically speaking guaranteed to terminate, this should be fast in+ practice.+-}+uniqueKey :: (Random k, Ord k) => Map k a -> IO k+uniqueKey m = do k <- randomIO+ if M.member k m then uniqueKey m else return k+