Spock 0.4.0.1 → 0.4.1.0
raw patch · 5 files changed
+117/−62 lines, 5 files
Files
- Spock.cabal +1/−1
- Web/Spock.hs +66/−32
- Web/Spock/Monad.hs +1/−1
- Web/Spock/SessionManager.hs +31/−28
- Web/Spock/Types.hs +18/−0
Spock.cabal view
@@ -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
Web/Spock.hs view
@@ -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
Web/Spock/Monad.hs view
@@ -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
Web/Spock/SessionManager.hs view
@@ -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
Web/Spock/Types.hs view
@@ -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