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
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
type IORqHandler = RqHandlerT IO
newtype RqHandlerT m a = RqHandlerT { unRqHandlerT :: ReaderT RequestContext (MaybeT m) a }
deriving (Functor, Monad, MonadIO, MonadReader RequestContext, MonadPlus)
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
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
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
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 :: MonadIO m => String -> RqHandlerT m BasicRsp
mapDir dirPath = do
filePath <- fmap ((dirPath ++) . pendingURIPath) ask
liftIO $ putStrLn ("To send file: " ++ filePath)
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)
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
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