diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -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 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 diff --git a/Web/Spock.hs b/Web/Spock.hs --- a/Web/Spock.hs +++ b/Web/Spock.hs @@ -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 diff --git a/Web/Spock/Cookie.hs b/Web/Spock/Cookie.hs --- a/Web/Spock/Cookie.hs +++ b/Web/Spock/Cookie.hs @@ -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 + , ";" + ] diff --git a/Web/Spock/SessionManager.hs b/Web/Spock/SessionManager.hs --- a/Web/Spock/SessionManager.hs +++ b/Web/Spock/SessionManager.hs @@ -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 $ diff --git a/Web/Spock/Types.hs b/Web/Spock/Types.hs --- a/Web/Spock/Types.hs +++ b/Web/Spock/Types.hs @@ -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 }