Spock 0.4.3.4 → 0.4.3.5
raw patch · 13 files changed
+682/−646 lines, 13 files
Files
- Spock.cabal +3/−2
- Web/Spock.hs +0/−110
- Web/Spock/Cookie.hs +0/−54
- Web/Spock/Monad.hs +0/−78
- Web/Spock/SafeActions.hs +0/−61
- Web/Spock/SessionManager.hs +0/−195
- Web/Spock/Types.hs +0/−146
- src/Web/Spock.hs +110/−0
- src/Web/Spock/Cookie.hs +54/−0
- src/Web/Spock/Monad.hs +78/−0
- src/Web/Spock/SafeActions.hs +61/−0
- src/Web/Spock/SessionManager.hs +225/−0
- src/Web/Spock/Types.hs +151/−0
Spock.cabal view
@@ -1,5 +1,5 @@ name: Spock-version: 0.4.3.4+version: 0.4.3.5 synopsis: Another Haskell web toolkit based on scotty description: This toolbox provides everything you need to get a quick start into web hacking with haskell: sessions, cookies, database helper, csrf-protection, global state and the power of scotty Homepage: https://github.com/agrafix/Spock@@ -13,7 +13,8 @@ cabal-version: >=1.8 library- exposed-modules: Web.Spock+ hs-source-dirs: src+ exposed-modules: Web.Spock other-modules: Web.Spock.SessionManager, Web.Spock.Monad, Web.Spock.Cookie,
− Web/Spock.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Web.Spock- ( -- * Spock's core- spock, SpockM, SpockAction- -- * Database- , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)- -- * Accessing Database and State- , HasSpock (runQuery, getState)- -- * Sessions- , SessionCfg (..)- , readSession, writeSession, modifySession- -- * Cookies- , setCookie, setCookie', getCookie- -- * Safe actions- , SafeAction (..)- , safeActionPath- -- * General Routing- , get, post, put, delete, patch, addroute, Http.StdMethod (..)- -- * Other reexports from scotty- , middleware, matchAny, notFound- , request, reqHeader, body, param, params, jsonData, files- , status, addHeader, setHeader, redirect- , text, html, file, json, source, raw- , raise, rescue, next- , RoutePattern- -- * Spock utilities- , paramPathPiece- -- * Internals for extending Spock- , getSpockHeart, runSpockIO, WebStateM, WebState- )-where--import Web.Spock.SessionManager-import Web.Spock.Monad-import Web.Spock.Types-import Web.Spock.Cookie-import Web.Spock.SafeActions--import Control.Applicative-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Resource-import Data.Pool-import Web.Scotty.Trans-import Web.PathPieces-import qualified Network.HTTP.Types as Http-import qualified Data.Text.Lazy as TL---- | Run a spock application using the warp server, a given db storageLayer and an initial state.--- Spock works with database libraries that already implement connection pooling and--- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.-spock :: Int -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()-spock port sessionCfg poolOrConn initialState defs =- do sessionMgr <- createSessionManager sessionCfg- connectionPool <-- case poolOrConn of- PCConduitPool p ->- return (ConduitPool p)- PCPool p ->- return (DataPool p)- PCConn cb ->- let pc = cb_poolConfiguration cb- in DataPool <$> createPool (cb_createConn cb) (cb_destroyConn cb)- (pc_stripes pc) (pc_keepOpenTime pc)- (pc_resPerStripe pc)- let internalState =- WebState- { web_dbConn = connectionPool- , web_sessionMgr = sessionMgr- , web_state = initialState- }- runM m = runResourceT $ runReaderT (runWebStateM m) internalState- runActionToIO = runM-- scottyT port runM runActionToIO $- do middleware (sm_middleware sessionMgr)- hookSafeActions- defs---- | Write to the current session. Note that all data is stored on the server.--- The user only reciedes a sessionId to be identified.-writeSession :: sess -> SpockAction conn sess st ()-writeSession d =- do mgr <- getSessMgr- (sm_writeSession mgr) d---- | Modify the stored session-modifySession :: (sess -> sess) -> SpockAction conn sess st ()-modifySession f =- do mgr <- getSessMgr- (sm_modifySession mgr) f---- | Read the stored session-readSession :: SpockAction conn sess st sess-readSession =- do mgr <- getSessMgr- sm_readSession mgr---- | Same as "param", but the target type needs to implement "PathPiece"-paramPathPiece :: PathPiece s => TL.Text -> SpockAction conn sess st s-paramPathPiece t =- do val <- param t- case fromPathPiece val of- Just x ->- return x- Nothing ->- raise $ stringError $ "Cannot convert param: " ++ TL.unpack t ++ " to path piece!"
− Web/Spock/Cookie.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Web.Spock.Cookie where--import Web.Spock.Types--import Control.Arrow-import Control.Monad.Trans-import Data.Time-import System.Locale-import Web.Scotty.Trans-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Network.Wai as Wai---- | Read a cookie previously set in the users browser for your site-getCookie :: (SpockError e, MonadIO m) => T.Text -> ActionT e m (Maybe T.Text)-getCookie name =- do r <- request- return $ getCookieFromReq name r--getCookieFromReq :: T.Text -> Wai.Request -> Maybe T.Text-getCookieFromReq name req =- lookup "cookie" (Wai.requestHeaders req) >>=- lookup name . parseCookies . T.decodeUtf8- where- parseCookies :: T.Text -> [(T.Text, T.Text)]- parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words- parseCookie = first T.init . T.breakOnEnd "="---- | Set a cookie living for a given number of seconds-setCookie :: (SpockError e, MonadIO m) => T.Text -> T.Text -> NominalDiffTime- -> ActionT e m ()-setCookie name value validSeconds =- do now <- liftIO getCurrentTime- setCookie' name value (validSeconds `addUTCTime` now)---- | Set a cookie living until a specific 'UTCTime'-setCookie' :: (SpockError e, MonadIO m) => T.Text -> T.Text -> UTCTime- -> ActionT e m ()-setCookie' name value validUntil =- setHeader "Set-Cookie" (renderCookie name value validUntil)--renderCookie :: T.Text -> T.Text -> UTCTime -> TL.Text-renderCookie name value validUntil =- let formattedTime =- TL.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil- in TL.concat [ TL.fromStrict name- , "="- , TL.fromStrict value- , "; path=/; expires="- , formattedTime- , ";"- ]
− Web/Spock/Monad.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-module Web.Spock.Monad where--import Web.Spock.Types--import Control.Monad-import Control.Monad.Reader-import Control.Monad.Trans.Resource-import Data.Pool-import Data.Time.Clock ( UTCTime(..) )-import Web.Scotty.Trans-import qualified Data.Conduit.Pool as CP-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Text.XML.XSD.DateTime as XSD--webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a-webM = lift--instance MonadTrans t => HasSpock (t (WebStateM conn sess st)) where- type SpockConn (t (WebStateM conn sess st)) = conn- type SpockState (t (WebStateM conn sess st)) = st- type SpockSession (t (WebStateM conn sess st)) = sess- runQuery a = webM $ runQueryImpl a- getState = webM $ getStateImpl- getSessMgr = webM $ getSessMgrImpl--instance HasSpock (WebStateM conn sess st) where- type SpockConn (WebStateM conn sess st) = conn- type SpockState (WebStateM conn sess st) = st- type SpockSession (WebStateM conn sess st) = sess- runQuery = runQueryImpl- getState = getStateImpl- getSessMgr = getSessMgrImpl--runQueryImpl :: (conn -> IO a) -> WebStateM conn sess st a-runQueryImpl query =- do pool <- asks web_dbConn- let fun =- case pool of- DataPool p ->- withResource p- ConduitPool p ->- CP.withResource p- liftIO (fun query)--getStateImpl :: WebStateM conn sess st st-getStateImpl = asks web_state---- | Read the heart of Spock. This is useful if you want to construct your own--- monads that work with runQuery and getState using "runSpockIO"-getSpockHeart :: MonadTrans t => t (WebStateM conn sess st) (WebState conn sess st)-getSpockHeart = webM ask---- | Run an action inside of Spocks core monad. This allows you to use runQuery and getState-runSpockIO :: WebState conn sess st -> WebStateM conn sess st a -> IO a-runSpockIO st (WebStateM action) =- runResourceT $- runReaderT action st--getSessMgrImpl :: (WebStateM conn sess st) (SessionManager conn sess st)-getSessMgrImpl = asks web_sessionMgr--instance Parsable BSL.ByteString where- parseParam =- Right . BSL.fromStrict . T.encodeUtf8 . TL.toStrict--instance Parsable UTCTime where- parseParam p =- case join $ fmap XSD.toUTCTime $ XSD.dateTime (TL.toStrict p) of- Nothing ->- Left $ TL.pack $ "Can't parse param (`" ++ show p ++ "`) as UTCTime!"- Just x ->- Right x
− Web/Spock/SafeActions.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-module Web.Spock.SafeActions where--import Web.Scotty.Trans-import Web.Spock.Types--import qualified Data.Text as T---- | Wire up a safe action: Safe actions are actions that are protected from--- csrf attacks. Here's a usage example:------ > newtype DeleteUser = DeleteUser Int deriving (Hashable, Typeable, Eq)--- >--- > instance SafeAction DeleteUser where--- > runSafeAction (DeleteUser i) =--- > do runQuery $ deleteUserFromDb i--- > redirect "/user-list"--- >--- > get "/user-details/:userId" $--- > do userId <- param "userId"--- > deleteUrl <- safeActionPath (DeleteUser userId)--- > html $ TL.concat [ "Click <a href='", TL.fromStrict deleteUrl, "'>here</a> to delete user!" ]------ Note that safeActions currently only support GET and POST requests.----safeActionPath :: forall conn sess st a.- ( SafeAction conn sess st a- , HasSpock(SpockAction conn sess st)- , SpockConn (SpockAction conn sess st) ~ conn- , SpockSession (SpockAction conn sess st) ~ sess- , SpockState (SpockAction conn sess st) ~ st)- => a- -> SpockAction conn sess st T.Text-safeActionPath safeAction =- do mgr <- getSessMgr- hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction)- return $ T.concat [ "/h/", hash ]--hookSafeActions :: forall conn sess st.- ( HasSpock (SpockAction conn sess st)- , SpockConn (SpockAction conn sess st) ~ conn- , SpockSession (SpockAction conn sess st) ~ sess- , SpockState (SpockAction conn sess st) ~ st)- => SpockM conn sess st ()-hookSafeActions =- do get "/h/:spock-csurf-protection" run- post "/h/:spock-csurf-protection" run- where- run =- do h <- param "spock-csurf-protection"- mgr <- getSessMgr- mAction <- (sm_lookupSafeAction mgr) h- case mAction of- Nothing ->- next- Just (PackedSafeAction action) ->- runSafeAction action
− Web/Spock/SessionManager.hs
@@ -1,195 +0,0 @@-{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}-module Web.Spock.SessionManager- ( createSessionManager- , SessionId, Session(..), SessionManager(..)- )-where--import Web.Spock.Types-import Web.Spock.Cookie--import Control.Concurrent.STM-import Control.Monad.Trans-import Data.Time-import System.Random-import Web.Scotty.Trans-import qualified Data.ByteString.Base64 as B64-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Lazy as BSL-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.Vault.Lazy as V-import qualified Network.Wai as Wai-import qualified Network.Wai.Util as Wai--createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st)-createSessionManager cfg =- do cacheHM <- atomically $ newTVar HM.empty- vaultKey <- V.newKey- return $ SessionManager- { sm_readSession = readSessionImpl vaultKey cacheHM- , sm_writeSession = writeSessionImpl vaultKey cacheHM- , sm_modifySession = modifySessionImpl vaultKey cacheHM- , sm_middleware = sessionMiddleware cfg vaultKey cacheHM- , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM- , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM- }--modifySessionBase :: V.Key SessionId- -> UserSessions conn sess st- -> (Session conn sess st -> Session conn sess st)- -> SpockAction conn sess st ()-modifySessionBase vK sessionRef modFun =- do req <- request- case V.lookup vK (Wai.vault req) of- Nothing ->- error "(3) Internal Spock Session Error. Please report this bug!"- Just sid ->- liftIO $ atomically $ modifyTVar sessionRef (HM.adjust modFun sid)--readSessionBase :: V.Key SessionId- -> UserSessions conn sess st- -> SpockAction conn sess st (Session conn sess st)-readSessionBase vK sessionRef =- do req <- request- case V.lookup vK (Wai.vault req) of- Nothing ->- error "(1) Internal Spock Session Error. Please report this bug!"- Just sid ->- do sessions <- liftIO $ atomically $ readTVar sessionRef- case HM.lookup sid sessions of- Nothing ->- error "(2) Internal Spock Session Error. Please report this bug!"- Just session ->- return session--addSafeActionImpl :: V.Key SessionId- -> UserSessions conn sess st- -> PackedSafeAction conn sess st- -> SpockAction conn sess st SafeActionHash-addSafeActionImpl vaultKey cacheHM safeAction =- do base <- readSessionBase vaultKey cacheHM- case HM.lookup safeAction (sas_reverse (sess_safeActions base)) of- Just safeActionHash ->- return safeActionHash- Nothing ->- do safeActionHash <- liftIO (randomHash 40)- let f sas =- sas- { sas_forward = HM.insert safeActionHash safeAction (sas_forward sas)- , sas_reverse = HM.insert safeAction safeActionHash (sas_reverse sas)- }- modifySessionBase vaultKey cacheHM (\s -> s { sess_safeActions = f (sess_safeActions s) })- return safeActionHash--lookupSafeActionImpl :: V.Key SessionId- -> UserSessions conn sess st- -> SafeActionHash- -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))-lookupSafeActionImpl vaultKey cacheHM hash =- do base <- readSessionBase vaultKey cacheHM- return $ HM.lookup hash (sas_forward (sess_safeActions base))--readSessionImpl :: V.Key SessionId- -> UserSessions conn sess st- -> SpockAction conn sess st sess-readSessionImpl vK sessionRef =- do base <- readSessionBase vK sessionRef- return (sess_data base)--writeSessionImpl :: V.Key SessionId- -> UserSessions conn sess st- -> sess- -> SpockAction conn sess st ()-writeSessionImpl vK sessionRef value =- modifySessionImpl vK sessionRef (const value)--modifySessionImpl :: V.Key SessionId- -> UserSessions conn sess st- -> (sess -> sess)- -> SpockAction conn sess st ()-modifySessionImpl vK sessionRef f =- do let modFun session =- session { sess_data = f (sess_data session) }- modifySessionBase vK sessionRef modFun--sessionMiddleware :: SessionCfg sess- -> V.Key SessionId- -> UserSessions conn sess st- -> Wai.Middleware-sessionMiddleware cfg vK sessionRef app req =- case getCookieFromReq (sc_cookieName cfg) req of- Just sid ->- do mSess <- loadSessionImpl cfg sessionRef sid- case mSess of- Nothing ->- mkNew- Just sess ->- withSess False sess- Nothing ->- mkNew- where- defVal = sc_emptySession cfg- v = Wai.vault req- addCookie sess responseHeaders =- let cookieContent =- renderCookie (sc_cookieName cfg) (sess_id sess) (sess_validUntil sess)- cookie = ("Set-Cookie", BSL.toStrict $ TL.encodeUtf8 cookieContent)- in (cookie : responseHeaders)- withSess shouldSetCookie sess =- do resp <- app (req { Wai.vault = V.insert vK (sess_id sess) v })- return $ if shouldSetCookie then Wai.mapHeaders (addCookie sess) resp else resp- mkNew =- do newSess <- newSessionImpl cfg sessionRef defVal- withSess True newSess--newSessionImpl :: SessionCfg sess- -> UserSessions conn sess st- -> sess- -> IO (Session conn sess st)-newSessionImpl sessCfg sessionRef content =- do sess <- createSession sessCfg content- atomically $ modifyTVar sessionRef (\hm -> HM.insert (sess_id sess) sess hm)- return sess--loadSessionImpl :: SessionCfg sess- -> UserSessions conn sess st- -> SessionId- -> IO (Maybe (Session conn sess st))-loadSessionImpl sessCfg sessionRef sid =- do sessHM <- atomically $ readTVar sessionRef- now <- getCurrentTime- case HM.lookup sid sessHM of- Just sess ->- do if addUTCTime (sc_sessionTTL sessCfg) (sess_validUntil sess) > now- then return $ Just sess- else do deleteSessionImpl sessionRef sid- return Nothing- Nothing ->- return Nothing--deleteSessionImpl :: UserSessions conn sess st- -> SessionId- -> IO ()-deleteSessionImpl sessionRef sid =- do atomically $ modifyTVar sessionRef (\hm -> HM.delete sid hm)- return ()--createSession :: SessionCfg sess -> sess -> IO (Session conn sess st)-createSession sessCfg content =- do sid <- randomHash (sc_sessionIdEntropy sessCfg)- now <- getCurrentTime- let validUntil = addUTCTime (sc_sessionTTL sessCfg) now- emptySafeActions =- SafeActionStore HM.empty HM.empty- return (Session sid validUntil content emptySafeActions)--randomHash :: Int -> IO T.Text-randomHash len =- do gen <- g- return $ T.decodeUtf8 $ B64.encode $ BSC.pack $- take len $ randoms gen- where- g = newStdGen :: IO StdGen
− Web/Spock/Types.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification #-}-module Web.Spock.Types where--import Web.Scotty.Trans--import Control.Applicative-import Control.Concurrent.STM-import Control.Monad.Base-import Control.Monad.Reader-import Control.Monad.Trans.Control-import Control.Monad.Trans.Resource-import Data.Hashable-import Data.Pool-import Data.Text.Lazy (Text)-import Data.Time.Clock ( UTCTime(..), NominalDiffTime )-import Data.Typeable-import Network.Wai-import qualified Data.Conduit.Pool as CP-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T--type SpockError e = ScottyError e---- | Spock is supercharged Scotty, that's why the 'SpockM' is built on the--- ScottyT monad. Insive the SpockM monad, you may define routes and middleware.-type SpockM conn sess st = ScottyT Text (WebStateM conn sess st)---- | The SpockAction is the monad of all route-actions. You have access--- to the database, session and state of your application.-type SpockAction conn sess st = ActionT Text (WebStateM conn sess st)---- | If Spock should take care of connection pooling, you need to configure--- it depending on what you need.-data PoolCfg- = PoolCfg- { pc_stripes :: Int- , pc_resPerStripe :: Int- , pc_keepOpenTime :: NominalDiffTime- }---- | The ConnBuilder instructs Spock how to create or close a database connection.-data ConnBuilder a- = ConnBuilder- { cb_createConn :: IO a- , cb_destroyConn :: a -> IO ()- , cb_poolConfiguration :: PoolCfg- }---- | You can feed Spock with either a connection pool, or instructions on how to build--- a connection pool. See 'ConnBuilder'-data PoolOrConn a- = PCPool (Pool a)- | PCConduitPool (CP.Pool a)- | PCConn (ConnBuilder a)---- | Configuration for the session manager-data SessionCfg a- = SessionCfg- { sc_cookieName :: T.Text- , sc_sessionTTL :: NominalDiffTime- , sc_sessionIdEntropy :: Int- , sc_emptySession :: a- }--data ConnectionPool conn- = DataPool (Pool conn)- | ConduitPool (CP.Pool conn)--data WebState conn sess st- = WebState- { web_dbConn :: ConnectionPool conn- , web_sessionMgr :: SessionManager conn sess st- , web_state :: st- }--class HasSpock m where- type SpockConn m :: *- type SpockState m :: *- type SpockSession m :: *- -- | Give you access to a database connectin from the connection pool. The connection is- -- released back to the pool once the function terminates.- runQuery :: (SpockConn m -> IO a) -> m a- -- | Read the application's state. If you wish to have mutable state, you could- -- use a 'TVar' from the STM packge.- getState :: m (SpockState m)- -- | Get the session manager- getSessMgr :: m (SessionManager (SpockConn m) (SpockSession m) (SpockState m))---- | SafeActions are actions that need to be protected from csrf attacks-class (Hashable a, Eq a, Typeable a) => SafeAction conn sess st a where- runSafeAction :: a -> SpockAction conn sess st ()--data PackedSafeAction conn sess st- = forall a. (SafeAction conn sess st a) => PackedSafeAction { unpackSafeAction :: a }--instance Hashable (PackedSafeAction conn sess st) where- hashWithSalt i (PackedSafeAction a) = hashWithSalt i a--instance Eq (PackedSafeAction conn sess st) where- (PackedSafeAction a) == (PackedSafeAction b) =- cast a == Just b--data SafeActionStore conn sess st- = SafeActionStore- { sas_forward :: HM.HashMap SafeActionHash (PackedSafeAction conn sess st)- , sas_reverse :: HM.HashMap (PackedSafeAction conn sess st) SafeActionHash- }--type SafeActionHash = T.Text--newtype WebStateM conn sess st a = WebStateM { runWebStateM :: ReaderT (WebState conn sess st) (ResourceT IO) a }- deriving (Monad, Functor, Applicative, MonadIO, MonadReader (WebState conn sess st))--instance MonadBase IO (WebStateM conn sess st) where- liftBase = WebStateM . liftBase--instance MonadBaseControl IO (WebStateM conn sess st) where- newtype StM (WebStateM conn sess st) a = WStM { unWStM :: StM (ReaderT (WebState conn sess st) (ResourceT IO)) a }- liftBaseWith f = WebStateM . liftBaseWith $ \runInBase -> f $ liftM WStM . runInBase . runWebStateM- restoreM = WebStateM . restoreM . unWStM--type SessionId = T.Text-data Session conn sess st- = Session- { sess_id :: SessionId- , sess_validUntil :: UTCTime- , sess_data :: sess- , sess_safeActions :: SafeActionStore conn sess st- }-type UserSessions conn sess st =- TVar (HM.HashMap SessionId (Session conn sess st))--data SessionManager conn sess st- = SessionManager- { sm_readSession :: SpockAction conn sess st sess- , sm_writeSession :: sess -> SpockAction conn sess st ()- , sm_modifySession :: (sess -> sess) -> SpockAction conn sess st ()- , sm_middleware :: Middleware- , sm_addSafeAction :: (PackedSafeAction conn sess st) -> SpockAction conn sess st SafeActionHash- , sm_lookupSafeAction :: SafeActionHash -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))- }
+ src/Web/Spock.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Spock+ ( -- * Spock's core+ spock, SpockM, SpockAction+ -- * Database+ , PoolOrConn (..), ConnBuilder (..), PoolCfg (..)+ -- * Accessing Database and State+ , HasSpock (runQuery, getState)+ -- * Sessions+ , SessionCfg (..)+ , readSession, writeSession, modifySession+ -- * Cookies+ , setCookie, setCookie', getCookie+ -- * Safe actions+ , SafeAction (..)+ , safeActionPath+ -- * General Routing+ , get, post, put, delete, patch, addroute, Http.StdMethod (..)+ -- * Other reexports from scotty+ , middleware, matchAny, notFound+ , request, reqHeader, body, param, params, jsonData, files+ , status, addHeader, setHeader, redirect+ , text, html, file, json, source, raw+ , raise, rescue, next+ , RoutePattern+ -- * Spock utilities+ , paramPathPiece+ -- * Internals for extending Spock+ , getSpockHeart, runSpockIO, WebStateM, WebState+ )+where++import Web.Spock.SessionManager+import Web.Spock.Monad+import Web.Spock.Types+import Web.Spock.Cookie+import Web.Spock.SafeActions++import Control.Applicative+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Resource+import Data.Pool+import Web.Scotty.Trans+import Web.PathPieces+import qualified Network.HTTP.Types as Http+import qualified Data.Text.Lazy as TL++-- | Run a spock application using the warp server, a given db storageLayer and an initial state.+-- Spock works with database libraries that already implement connection pooling and+-- with those that don't come with it out of the box. For more see the 'PoolOrConn' type.+spock :: Int -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()+spock port sessionCfg poolOrConn initialState defs =+ do sessionMgr <- createSessionManager sessionCfg+ connectionPool <-+ case poolOrConn of+ PCConduitPool p ->+ return (ConduitPool p)+ PCPool p ->+ return (DataPool p)+ PCConn cb ->+ let pc = cb_poolConfiguration cb+ in DataPool <$> createPool (cb_createConn cb) (cb_destroyConn cb)+ (pc_stripes pc) (pc_keepOpenTime pc)+ (pc_resPerStripe pc)+ let internalState =+ WebState+ { web_dbConn = connectionPool+ , web_sessionMgr = sessionMgr+ , web_state = initialState+ }+ runM m = runResourceT $ runReaderT (runWebStateM m) internalState+ runActionToIO = runM++ scottyT port runM runActionToIO $+ do middleware (sm_middleware sessionMgr)+ hookSafeActions+ defs++-- | Write to the current session. Note that all data is stored on the server.+-- The user only reciedes a sessionId to be identified.+writeSession :: sess -> SpockAction conn sess st ()+writeSession d =+ do mgr <- getSessMgr+ (sm_writeSession mgr) d++-- | Modify the stored session+modifySession :: (sess -> sess) -> SpockAction conn sess st ()+modifySession f =+ do mgr <- getSessMgr+ (sm_modifySession mgr) f++-- | Read the stored session+readSession :: SpockAction conn sess st sess+readSession =+ do mgr <- getSessMgr+ sm_readSession mgr++-- | Same as "param", but the target type needs to implement "PathPiece"+paramPathPiece :: PathPiece s => TL.Text -> SpockAction conn sess st s+paramPathPiece t =+ do val <- param t+ case fromPathPiece val of+ Just x ->+ return x+ Nothing ->+ raise $ stringError $ "Cannot convert param: " ++ TL.unpack t ++ " to path piece!"
+ src/Web/Spock/Cookie.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Spock.Cookie where++import Web.Spock.Types++import Control.Arrow+import Control.Monad.Trans+import Data.Time+import System.Locale+import Web.Scotty.Trans+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Network.Wai as Wai++-- | Read a cookie previously set in the users browser for your site+getCookie :: (SpockError e, MonadIO m) => T.Text -> ActionT e m (Maybe T.Text)+getCookie name =+ do r <- request+ return $ getCookieFromReq name r++getCookieFromReq :: T.Text -> Wai.Request -> Maybe T.Text+getCookieFromReq name req =+ lookup "cookie" (Wai.requestHeaders req) >>=+ lookup name . parseCookies . T.decodeUtf8+ where+ parseCookies :: T.Text -> [(T.Text, T.Text)]+ parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words+ parseCookie = first T.init . T.breakOnEnd "="++-- | Set a cookie living for a given number of seconds+setCookie :: (SpockError e, MonadIO m) => T.Text -> T.Text -> NominalDiffTime+ -> ActionT e m ()+setCookie name value validSeconds =+ do now <- liftIO getCurrentTime+ setCookie' name value (validSeconds `addUTCTime` now)++-- | Set a cookie living until a specific 'UTCTime'+setCookie' :: (SpockError e, MonadIO m) => T.Text -> T.Text -> UTCTime+ -> ActionT e m ()+setCookie' name value validUntil =+ setHeader "Set-Cookie" (renderCookie name value validUntil)++renderCookie :: T.Text -> T.Text -> UTCTime -> TL.Text+renderCookie name value validUntil =+ let formattedTime =+ TL.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" validUntil+ in TL.concat [ TL.fromStrict name+ , "="+ , TL.fromStrict value+ , "; path=/; expires="+ , formattedTime+ , ";"+ ]
+ src/Web/Spock/Monad.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+module Web.Spock.Monad where++import Web.Spock.Types++import Control.Monad+import Control.Monad.Reader+import Control.Monad.Trans.Resource+import Data.Pool+import Data.Time.Clock ( UTCTime(..) )+import Web.Scotty.Trans+import qualified Data.Conduit.Pool as CP+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Text.XML.XSD.DateTime as XSD++webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a+webM = lift++instance MonadTrans t => HasSpock (t (WebStateM conn sess st)) where+ type SpockConn (t (WebStateM conn sess st)) = conn+ type SpockState (t (WebStateM conn sess st)) = st+ type SpockSession (t (WebStateM conn sess st)) = sess+ runQuery a = webM $ runQueryImpl a+ getState = webM $ getStateImpl+ getSessMgr = webM $ getSessMgrImpl++instance HasSpock (WebStateM conn sess st) where+ type SpockConn (WebStateM conn sess st) = conn+ type SpockState (WebStateM conn sess st) = st+ type SpockSession (WebStateM conn sess st) = sess+ runQuery = runQueryImpl+ getState = getStateImpl+ getSessMgr = getSessMgrImpl++runQueryImpl :: (conn -> IO a) -> WebStateM conn sess st a+runQueryImpl query =+ do pool <- asks web_dbConn+ let fun =+ case pool of+ DataPool p ->+ withResource p+ ConduitPool p ->+ CP.withResource p+ liftIO (fun query)++getStateImpl :: WebStateM conn sess st st+getStateImpl = asks web_state++-- | Read the heart of Spock. This is useful if you want to construct your own+-- monads that work with runQuery and getState using "runSpockIO"+getSpockHeart :: MonadTrans t => t (WebStateM conn sess st) (WebState conn sess st)+getSpockHeart = webM ask++-- | Run an action inside of Spocks core monad. This allows you to use runQuery and getState+runSpockIO :: WebState conn sess st -> WebStateM conn sess st a -> IO a+runSpockIO st (WebStateM action) =+ runResourceT $+ runReaderT action st++getSessMgrImpl :: (WebStateM conn sess st) (SessionManager conn sess st)+getSessMgrImpl = asks web_sessionMgr++instance Parsable BSL.ByteString where+ parseParam =+ Right . BSL.fromStrict . T.encodeUtf8 . TL.toStrict++instance Parsable UTCTime where+ parseParam p =+ case join $ fmap XSD.toUTCTime $ XSD.dateTime (TL.toStrict p) of+ Nothing ->+ Left $ TL.pack $ "Can't parse param (`" ++ show p ++ "`) as UTCTime!"+ Just x ->+ Right x
+ src/Web/Spock/SafeActions.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module Web.Spock.SafeActions where++import Web.Scotty.Trans+import Web.Spock.Types++import qualified Data.Text as T++-- | Wire up a safe action: Safe actions are actions that are protected from+-- csrf attacks. Here's a usage example:+--+-- > newtype DeleteUser = DeleteUser Int deriving (Hashable, Typeable, Eq)+-- >+-- > instance SafeAction Connection () () DeleteUser where+-- > runSafeAction (DeleteUser i) =+-- > do runQuery $ deleteUserFromDb i+-- > redirect "/user-list"+-- >+-- > get "/user-details/:userId" $+-- > do userId <- param "userId"+-- > deleteUrl <- safeActionPath (DeleteUser userId)+-- > html $ TL.concat [ "Click <a href='", TL.fromStrict deleteUrl, "'>here</a> to delete user!" ]+--+-- Note that safeActions currently only support GET and POST requests.+--+safeActionPath :: forall conn sess st a.+ ( SafeAction conn sess st a+ , HasSpock(SpockAction conn sess st)+ , SpockConn (SpockAction conn sess st) ~ conn+ , SpockSession (SpockAction conn sess st) ~ sess+ , SpockState (SpockAction conn sess st) ~ st)+ => a+ -> SpockAction conn sess st T.Text+safeActionPath safeAction =+ do mgr <- getSessMgr+ hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction)+ return $ T.concat [ "/h/", hash ]++hookSafeActions :: forall conn sess st.+ ( HasSpock (SpockAction conn sess st)+ , SpockConn (SpockAction conn sess st) ~ conn+ , SpockSession (SpockAction conn sess st) ~ sess+ , SpockState (SpockAction conn sess st) ~ st)+ => SpockM conn sess st ()+hookSafeActions =+ do get "/h/:spock-csurf-protection" run+ post "/h/:spock-csurf-protection" run+ where+ run =+ do h <- param "spock-csurf-protection"+ mgr <- getSessMgr+ mAction <- (sm_lookupSafeAction mgr) h+ case mAction of+ Nothing ->+ next+ Just (PackedSafeAction action) ->+ runSafeAction action
+ src/Web/Spock/SessionManager.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}+module Web.Spock.SessionManager+ ( createSessionManager+ , SessionId, Session(..), SessionManager(..)+ )+where++import Web.Spock.Types+import Web.Spock.Cookie++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Trans+import Data.Time+import System.Random+import Web.Scotty.Trans+import qualified Data.ByteString.Base64.URL as B64+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Vault.Lazy as V+import qualified Network.Wai as Wai+import qualified Network.Wai.Util as Wai++createSessionManager :: SessionCfg sess -> IO (SessionManager conn sess st)+createSessionManager cfg =+ do cacheHM <- atomically $ newTVar HM.empty+ vaultKey <- V.newKey+ _ <- forkIO (forever (housekeepSessions cacheHM))+ return $ SessionManager+ { sm_readSession = readSessionImpl vaultKey cacheHM+ , sm_writeSession = writeSessionImpl vaultKey cacheHM+ , sm_modifySession = modifySessionImpl vaultKey cacheHM+ , sm_middleware = sessionMiddleware cfg vaultKey cacheHM+ , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM+ , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM+ , sm_removeSafeAction = removeSafeActionImpl vaultKey cacheHM+ }++modifySessionBase :: V.Key SessionId+ -> UserSessions conn sess st+ -> (Session conn sess st -> Session conn sess st)+ -> SpockAction conn sess st ()+modifySessionBase vK sessionRef modFun =+ do req <- request+ case V.lookup vK (Wai.vault req) of+ Nothing ->+ error "(3) Internal Spock Session Error. Please report this bug!"+ Just sid ->+ liftIO $ atomically $ modifyTVar' sessionRef (HM.adjust modFun sid)++readSessionBase :: V.Key SessionId+ -> UserSessions conn sess st+ -> SpockAction conn sess st (Session conn sess st)+readSessionBase vK sessionRef =+ do req <- request+ case V.lookup vK (Wai.vault req) of+ Nothing ->+ error "(1) Internal Spock Session Error. Please report this bug!"+ Just sid ->+ do sessions <- liftIO $ atomically $ readTVar sessionRef+ case HM.lookup sid sessions of+ Nothing ->+ error "(2) Internal Spock Session Error. Please report this bug!"+ Just session ->+ return session++addSafeActionImpl :: V.Key SessionId+ -> UserSessions conn sess st+ -> PackedSafeAction conn sess st+ -> SpockAction conn sess st SafeActionHash+addSafeActionImpl vaultKey sessionMapVar safeAction =+ do base <- readSessionBase vaultKey sessionMapVar+ case HM.lookup safeAction (sas_reverse (sess_safeActions base)) of+ Just safeActionHash ->+ return safeActionHash+ Nothing ->+ do safeActionHash <- liftIO (randomHash 40)+ let f sas =+ sas+ { sas_forward = HM.insert safeActionHash safeAction (sas_forward sas)+ , sas_reverse = HM.insert safeAction safeActionHash (sas_reverse sas)+ }+ modifySessionBase vaultKey sessionMapVar (\s -> s { sess_safeActions = f (sess_safeActions s) })+ return safeActionHash++lookupSafeActionImpl :: V.Key SessionId+ -> UserSessions conn sess st+ -> SafeActionHash+ -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))+lookupSafeActionImpl vaultKey sessionMapVar hash =+ do base <- readSessionBase vaultKey sessionMapVar+ return $ HM.lookup hash (sas_forward (sess_safeActions base))++removeSafeActionImpl :: V.Key SessionId+ -> UserSessions conn sess st+ -> PackedSafeAction conn sess st+ -> SpockAction conn sess st ()+removeSafeActionImpl vaultKey sessionMapVar action =+ modifySessionBase vaultKey sessionMapVar (\s -> s { sess_safeActions = f (sess_safeActions s ) })+ where+ f sas =+ sas+ { sas_forward =+ case HM.lookup action (sas_reverse sas) of+ Just h -> HM.delete h (sas_forward sas)+ Nothing -> sas_forward sas+ , sas_reverse = HM.delete action (sas_reverse sas)+ }++readSessionImpl :: V.Key SessionId+ -> UserSessions conn sess st+ -> SpockAction conn sess st sess+readSessionImpl vK sessionRef =+ do base <- readSessionBase vK sessionRef+ return (sess_data base)++writeSessionImpl :: V.Key SessionId+ -> UserSessions conn sess st+ -> sess+ -> SpockAction conn sess st ()+writeSessionImpl vK sessionRef value =+ modifySessionImpl vK sessionRef (const value)++modifySessionImpl :: V.Key SessionId+ -> UserSessions conn sess st+ -> (sess -> sess)+ -> SpockAction conn sess st ()+modifySessionImpl vK sessionRef f =+ do let modFun session =+ session { sess_data = f (sess_data session) }+ modifySessionBase vK sessionRef modFun++sessionMiddleware :: SessionCfg sess+ -> V.Key SessionId+ -> UserSessions conn sess st+ -> Wai.Middleware+sessionMiddleware cfg vK sessionRef app req =+ case getCookieFromReq (sc_cookieName cfg) req of+ Just sid ->+ do mSess <- loadSessionImpl sessionRef sid+ case mSess of+ Nothing ->+ mkNew+ Just sess ->+ withSess False sess+ Nothing ->+ mkNew+ where+ defVal = sc_emptySession cfg+ v = Wai.vault req+ addCookie sess responseHeaders =+ let cookieContent =+ renderCookie (sc_cookieName cfg) (sess_id sess) (sess_validUntil sess)+ cookie = ("Set-Cookie", BSL.toStrict $ TL.encodeUtf8 cookieContent)+ in (cookie : responseHeaders)+ withSess shouldSetCookie sess =+ do resp <- app (req { Wai.vault = V.insert vK (sess_id sess) v })+ return $ if shouldSetCookie then Wai.mapHeaders (addCookie sess) resp else resp+ mkNew =+ do newSess <- newSessionImpl cfg sessionRef defVal+ withSess True newSess++newSessionImpl :: SessionCfg sess+ -> UserSessions conn sess st+ -> sess+ -> IO (Session conn sess st)+newSessionImpl sessCfg sessionRef content =+ do sess <- createSession sessCfg content+ atomically $ modifyTVar' sessionRef (\hm -> HM.insert (sess_id sess) sess hm)+ return $! sess++loadSessionImpl :: UserSessions conn sess st+ -> SessionId+ -> IO (Maybe (Session conn sess st))+loadSessionImpl sessionRef sid =+ do sessHM <- atomically $ readTVar sessionRef+ now <- getCurrentTime+ case HM.lookup sid sessHM of+ Just sess ->+ do if (sess_validUntil sess) > now+ then return $ Just sess+ else do deleteSessionImpl sessionRef sid+ return Nothing+ Nothing ->+ return Nothing++deleteSessionImpl :: UserSessions conn sess st+ -> SessionId+ -> IO ()+deleteSessionImpl sessionRef sid =+ do atomically $ modifyTVar' sessionRef (\hm -> HM.delete sid hm)+ return ()++housekeepSessions :: UserSessions conn sess st -> IO ()+housekeepSessions sessionRef =+ do now <- getCurrentTime+ atomically $ modifyTVar' sessionRef (killOld now)+ threadDelay (1000 * 1000 * 60) -- 60 seconds+ where+ filterOld now (_, sess) =+ (sess_validUntil sess) > now+ killOld now hm =+ HM.fromList $ filter (filterOld now) $ HM.toList hm++createSession :: SessionCfg sess -> sess -> IO (Session conn sess st)+createSession sessCfg content =+ do sid <- randomHash (sc_sessionIdEntropy sessCfg)+ now <- getCurrentTime+ let validUntil = addUTCTime (sc_sessionTTL sessCfg) now+ emptySafeActions =+ SafeActionStore HM.empty HM.empty+ return (Session sid validUntil content emptySafeActions)++randomHash :: Int -> IO T.Text+randomHash len =+ do gen <- g+ return $ T.replace "=" "" $ T.decodeUtf8 $ B64.encode $ BSC.pack $+ take len $ randoms gen+ where+ g = newStdGen :: IO StdGen
+ src/Web/Spock/Types.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+module Web.Spock.Types where++import Web.Scotty.Trans++import Control.Applicative+import Control.Concurrent.STM+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource+import Data.Hashable+import Data.Pool+import Data.Text.Lazy (Text)+import Data.Time.Clock ( UTCTime(..), NominalDiffTime )+import Data.Typeable+import Network.Wai+import qualified Data.Conduit.Pool as CP+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T++type SpockError e = ScottyError e++-- | Spock is supercharged Scotty, that's why the 'SpockM' is built on the+-- ScottyT monad. Insive the SpockM monad, you may define routes and middleware.+type SpockM conn sess st = ScottyT Text (WebStateM conn sess st)++-- | The SpockAction is the monad of all route-actions. You have access+-- to the database, session and state of your application.+type SpockAction conn sess st = ActionT Text (WebStateM conn sess st)++-- | If Spock should take care of connection pooling, you need to configure+-- it depending on what you need.+data PoolCfg+ = PoolCfg+ { pc_stripes :: Int+ , pc_resPerStripe :: Int+ , pc_keepOpenTime :: NominalDiffTime+ }++-- | The ConnBuilder instructs Spock how to create or close a database connection.+data ConnBuilder a+ = ConnBuilder+ { cb_createConn :: IO a+ , cb_destroyConn :: a -> IO ()+ , cb_poolConfiguration :: PoolCfg+ }++-- | You can feed Spock with either a connection pool, or instructions on how to build+-- a connection pool. See 'ConnBuilder'+data PoolOrConn a+ = PCPool (Pool a)+ | PCConduitPool (CP.Pool a)+ | PCConn (ConnBuilder a)++-- | Configuration for the session manager+data SessionCfg a+ = SessionCfg+ { sc_cookieName :: T.Text+ , sc_sessionTTL :: NominalDiffTime+ , sc_sessionIdEntropy :: Int+ , sc_emptySession :: a+ }++data ConnectionPool conn+ = DataPool (Pool conn)+ | ConduitPool (CP.Pool conn)++data WebState conn sess st+ = WebState+ { web_dbConn :: ConnectionPool conn+ , web_sessionMgr :: SessionManager conn sess st+ , web_state :: st+ }++class HasSpock m where+ type SpockConn m :: *+ type SpockState m :: *+ type SpockSession m :: *+ -- | Give you access to a database connectin from the connection pool. The connection is+ -- released back to the pool once the function terminates.+ runQuery :: (SpockConn m -> IO a) -> m a+ -- | Read the application's state. If you wish to have mutable state, you could+ -- use a 'TVar' from the STM packge.+ getState :: m (SpockState m)+ -- | Get the session manager+ getSessMgr :: m (SessionManager (SpockConn m) (SpockSession m) (SpockState m))++-- | SafeActions are actions that need to be protected from csrf attacks+class (Hashable a, Eq a, Typeable a) => SafeAction conn sess st a where+ -- | The body of the safe action. Either GET or POST+ runSafeAction :: a -> SpockAction conn sess st ()++data PackedSafeAction conn sess st+ = forall a. (SafeAction conn sess st a) => PackedSafeAction { unpackSafeAction :: a }++instance Hashable (PackedSafeAction conn sess st) where+ hashWithSalt i (PackedSafeAction a) = hashWithSalt i a++instance Eq (PackedSafeAction conn sess st) where+ (PackedSafeAction a) == (PackedSafeAction b) =+ cast a == Just b++data SafeActionStore conn sess st+ = SafeActionStore+ { sas_forward :: !(HM.HashMap SafeActionHash (PackedSafeAction conn sess st))+ , sas_reverse :: !(HM.HashMap (PackedSafeAction conn sess st) SafeActionHash)+ }++type SafeActionHash = T.Text++newtype WebStateM conn sess st a = WebStateM { runWebStateM :: ReaderT (WebState conn sess st) (ResourceT IO) a }+ deriving (Monad, Functor, Applicative, MonadIO, MonadReader (WebState conn sess st))++instance MonadBase IO (WebStateM conn sess st) where+ liftBase = WebStateM . liftBase++instance MonadBaseControl IO (WebStateM conn sess st) where+ newtype StM (WebStateM conn sess st) a = WStM { unWStM :: StM (ReaderT (WebState conn sess st) (ResourceT IO)) a }+ liftBaseWith f = WebStateM . liftBaseWith $ \runInBase -> f $ liftM WStM . runInBase . runWebStateM+ restoreM = WebStateM . restoreM . unWStM++type SessionId = T.Text+data Session conn sess st+ = Session+ { sess_id :: !SessionId+ , sess_validUntil :: !UTCTime+ , sess_data :: !sess+ , sess_safeActions :: !(SafeActionStore conn sess st)+ }+instance Show (Session conn sess st) where+ show = show . sess_id++type UserSessions conn sess st =+ TVar (HM.HashMap SessionId (Session conn sess st))++data SessionManager conn sess st+ = SessionManager+ { sm_readSession :: SpockAction conn sess st sess+ , sm_writeSession :: sess -> SpockAction conn sess st ()+ , sm_modifySession :: (sess -> sess) -> SpockAction conn sess st ()+ , sm_middleware :: Middleware+ , sm_addSafeAction :: PackedSafeAction conn sess st -> SpockAction conn sess st SafeActionHash+ , sm_lookupSafeAction :: SafeActionHash -> SpockAction conn sess st (Maybe (PackedSafeAction conn sess st))+ , sm_removeSafeAction :: PackedSafeAction conn sess st -> SpockAction conn sess st ()+ }