module Factis.Haskoon.HttpSpec.WebHandler
(ReqHandler(..), ReqHandlerT(..), ReqHandlerState(..)
,runWebReq, runWebReqHandlerT, runReqHandlerT, runIOReqHandlerT, match)
where
import Control.Monad (liftM)
import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
import Control.Monad.Error (MonadError(..), ErrorT(..))
import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)
import Factis.Haskoon.Web (Web(..),WebIO,webBadRequest)
import Factis.Haskoon.WebTrans (WebTrans(..), liftWebRec)
import Data.HttpSpec (WebExc(..),WebComm(..),WebIn(..),WebErr(..))
import Data.HttpSpec.HttpTypes (ReqIn(..),ReqOut(..),ResIn(..),ResOut(..)
,urlMatchPrefix')
import Factis.Haskoon.HttpSpec.SendRecv (getReqIn, sendResOut, sendReqOut)
class MonadError WebExc m => ReqHandler m where
sendReq :: ReqOut -> m ResIn
data ReqHandlerState m
= ReqHandlerState
{ rhst_sendReqOut :: ReqOut -> m (Either String ResIn)
}
newtype ReqHandlerT m a
= ReqHandlerT
{ unReqHandlerT :: ReaderT (ReqHandlerState m) (ErrorT WebExc m) a }
deriving (Monad)
instance Monad m => MonadError WebExc (ReqHandlerT m) where
throwError err = ReqHandlerT (throwError err)
catchError (ReqHandlerT action') handler =
ReqHandlerT (catchError action' handler')
where handler' err = let ReqHandlerT result = handler err in result
instance MonadIO m => MonadIO (ReqHandlerT m) where
liftIO m = ReqHandlerT (liftIO m)
instance MonadTrans ReqHandlerT where
lift m = ReqHandlerT (lift (lift m))
instance WebTrans ReqHandlerT where
liftWeb = ReqHandlerT . lift . lift
liftWebFun f cont =
ReqHandlerT $
do st <- ask
res <- lift (lift (f (runReqHandlerT cont st)))
case res of
Left msg -> lift (throwError msg)
Right x -> return x
instance Web m => Web (ReqHandlerT m) where
type WebRes (ReqHandlerT m) = WebRes m
webRec = liftWebRec (liftM id) webRec
liftRdr :: ReaderT (ReqHandlerState m) (ErrorT WebExc m) a -> ReqHandlerT m a
liftRdr rdr = ReqHandlerT rdr
instance MonadIO m => ReqHandler (ReqHandlerT m) where
sendReq rout =
do sro <- liftRdr (asks rhst_sendReqOut)
res <- lift (sro rout)
case res of
Left err -> fail err
Right result -> return result
runReqHandlerT :: Monad m =>
ReqHandlerT m a
-> ReqHandlerState m
-> m (Either WebExc a)
runReqHandlerT rh st = runErrorT $ flip runReaderT st $ unReqHandlerT rh
runWebReqHandlerT :: WebIO m => ReqHandlerT m a -> m (Either WebExc a)
runWebReqHandlerT = runIOReqHandlerT
runIOReqHandlerT :: MonadIO m => ReqHandlerT m a -> m (Either WebExc a)
runIOReqHandlerT = flip runReqHandlerT rhState
where rhState = ReqHandlerState sendReqOut
runWebReq :: WebIO m => (ReqIn -> ReqHandlerT m ResOut) -> m (WebRes m)
runWebReq handler =
do reqIn <- getReqIn
case urlMatchPrefix' (reqIn_progUrl reqIn) (reqIn_fullUrl reqIn) of
Just url ->
do let reqIn' = reqIn { reqIn_fullUrl = url }
res <- runWebReqHandlerT (handler reqIn')
case res of
Left err -> webBadRequest (show err)
Right resOut -> sendResOut resOut
Nothing -> webBadRequest $ "progUrl has to be prefix of fullUrl!"
match :: MonadError WebExc m => [ReqIn -> m ResOut] -> ReqIn -> m ResOut
match [] reqIn = throwError (WebExc comm err)
where err = WebErrNoMatch reqIn
comm = Just $ WebCommIn (WebIn (Just reqIn) Nothing)
match (f:fs) reqIn = catchError (f reqIn) handler
where cont = match fs reqIn
handler exc@(WebExc _ err) =
case err of
WebErrNoMatch {} -> cont
WebErrInvalidUrl {} -> cont
WebErrInvalidMethod {} -> cont
_ -> throwError exc