WebHandler.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}

module Factis.Haskoon.HttpSpec.WebHandler
    (ReqHandler(..), ReqHandlerT(..), ReqHandlerState(..)
    ,runWebReq, runWebReqHandlerT, runReqHandlerT, runIOReqHandlerT, match)
where

----------------------------------------
-- STDLIB
----------------------------------------
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)

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import Factis.Haskoon.Web (Web(..),WebIO,webBadRequest)
import Factis.Haskoon.WebTrans (WebTrans(..), liftWebRec)

----------------------------------------
-- LOCAL
----------------------------------------
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