redHandlers-0.1: Network/HTTP/RedHandler/Handler.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.HTTP.RedHandler.Handler where
import Network.HTTP.RedHandler.Utils (low)
import Network.URI (uriPath)
import Text.XHtml.Strict
import Maybe (fromMaybe)
import Control.Monad (MonadPlus, mzero, mplus, msum)
import Control.Monad.Trans (lift)
import Control.Monad.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Reader
import Network.HTTP.RedHandler.HTTP_Fork.HTTP (RequestMethod(..), rqMethod, Response, rqURI, rqHeaders, rqBody)
import Network.HTTP.RedHandler.FileUtils (sendFileResponse)
import Network.HTTP.RedHandler.RequestContext
import Network.HTTP.RedHandler.Response
------------------------------------------------------------------
--------- MaybeT monad transformer instances and combinators -----
------------------------------------------------------------------
mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT f = MaybeT . f . runMaybeT
maybeToMonadPlus :: MonadPlus m => Maybe a -> m a
maybeToMonadPlus Nothing = mzero
maybeToMonadPlus (Just x) = return x
------------------------------------------------------------------
--------- RequestHandler monad transformer -----------------------
------------------------------------------------------------------
type IORqHandler = RqHandlerT IO
newtype RqHandlerT m a = RqHandlerT { unRqHandlerT :: ReaderT RequestContext (MaybeT m) a }
deriving (Functor, Monad, MonadIO, MonadReader RequestContext, MonadPlus) --, MonadTrans)
instance MonadTrans RqHandlerT where
lift = RqHandlerT . lift . lift
runRqHandlerT :: RqHandlerT m a -> RequestContext -> m (Maybe a)
runRqHandlerT han = runMaybeT . runReaderT (unRqHandlerT han)
mapRqHandlerT :: (m (Maybe a) -> n (Maybe b)) -> RqHandlerT m a -> RqHandlerT n b
mapRqHandlerT f = RqHandlerT . mapReaderT (mapMaybeT f) . unRqHandlerT
--------------------------------------------
--------- RqHandlerT combinators -----------
--------------------------------------------
notMe :: Monad m => RqHandlerT m a
notMe = mzero
anyOf :: Monad m => [RqHandlerT m a] -> RqHandlerT m a
anyOf = msum
ifReq :: Monad m => (RequestContext -> Bool) -> RqHandlerT m a -> RqHandlerT m a -> RqHandlerT m a
ifReq test thenh elseh = ask >>= \req -> if (test req) then thenh else elseh
underString :: Monad m => (String -> RqHandlerT m a) -> RqHandlerT m a
underString hanLambda = ask >>= \req -> case moveForwardDir req of
Nothing -> notMe
Just (req',d) -> local (\_->req') $ hanLambda d
under :: Monad m => String -> RqHandlerT m a -> RqHandlerT m a
under urlDirName han = underString (\s -> if s == low urlDirName then han else notMe)
underInteger :: Monad m => (Integer -> RqHandlerT m a) -> RqHandlerT m a
underInteger hanLambda = underString hanStrLambda
where
hanStrLambda s = case maybeReads s of
Nothing -> notMe
Just ix -> hanLambda ix
reprocessLastDir :: Monad m => RqHandlerT m a -> RqHandlerT m a
reprocessLastDir han = ask >>= \req -> case moveBackwardDir req of
Nothing -> notMe
Just (req',_) -> local (\_->req') han
underNoDir :: Monad m => RqHandlerT m a -> RqHandlerT m a
underNoDir = filterReq (null . dirs)
withDocName :: Monad m => String -> RqHandlerT m a -> RqHandlerT m a
withDocName urlDocName han = underNoDir $ filterReq ((==urlDocName) . docName) han
withDocNameInteger :: Monad m => (Integer -> RqHandlerT m a) -> RqHandlerT m a
withDocNameInteger lam = underNoDir $ (withParam $ maybeReads . docName) lam
withDocNameString :: Monad m => (String -> RqHandlerT m a) -> RqHandlerT m a
withDocNameString lam = underNoDir $ (withParam $ Just . docName) lam
modReq :: Monad m => (RequestContext -> RequestContext) -> RqHandlerT m a -> RqHandlerT m a
modReq = local
modResp :: Monad m => (a -> b) -> RqHandlerT m a -> RqHandlerT m b
modResp = fmap
-- more Request Handler combinators
filterReq :: Monad m => (RequestContext -> Bool) -> RqHandlerT m a -> RqHandlerT m a
filterReq test han = ifReq test han notMe
sat :: Monad m => (RequestContext->a) -> (a->Bool) -> RqHandlerT m b -> RqHandlerT m b
sat tr test = filterReq (test . tr)
ifMethod :: Monad m => RequestMethod -> RqHandlerT m a -> RqHandlerT m a
ifMethod method = filterReq (\req -> (rqMethod . originalRequest $ req) == method)
formatEq :: Monad m => String -> RqHandlerT m a -> RqHandlerT m a
formatEq fmt = filterReq (\req -> (format req) == fmt)
formatHtml :: Monad m => RqHandlerT m a -> RqHandlerT m a
formatHtml = formatEq "html"
ifGet, ifPost :: Monad m => RqHandlerT m a -> RqHandlerT m a
ifGet = ifMethod GET
ifPost = ifMethod POST
eq :: (Eq a, Monad m) => (RequestContext->a) -> a -> RqHandlerT m b -> RqHandlerT m b
eq tr val = sat tr (==val)
failWith :: Monad m => RqHandlerT m a -> RqHandlerT m a -> RqHandlerT m a
failWith failh handl = handl `mplus` failh
-----------------------------------------------------------------
-- Handlers related to IO (running an IO, file sytestem, debug) -
-----------------------------------------------------------------
getResponse :: Monad m => RqHandlerT m BasicRsp -> RequestContext -> m Response
getResponse han req = liftM maybeBasicRspToResponse (runRqHandlerT han req)
respWithStatic :: MonadIO m => String -> RqHandlerT m BasicRsp
respWithStatic filePath = fmap (uncurry fileRsp) $ liftIO (sendFileResponse filePath) >>= maybeToMonadPlus
-- mapDir performs a get, applying the URL as relative to the pathString
-- it checks if the pathString exist and then appends it to the URI, in case it fails returns nothing.
mapDir :: MonadIO m => String -> RqHandlerT m BasicRsp
mapDir dirPath = do
filePath <- fmap ((dirPath ++) . pendingURIPath) ask
liftIO $ putStrLn ("To send file: " ++ filePath)
-- FIXME: comment last line for deployment
respWithStatic filePath
printString :: String -> IORqHandler ()
printString s = liftIO (putStrLn s)
printFullReq :: IORqHandler ()
printFullReq = ask >>= liftIO . print
debug :: IORqHandler a -> IORqHandler a
debug rh = printString "--------" >> printFullReq >> rh
debugStr :: String -> IORqHandler a -> IORqHandler a
debugStr s rh = printString "--------" >> printString s >> printFullReq >> rh
printReq :: IORqHandler a -> IORqHandler a
printReq rh = ask >>= printString . showShortReq >> rh
where
showShortReq req = let o = originalRequest req
in (show $ rqMethod o) ++ " " ++ (show $ rqURI o)
-----------------------------------------------------
--------------------RequestContext-------------------
-----------------------------------------------------
withRequestDo :: Monad m => (RequestContext -> m a) -> RqHandlerT m a
withRequestDo rqlam = ask >>= lift . rqlam
withParam ::Monad m => (RequestContext-> Maybe a) -> (a-> RqHandlerT m b) -> RqHandlerT m b
withParam sel lam = ask >>= \req -> case sel req of
Nothing -> notMe
Just x -> lam x
maybeReads :: Read a => String -> Maybe a
maybeReads val = case reads val of
[] -> Nothing
(n,_):_ -> Just n
withQueryField :: Monad m => String -> (String-> RqHandlerT m a) -> RqHandlerT m a
withQueryField key = withParam $ (lookup key) . query
withQuery :: Monad m => ([(String,String)] -> RqHandlerT m a) -> RqHandlerT m a
withQuery = withParam $ (Just . query)
-- forms
withPostField :: Monad m => String -> (String -> RqHandlerT m a) -> RqHandlerT m a
withPostField key = withParam $ lookup key . postFields
withPostFields :: Monad m => ([(String,String)] -> RqHandlerT m a) -> RqHandlerT m a
withPostFields postFieldsLam = ask >>= postFieldsLam . postFields
withPostFieldFileName :: Monad m => String -> (Maybe String -> RqHandlerT m a) -> RqHandlerT m a
withPostFieldFileName field postFieldFileNameLam = ask >>= postFieldFileNameLam . postFieldFileName field
----------------------
-- examples ----------
----------------------
showReqHtml :: Monad m => RqHandlerT m Html
showReqHtml = fmap showReq ask
showReq :: RequestContext -> Html
showReq reqc =
header << thetitle << "showing original request"
+++ body << (
h2 << ("URI: " ++ show (rqURI req) ) +++
h2 << ("Req Method: " ++ show (rqMethod req) ) +++
h2 << ("Req Headers: ") +++
concatHtml(map (\hdr -> (h3 << show hdr)) (rqHeaders req)) +++
h2 << ("Req Body: " ++ show (rqBody req) ) +++
showRqContext reqc
)
where
showRqContext :: RequestContext -> Html
showRqContext reqc = h2 << ("Current request being processed: ") +++
h3 << ("Dirs: " ++ show (dirs reqc)) +++
h3 << ("Doc Name: " ++ docName reqc) +++
h3 << ("Format: " ++ format reqc) +++
h3 << ("Query: " ++ show (query reqc)) +++
h3 << ("Form body inputs:" ++ show (formInputs reqc))
req = originalRequest reqc