{-# LANGUAGE DeriveFunctor , GADTs , GeneralizedNewtypeDeriving , ScopedTypeVariables , StandaloneDeriving , TypeOperators , OverloadedStrings , DataKinds , TupleSections , FlexibleContexts , ConstraintKinds , DataKinds , KindSignatures , TypeFamilies , RankNTypes , PolyKinds , UndecidableInstances #-} 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 -- | For routes ending with a literal. 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 -- ^ Path to match against -> childType -- ^ Possibly a function, ending in @EitherResponse z m@ -> Maybe (HandlerT z childType m ()) -- ^ Potential child routes -> 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) -- | For routes ending with a parser. 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) -- | Turns a @HandlerT@ into a Wai @Application@ route :: ( Functor m , Monad m , MonadIO m ) => HandlerT z (EitherResponse z m) m a -- ^ Assembled @handle@ calls -> 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 -- file extension parse failed 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