Spock 0.4.2.4 → 0.4.3.0
raw patch · 5 files changed
+143/−146 lines, 5 filesdep +vaultdep +wai-util
Dependencies added: vault, wai-util
Files
- Spock.cabal +7/−5
- Web/Spock.hs +24/−81
- Web/Spock/Cookie.hs +18/−11
- Web/Spock/SessionManager.hs +86/−31
- Web/Spock/Types.hs +8/−18
Spock.cabal view
@@ -1,13 +1,13 @@ name: Spock-version: 0.4.2.4+version: 0.4.3.0 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, database helper, authentication and the power of scotty+description: This toolbox provides everything you need to get a quick start into web hacking with haskell: sessions, cookies, database helper, global state and the power of scotty Homepage: https://github.com/agrafix/Spock Bug-reports: https://github.com/agrafix/Spock/issues license: BSD3 author: Alexander Thiemann <mail@agrafix.net> maintainer: mail@agrafix.net-copyright: (c) 2013 Alexander Thiemann+copyright: (c) 2013 - 2014 Alexander Thiemann category: Web build-type: Simple cabal-version: >=1.8@@ -21,6 +21,7 @@ build-depends: base >= 4 && < 5, scotty >= 0.6, wai >=2.0,+ wai-util ==0.7, http-types ==0.8.*, text >= 0.11.3.1 && < 1.2, containers ==0.5.*,@@ -40,8 +41,9 @@ aeson >=0.6, resource-pool ==0.2.*, random ==1.*,- pool-conduit ==0.1.*- ghc-options: -fwarn-unused-imports+ pool-conduit ==0.1.*,+ vault ==0.3.*+ ghc-options: -Wall -fno-warn-orphans source-repository head type: git
Web/Spock.hs view
@@ -10,23 +10,20 @@ , PoolOrConn (..), ConnBuilder (..), PoolCfg (..) -- * Accessing Database and State , HasSpock (runQuery, getState)- -- * Authorization+ -- * Sessions , SessionCfg (..)- , authedUser, unauthCurrent- -- * Authorized Routing- , NoAccessReason (..), UserRights- , NoAccessHandler, LoadUserFun, CheckRightsFun- , authed- -- * General Routing- , get, post, put, delete, patch, addroute, Http.StdMethod (..)+ , readSession, writeSession, modifySession -- * Cookies , setCookie, setCookie', getCookie+ -- * 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 -- * Internals for extending Spock , getSpockHeart, runSpockIO, WebStateM, WebState )@@ -38,7 +35,6 @@ import Web.Spock.Cookie import Control.Applicative-import Control.Monad.Trans import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Data.Pool@@ -48,9 +44,9 @@ -- | 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 -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO ()+spock :: Int -> SessionCfg sess -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO () spock port sessionCfg poolOrConn initialState defs =- do sessionMgr <- openSessionManager sessionCfg+ do sessionMgr <- createSessionManager sessionCfg connectionPool <- case poolOrConn of PCConduitPool p ->@@ -71,78 +67,25 @@ runM m = runResourceT $ runReaderT (runWebStateM m) internalState runActionToIO = runM - scottyT port runM runActionToIO defs+ scottyT port runM runActionToIO $+ do middleware (sm_middleware sessionMgr)+ defs --- | After checking that a login was successfull, register the usersId--- into the session and create a session cookie for later "authed" requests--- to work properly-authedUser :: user -> (user -> sess) -> SpockAction conn sess st ()-authedUser user getSessionId =+-- | 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_createCookieSession mgr) (getSessionId user)+ (sm_writeSession mgr) d --- | Destroy the current users session-unauthCurrent :: SpockAction conn sess st ()-unauthCurrent =+-- | Modify the stored session+modifySession :: (sess -> sess) -> SpockAction conn sess st ()+modifySession f = do mgr <- getSessMgr- mSess <- sm_sessionFromCookie mgr- case mSess of- Just sess -> liftIO $ (sm_deleteSession mgr) (sess_id sess)- Nothing -> return ()---- | Define what happens to non-authorized requests-type NoAccessHandler conn sess st =- NoAccessReason -> SpockAction conn sess st ()---- | How should a session be transformed into a user? Can access the database using 'runQuery'-type LoadUserFun conn sess st user =- sess -> SpockAction conn sess st (Maybe user)---- | What rights does the current user have? Can access the database using 'runQuery'-type CheckRightsFun conn sess st user =- user -> [UserRights] -> SpockAction conn sess st Bool+ (sm_modifySession mgr) f --- | Before the request is performed, you can check if the signed in user has permissions to--- view the contents of the request. You may want to define a helper function that--- proxies this function to not pass around 'NoAccessHandler', 'LoadUserFun' and 'CheckRightsFun'--- all the time.--- Example:------ > type MyWebMonad a = SpockAction Connection Int () a--- > newtype MyUser = MyUser { unMyUser :: T.Text }--- >--- > http403 msg =--- > do status Http.status403--- > text (show msg)--- >--- > login :: Http.StdMethod--- > -> [UserRights]--- > -> RoutePattern--- > -> (MyUser -> MyWebMonad ())--- > -> MyWebMonad ()--- > login =--- > authed http403 myLoadUser myCheckRights----authed :: NoAccessHandler conn sess st- -> LoadUserFun conn sess st user- -> CheckRightsFun conn sess st user- -> Http.StdMethod -> [UserRights] -> RoutePattern- -> (user -> SpockAction conn sess st ())- -> SpockM conn sess st ()-authed noAccessHandler loadUser checkRights reqTy requiredRights route action =- addroute reqTy route $- do mgr <- getSessMgr- mSess <- fmap sess_data <$> (sm_sessionFromCookie mgr)- case mSess of- Just sval ->- do mUser <- loadUser sval- case mUser of- Just user ->- do isOk <- checkRights user requiredRights- if isOk- then action user- else noAccessHandler NotEnoughRights- Nothing ->- noAccessHandler NotLoggedIn- Nothing ->- noAccessHandler NoSession+-- | Read the stored session+readSession :: SpockAction conn sess st sess+readSession =+ do mgr <- getSessMgr+ sm_readSession mgr
Web/Spock/Cookie.hs view
@@ -16,9 +16,13 @@ -- | 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 req <- request- return $ lookup "cookie" (Wai.requestHeaders req) >>=- lookup name . parseCookies . T.decodeUtf8+ 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@@ -35,13 +39,16 @@ 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 setHeader "Set-Cookie" (TL.concat [ TL.fromStrict name- , "="- , TL.fromStrict value- , "; path=/; expires="- , formattedTime- , ";"- ]- )+ in TL.concat [ TL.fromStrict name+ , "="+ , TL.fromStrict value+ , "; path=/; expires="+ , formattedTime+ , ";"+ ]
Web/Spock/SessionManager.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-} module Web.Spock.SessionManager- ( openSessionManager+ ( createSessionManager , SessionId, Session(..), SessionManager(..) ) where@@ -13,33 +13,100 @@ import Data.Time import System.Random import Web.Scotty.Trans+import qualified Data.Vault.Lazy as V import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Base64 as B64 import qualified Data.HashMap.Strict as HM import qualified Data.Text.Encoding as T+import qualified Network.Wai as Wai+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.ByteString.Lazy as BSL+import qualified Network.Wai.Util as Wai -openSessionManager :: SessionCfg -> IO (SessionManager a)-openSessionManager cfg =+createSessionManager :: SessionCfg a -> IO (SessionManager a)+createSessionManager cfg = do cacheHM <- atomically $ newTVar HM.empty+ vaultKey <- V.newKey return $ SessionManager- { sm_loadSession = loadSessionImpl cfg cacheHM- , sm_sessionFromCookie = sessionFromCookieImpl cfg cacheHM- , sm_createCookieSession = createCookieSessionImpl cfg cacheHM- , sm_newSession = newSessionImpl cfg cacheHM- , sm_deleteSession = deleteSessionImpl cacheHM+ { sm_readSession = readSessionImpl vaultKey cacheHM+ , sm_writeSession = writeSessionImpl vaultKey cacheHM+ , sm_modifySession = modifySessionImpl vaultKey cacheHM+ , sm_middleware = sessionMiddleware cfg vaultKey cacheHM } -createCookieSessionImpl :: (SpockError e, MonadIO m)- => SessionCfg- -> UserSessions a- -> a- -> ActionT e m ()-createCookieSessionImpl sessCfg sessRef val =- do sess <- liftIO $ newSessionImpl sessCfg sessRef val- setCookie' (sc_cookieName sessCfg) (sess_id sess) (sess_validUntil sess)+readSessionImpl :: (SpockError e, MonadIO m)+ => V.Key SessionId+ -> UserSessions a+ -> ActionT e m a+readSessionImpl 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 (sess_data session) -newSessionImpl :: SessionCfg+writeSessionImpl :: (SpockError e, MonadIO m)+ => V.Key SessionId+ -> UserSessions a+ -> a+ -> ActionT e m ()+writeSessionImpl vK sessionRef value =+ modifySessionImpl vK sessionRef (const value)++modifySessionImpl :: (SpockError e, MonadIO m)+ => V.Key SessionId+ -> UserSessions a+ -> (a -> a)+ -> ActionT e m ()+modifySessionImpl vK sessionRef f =+ do req <- request+ case V.lookup vK (Wai.vault req) of+ Nothing ->+ error "(3) Internal Spock Session Error. Please report this bug!"+ Just sid ->+ do let modFun session =+ session { sess_data = f (sess_data session) }+ liftIO $ atomically $ modifyTVar sessionRef (HM.adjust modFun sid)+++sessionMiddleware :: SessionCfg a+ -> V.Key SessionId+ -> UserSessions a+ -> 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 a -> UserSessions a -> a -> IO (Session a)@@ -48,19 +115,7 @@ atomically $ modifyTVar sessionRef (\hm -> HM.insert (sess_id sess) sess hm) return sess -sessionFromCookieImpl :: (SpockError e, MonadIO m)- => SessionCfg- -> UserSessions a- -> ActionT e m (Maybe (Session a))-sessionFromCookieImpl sessCfg sessionRef =- do mSid <- getCookie (sc_cookieName sessCfg)- case mSid of- Just sid ->- liftIO $ loadSessionImpl sessCfg sessionRef sid- Nothing ->- return Nothing--loadSessionImpl :: SessionCfg+loadSessionImpl :: SessionCfg a -> UserSessions a -> SessionId -> IO (Maybe (Session a))@@ -83,7 +138,7 @@ do atomically $ modifyTVar sessionRef (\hm -> HM.delete sid hm) return () -createSession :: SessionCfg -> a -> IO (Session a)+createSession :: SessionCfg a -> a -> IO (Session a) createSession sessCfg content = do gen <- g let sid = T.decodeUtf8 $ B64.encode $ BSC.pack $
Web/Spock/Types.hs view
@@ -12,13 +12,14 @@ import Control.Monad.Reader import Control.Monad.Trans.Resource import Data.Pool-import Data.Time.Clock ( UTCTime(..), NominalDiffTime(..) )+import Data.Time.Clock ( UTCTime(..), NominalDiffTime ) import qualified Data.Conduit.Pool as CP import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Data.Text.Lazy (Text) import Control.Monad.Trans.Control import Control.Monad.Base+import Network.Wai type SpockError e = ScottyError e @@ -55,23 +56,14 @@ | PCConn (ConnBuilder a) -- | Configuration for the session manager-data SessionCfg+data SessionCfg a = SessionCfg { sc_cookieName :: T.Text , sc_sessionTTL :: NominalDiffTime , sc_sessionIdEntropy :: Int+ , sc_emptySession :: a } --- | Assign the current session roles/permission, eg. admin or user-type UserRights = T.Text---- | Describes why access was denied to a user-data NoAccessReason- = NotEnoughRights- | NotLoggedIn- | NoSession- deriving (Show, Eq, Read, Enum)- data ConnectionPool conn = DataPool (Pool conn) | ConduitPool (CP.Pool conn)@@ -105,10 +97,8 @@ data SessionManager a = SessionManager- { sm_loadSession :: SessionId -> IO (Maybe (Session a))- , sm_sessionFromCookie :: (SpockError e, MonadIO m)- => ActionT e m (Maybe (Session a))- , sm_createCookieSession :: (SpockError e, MonadIO m) => a -> ActionT e m ()- , sm_newSession :: a -> IO (Session a)- , sm_deleteSession :: SessionId -> IO ()+ { sm_readSession :: (SpockError e, MonadIO m) => ActionT e m a+ , sm_writeSession :: (SpockError e, MonadIO m) => a -> ActionT e m ()+ , sm_modifySession :: (SpockError e, MonadIO m) => (a -> a) -> ActionT e m ()+ , sm_middleware :: Middleware }