diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,5 +1,5 @@ name: Spock -version: 0.4.0.1 +version: 0.4.1.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 Homepage: https://github.com/agrafix/Spock diff --git a/Web/Spock.hs b/Web/Spock.hs --- a/Web/Spock.hs +++ b/Web/Spock.hs @@ -8,14 +8,19 @@ spock, SpockM, SpockAction -- * Database , runQuery, PoolOrConn (..), ConnBuilder (..), PoolCfg (..) - -- * Routing - , authed, get, post, put, delete, patch, addroute, Http.StdMethod (..) - -- * Cookies - , setCookie, setCookie', getCookie - -- * Sessions - , authedUser, unauthCurrent -- * State , getState + -- * Authorization + , SessionCfg (..) + , authedUser, unauthCurrent + -- * Authorized Routing + , NoAccessReason (..), UserRights + , NoAccessHandler, LoadUserFun, CheckRightsFun + , authed + -- * General Routing + , get, post, put, delete, patch, addroute, Http.StdMethod (..) + -- * Cookies + , setCookie, setCookie', getCookie -- * Other reexports from scotty , middleware, matchAny, notFound , request, reqHeader, body, param, params, jsonData, files @@ -36,23 +41,23 @@ import Control.Monad.Trans.Resource import Data.Pool import Web.Scotty.Trans -import qualified Data.Text as T import qualified Network.HTTP.Types as Http -- | 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 -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO () -spock port poolOrConn initialState defs = - do sessionMgr <- openSessionManager - connectionPool <- case poolOrConn of - PCPool p -> - return p - PCConn cb -> - let pc = cb_poolConfiguration cb - in createPool (cb_createConn cb) (cb_destroyConn cb) - (pc_stripes pc) (pc_keepOpenTime pc) - (pc_resPerStripe pc) +spock :: Int -> SessionCfg -> PoolOrConn conn -> st -> SpockM conn sess st () -> IO () +spock port sessionCfg poolOrConn initialState defs = + do sessionMgr <- openSessionManager sessionCfg + connectionPool <- + case poolOrConn of + PCPool p -> + return p + PCConn cb -> + let pc = cb_poolConfiguration cb + in createPool (cb_createConn cb) (cb_destroyConn cb) + (pc_stripes pc) (pc_keepOpenTime pc) + (pc_resPerStripe pc) let internalState = WebState { web_dbConn = connectionPool @@ -81,30 +86,59 @@ 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 + -- | 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 loadUser and checkRights all the time -authed :: Http.StdMethod -> [T.Text] -> RoutePattern - -> (conn -> sess -> IO (Maybe user)) - -> (conn -> user -> [T.Text] -> IO Bool) +-- 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 reqTy requiredRights route loadUser checkRights action = +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 <- runQuery $ \conn -> loadUser conn sval + do mUser <- loadUser sval case mUser of Just user -> - do isOk <- runQuery $ \conn -> checkRights conn user requiredRights + do isOk <- checkRights user requiredRights if isOk then action user - else http403 "No rights to see this!" - Nothing -> http403 "Not logged in" - Nothing -> http403 "Not logged in" - where - http403 msg = - do status Http.status403 - text msg + else noAccessHandler NotEnoughRights + Nothing -> + noAccessHandler NotLoggedIn + Nothing -> + noAccessHandler NoSession diff --git a/Web/Spock/Monad.hs b/Web/Spock/Monad.hs --- a/Web/Spock/Monad.hs +++ b/Web/Spock/Monad.hs @@ -27,7 +27,7 @@ do pool <- asks web_dbConn liftIO $ withResource pool query --- | Read the application's state. If you wish to have immutable state, you could +-- | Read the application's state. If you wish to have mutable state, you could -- use a 'TVar' from the STM packge. getState :: MonadTrans t => t (WebStateM conn sess st) st getState = webM $ asks web_state diff --git a/Web/Spock/SessionManager.hs b/Web/Spock/SessionManager.hs --- a/Web/Spock/SessionManager.hs +++ b/Web/Spock/SessionManager.hs @@ -18,55 +18,58 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text.Encoding as T -_COOKIE_NAME_ = "asession" -sessionTTL = 10 * 60 * 60 -sessionIdEntropy = 12 :: Int - -openSessionManager :: IO (SessionManager a) -openSessionManager = +openSessionManager :: SessionCfg -> IO (SessionManager a) +openSessionManager cfg = do cacheHM <- atomically $ newTVar HM.empty return $ SessionManager - { sm_loadSession = loadSessionImpl cacheHM - , sm_sessionFromCookie = sessionFromCookieImpl cacheHM - , sm_createCookieSession = createCookieSessionImpl cacheHM - , sm_newSession = newSessionImpl cacheHM + { sm_loadSession = loadSessionImpl cfg cacheHM + , sm_sessionFromCookie = sessionFromCookieImpl cfg cacheHM + , sm_createCookieSession = createCookieSessionImpl cfg cacheHM + , sm_newSession = newSessionImpl cfg cacheHM , sm_deleteSession = deleteSessionImpl cacheHM } -createCookieSessionImpl :: (SpockError e, MonadIO m) => UserSessions a -> a +createCookieSessionImpl :: (SpockError e, MonadIO m) + => SessionCfg + -> UserSessions a + -> a -> ActionT e m () -createCookieSessionImpl sessRef val = - do sess <- liftIO $ newSessionImpl sessRef val - setCookie' _COOKIE_NAME_ (sess_id sess) (sess_validUntil sess) +createCookieSessionImpl sessCfg sessRef val = + do sess <- liftIO $ newSessionImpl sessCfg sessRef val + setCookie' (sc_cookieName sessCfg) (sess_id sess) (sess_validUntil sess) -newSessionImpl :: UserSessions a +newSessionImpl :: SessionCfg + -> UserSessions a -> a -> IO (Session a) -newSessionImpl sessionRef content = - do sess <- createSession content +newSessionImpl sessCfg sessionRef content = + do sess <- createSession sessCfg content atomically $ modifyTVar sessionRef (\hm -> HM.insert (sess_id sess) sess hm) return sess -sessionFromCookieImpl :: (SpockError e, MonadIO m) => UserSessions a +sessionFromCookieImpl :: (SpockError e, MonadIO m) + => SessionCfg + -> UserSessions a -> ActionT e m (Maybe (Session a)) -sessionFromCookieImpl sessionRef = - do mSid <- getCookie _COOKIE_NAME_ +sessionFromCookieImpl sessCfg sessionRef = + do mSid <- getCookie (sc_cookieName sessCfg) case mSid of Just sid -> - liftIO $ loadSessionImpl sessionRef sid + liftIO $ loadSessionImpl sessCfg sessionRef sid Nothing -> return Nothing -loadSessionImpl :: UserSessions a +loadSessionImpl :: SessionCfg + -> UserSessions a -> SessionId -> IO (Maybe (Session a)) -loadSessionImpl sessionRef sid = +loadSessionImpl sessCfg sessionRef sid = do sessHM <- atomically $ readTVar sessionRef now <- getCurrentTime case HM.lookup sid sessHM of Just sess -> - do if addUTCTime sessionTTL (sess_validUntil sess) > now + do if addUTCTime (sc_sessionTTL sessCfg) (sess_validUntil sess) > now then return $ Just sess else do deleteSessionImpl sessionRef sid return Nothing @@ -80,13 +83,13 @@ do atomically $ modifyTVar sessionRef (\hm -> HM.delete sid hm) return () -createSession :: a -> IO (Session a) -createSession content = +createSession :: SessionCfg -> a -> IO (Session a) +createSession sessCfg content = do gen <- g let sid = T.decodeUtf8 $ B64.encode $ BSC.pack $ - take sessionIdEntropy $ randoms gen + take (sc_sessionIdEntropy sessCfg) $ randoms gen now <- getCurrentTime - let validUntil = addUTCTime sessionTTL now + let validUntil = addUTCTime (sc_sessionTTL sessCfg) now return (Session sid validUntil content) where g = newStdGen :: IO StdGen diff --git a/Web/Spock/Types.hs b/Web/Spock/Types.hs --- a/Web/Spock/Types.hs +++ b/Web/Spock/Types.hs @@ -49,6 +49,24 @@ = PCPool (Pool a) | PCConn (ConnBuilder a) +-- | Configuration for the session manager +data SessionCfg + = SessionCfg + { sc_cookieName :: T.Text + , sc_sessionTTL :: NominalDiffTime + , sc_sessionIdEntropy :: Int + } + +-- | 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 WebState conn sess st = WebState { web_dbConn :: Pool conn