module Web.Spock
(
spock, SpockM, SpockAction
, PoolOrConn (..), ConnBuilder (..), PoolCfg (..)
, HasSpock (..)
, SessionCfg (..)
, authedUser, unauthCurrent
, NoAccessReason (..), UserRights
, NoAccessHandler, LoadUserFun, CheckRightsFun
, authed
, get, post, put, delete, patch, addroute, Http.StdMethod (..)
, setCookie, setCookie', getCookie
, middleware, matchAny, notFound
, request, reqHeader, body, param, params, jsonData, files
, status, addHeader, setHeader, redirect
, text, html, file, json, source, raw
, raise, rescue, next
, getSpockHeart, runSpockIO, WebStateM, WebState
)
where
import Web.Spock.SessionManager
import Web.Spock.Monad
import Web.Spock.Types
import Web.Spock.Cookie
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Resource
import Data.Pool
import Web.Scotty.Trans
import qualified Network.HTTP.Types as Http
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
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 defs
authedUser :: user -> (user -> sess) -> SpockAction conn sess st ()
authedUser user getSessionId =
do mgr <- getSessMgr
(sm_createCookieSession mgr) (getSessionId user)
unauthCurrent :: SpockAction conn sess st ()
unauthCurrent =
do mgr <- getSessMgr
mSess <- sm_sessionFromCookie mgr
case mSess of
Just sess -> liftIO $ (sm_deleteSession mgr) (sess_id sess)
Nothing -> return ()
type NoAccessHandler conn sess st =
NoAccessReason -> SpockAction conn sess st ()
type LoadUserFun conn sess st user =
sess -> SpockAction conn sess st (Maybe user)
type CheckRightsFun conn sess st user =
user -> [UserRights] -> SpockAction conn sess st Bool
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