module Web.Routes.Nested
( module Web.Routes.Nested.FileExtListener
, module Web.Routes.Nested.VerbListener
, module Web.Routes.Nested.Types
, HandlerT (..)
, EitherResponse
, handleLit
, handleParse
, notFoundLit
, notFoundParse
, route
) where
import Web.Routes.Nested.Types
import Web.Routes.Nested.FileExtListener
import Web.Routes.Nested.VerbListener
import Network.HTTP.Types
import Network.Wai
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Writer
import Control.Monad.Reader
import Data.Trie.Pred.Unified
import qualified Data.Trie.Pred.Unified as P
import qualified Data.Text as T
import qualified Data.Map.Lazy as M
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe)
import Data.Constraint
import Data.Function.Poly
newtype HandlerT z x m a = HandlerT
{ runHandler :: WriterT ( RUPTrie T.Text x
, RUPTrie T.Text x ) m a }
deriving (Functor)
deriving instance Applicative m => Applicative (HandlerT z x m)
deriving instance Monad m => Monad (HandlerT z x m)
deriving instance MonadIO m => MonadIO (HandlerT z x m)
instance MonadTrans (HandlerT z x) where
lift ma = HandlerT $ lift ma
type EitherResponse z m = Either (VerbListenerT z (FileExtListenerT Response m ()) m ())
(VerbListenerT z Response m ())
type family LastIsNothing (xs :: [Maybe *]) :: Constraint where
LastIsNothing '[] = ()
LastIsNothing ('Nothing ': '[]) = ()
LastIsNothing (x ': xs) = LastIsNothing xs
type family LastIsJust (xs :: [Maybe *]) :: Constraint where
LastIsJust (('Just x) ': '[]) = ()
LastIsJust (x ': xs) = LastIsJust xs
handleLit :: ( Monad m
, Functor m
, cleanxs ~ OnlyJusts xs
, HasResult childType (EitherResponse z m)
, ExpectArity cleanxs childType
, Singleton (UrlChunks xs)
childType
(RUPTrie T.Text result)
, Extrude (UrlChunks xs)
(RUPTrie T.Text childType)
(RUPTrie T.Text result)
, (ArityMinusTypeList childType cleanxs) ~ result
, childType ~ TypeListToArity cleanxs result
, LastIsNothing xs
) =>
UrlChunks xs
-> childType
-> Maybe (HandlerT z childType m ())
-> HandlerT z result m ()
handleLit ts vl Nothing =
HandlerT $ tell (singleton ts vl, mempty)
handleLit ts vl (Just cs) = do
((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs
HandlerT $ tell $ let
child = extrude ts $ Rooted (Just vl) ctrie
in
(child, mempty)
handleParse :: ( Monad m
, Functor m
, cleanxs ~ OnlyJusts xs
, HasResult childType (EitherResponse z m)
, ExpectArity cleanxs childType
, Singleton (UrlChunks xs)
childType
(RUPTrie T.Text result)
, Extrude (UrlChunks xs)
(RUPTrie T.Text childType)
(RUPTrie T.Text result)
, (ArityMinusTypeList childType cleanxs) ~ result
, childType ~ TypeListToArity cleanxs result
, LastIsJust xs
) =>
UrlChunks xs
-> childType
-> Maybe (HandlerT z childType m ())
-> HandlerT z result m ()
handleParse ts vl Nothing =
HandlerT $ tell (singleton ts vl, mempty)
handleParse ts vl (Just cs) = do
((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs
HandlerT $ tell $ let
child = extrude ts $ Rooted (Just vl) ctrie
in
(child, mempty)
notFoundLit :: ( Monad m
, Functor m
, cleanxs ~ OnlyJusts xs
, HasResult childType (EitherResponse z m)
, ExpectArity cleanxs childType
, Singleton (UrlChunks xs)
childType
(RUPTrie T.Text result)
, Extrude (UrlChunks xs)
(RUPTrie T.Text childType)
(RUPTrie T.Text result)
, (ArityMinusTypeList childType cleanxs) ~ result
, childType ~ TypeListToArity cleanxs result
, LastIsNothing xs
) =>
UrlChunks xs
-> childType
-> Maybe (HandlerT z childType m ())
-> HandlerT z result m ()
notFoundLit ts vl Nothing = do
HandlerT $ tell (mempty, singleton ts vl)
notFoundLit ts vl (Just cs) = do
((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs
HandlerT $ tell $ let
child = extrude ts $ Rooted (Just vl) ctrie
in
(mempty, child)
notFoundParse :: ( Monad m
, Functor m
, cleanxs ~ OnlyJusts xs
, HasResult childType (EitherResponse z m)
, ExpectArity cleanxs childType
, Singleton (UrlChunks xs)
childType
(RUPTrie T.Text result)
, Extrude (UrlChunks xs)
(RUPTrie T.Text childType)
(RUPTrie T.Text result)
, (ArityMinusTypeList childType cleanxs) ~ result
, childType ~ TypeListToArity cleanxs result
, LastIsJust xs
) =>
UrlChunks xs
-> childType
-> Maybe (HandlerT z childType m ())
-> HandlerT z result m ()
notFoundParse ts vl Nothing = do
HandlerT $ tell (mempty, singleton ts vl)
notFoundParse ts vl (Just cs) = do
((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs
HandlerT $ tell $ let
child = extrude ts $ Rooted (Just vl) ctrie
in
(mempty, child)
route :: ( Functor m
, Monad m
, MonadIO m
) =>
HandlerT z (EitherResponse z m) m a
-> Request
-> (Response -> IO ResponseReceived) -> m ResponseReceived
route h req respond = do
(rtrie, nftrie) <- execWriterT $ runHandler h
let mMethod = httpMethodToMSym $ requestMethod req
mFileext = case pathInfo req of
[] -> Just Html
xs -> toExt $ T.pack $ dropWhile (/= '.') $ T.unpack $ last xs
meitherNotFound = P.lookupNearestParent (pathInfo req) nftrie
notFoundBasic <- handleNotFound (Just Html) Get meitherNotFound
case mMethod of
Just v -> do
menf <- handleNotFound mFileext v meitherNotFound
let cleanedPathInfo = applyToLast trimFileExt $ pathInfo req
case P.lookup cleanedPathInfo rtrie of
Just eitherM -> continue mFileext v eitherM menf
Nothing -> case pathInfo req of
[] -> liftIO $ respond404 menf
_ -> case trimFileExt $ last $ pathInfo req of
"index" -> case P.lookup (init $ pathInfo req) rtrie of
Just eitherM -> continue mFileext v eitherM menf
Nothing -> liftIO $ respond404 menf
_ -> liftIO $ respond404 menf
_ -> liftIO $ respond404 notFoundBasic
where
handleNotFound :: MonadIO m =>
Maybe FileExt
-> Verb
-> Maybe (EitherResponse z m)
-> m (Maybe Response)
handleNotFound mf v meitherNotFound = case meitherNotFound of
Just (Left litmonad) -> case mf of
Nothing -> return Nothing
Just f -> do
vmapLit <- execWriterT $ runVerbListenerT litmonad
case M.lookup v (unVerbs vmapLit) of
Just (_, femonad) -> do
femap <- execWriterT $ runFileExtListenerT femonad
return $ lookupMin f $ unFileExts femap
Nothing -> return Nothing
Just (Right predmonad) -> do
vmapPred <- execWriterT $ runVerbListenerT predmonad
case M.lookup v (unVerbs vmapPred) of
Just (_, r) -> return $ Just r
Nothing -> return Nothing
Nothing -> return Nothing
continue :: MonadIO m =>
Maybe FileExt
-> Verb
-> EitherResponse z m
-> Maybe Response
-> m ResponseReceived
continue mf v eitherM mnfResp = case eitherM of
Left litmonad -> case mf of
Nothing -> liftIO $ respond404 mnfResp
Just f -> do
vmapLit <- execWriterT $ runVerbListenerT litmonad
continueLit f v (unVerbs vmapLit) mnfResp
Right predmonad -> do
vmapPred <- execWriterT $ runVerbListenerT predmonad
continuePred v (unVerbs vmapPred) mnfResp
continueLit :: MonadIO m =>
FileExt
-> Verb
-> M.Map Verb (Maybe (ReaderT BL.ByteString m z, Maybe BodyLength), FileExtListenerT Response m ())
-> Maybe Response
-> m ResponseReceived
continueLit f v vmap mnfResp = case M.lookup v vmap of
Just (mreqbodyf, femonad) -> do
femap <- execWriterT $ runFileExtListenerT femonad
case lookupMin f $ unFileExts femap of
Just r -> do
case mreqbodyf of
Nothing -> liftIO $ respond r
Just (reqbf,Nothing) -> do
body <- liftIO $ strictRequestBody req
(runReaderT $ reqbf) body
liftIO $ respond r
Just (reqbf,Just bl) -> do
case requestBodyLength req of
KnownLength bl' -> if bl' <= bl
then do body <- liftIO $ strictRequestBody req
(runReaderT $ reqbf) body
liftIO $ respond r
else liftIO $ respond404 mnfResp
_ -> liftIO $ respond404 mnfResp
Nothing -> liftIO $ respond404 mnfResp
Nothing -> liftIO $ respond404 mnfResp
continuePred :: MonadIO m =>
Verb
-> M.Map Verb (Maybe (ReaderT BL.ByteString m z, Maybe BodyLength), Response)
-> Maybe Response
-> m ResponseReceived
continuePred v vmap mnfResp = case M.lookup v vmap of
Just (mreqbodyf, r) ->
case mreqbodyf of
Nothing -> liftIO $ respond r
Just (reqbf,Nothing) -> do
body <- liftIO $ strictRequestBody req
(runReaderT $ reqbf) body
liftIO $ respond r
Just (reqbf,Just bl) -> do
case requestBodyLength req of
KnownLength bl' -> if bl' <= bl
then do body <- liftIO $ strictRequestBody req
(runReaderT $ reqbf) body
liftIO $ respond r
else liftIO $ respond404 mnfResp
_ -> liftIO $ respond404 mnfResp
Nothing -> liftIO $ respond404 mnfResp
respond404 :: Maybe Response -> IO ResponseReceived
respond404 mr = respond $ fromMaybe plain404 mr
plain404 :: Response
plain404 = responseLBS status404 [("Content-Type","text/plain")] "404"
lookupMin :: Ord k => k -> M.Map k a -> Maybe a
lookupMin k map | all (k <) (M.keys map) = M.lookup (minimum $ M.keys map) map
| otherwise = M.lookup k map
applyToLast :: (a -> a) -> [a] -> [a]
applyToLast _ [] = []
applyToLast f (x:[]) = f x : []
applyToLast f (x:xs) = x : applyToLast f xs
trimFileExt :: T.Text -> T.Text
trimFileExt s = if (T.unpack s) `endsWithAny` possibleExts
then T.pack $ takeWhile (/= '.') $ T.unpack s
else s
where
possibleExts = [".html",".htm",".txt",".json"]
endsWithAny s xs = (dropWhile (/= '.') s) `elem` xs
httpMethodToMSym :: Method -> Maybe Verb
httpMethodToMSym x | x == methodGet = Just Get
| x == methodPost = Just Post
| x == methodPut = Just Put
| x == methodDelete = Just Delete
| otherwise = Nothing