{-# 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