module Web.Spock
(
spock, authed, runQuery, getState, Http.StdMethod(..), SpockM
, authedUser, unauthCurrent, StorageLayer (..)
, middleware, get, post, put, delete, patch, addroute, matchAny, notFound
, request, reqHeader, body, param, params, jsonData, files
, status, addHeader, setHeader, redirect
, text, html, file, json, source, raw
, raise, rescue, next
)
where
import Web.Spock.SessionManager
import Web.Spock.Monad
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 Data.Text as T
import qualified Network.HTTP.Types as Http
type SpockM conn sess st a = ScottyT (WebStateM conn sess st) a
spock :: Int -> StorageLayer conn -> st -> SpockM conn sess st () -> IO ()
spock port storageLayer initialState defs =
do sessionMgr <- openSessionManager
connectionPool <- createPool (sl_createConn storageLayer) (sl_closeConn storageLayer) 5 (60*5) 5
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) -> ActionT (WebStateM conn sess st) ()
authedUser user getSessionId =
do mgr <- getSessMgr
(sm_createCookieSession mgr) (getSessionId user)
unauthCurrent :: ActionT (WebStateM 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 ()
authed :: Http.StdMethod -> [T.Text] -> RoutePattern
-> (conn -> sess -> IO (Maybe user))
-> (conn -> user -> [T.Text] -> IO Bool)
-> (user -> ActionT (WebStateM conn sess st) ())
-> SpockM conn sess st ()
authed reqTy requiredRights route loadUser checkRights 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
case mUser of
Just user ->
do isOk <- runQuery $ \conn -> checkRights conn 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