diff --git a/nested-routes.cabal b/nested-routes.cabal --- a/nested-routes.cabal +++ b/nested-routes.cabal @@ -1,5 +1,5 @@ Name: nested-routes -Version: 0.1 +Version: 0.1.1 Author: Athan Clark Maintainer: Athan Clark License: BSD3 @@ -24,7 +24,7 @@ , transformers , semigroups , containers - , pseudo-trie >= 0.0.4.2 + , pseudo-trie >= 0.0.4.3 , text , aeson , blaze-html diff --git a/src/Web/Routes/Nested.hs b/src/Web/Routes/Nested.hs --- a/src/Web/Routes/Nested.hs +++ b/src/Web/Routes/Nested.hs @@ -9,7 +9,9 @@ module Web.Routes.Nested ( module Web.Routes.Nested.FileExtListener , module Web.Routes.Nested.VerbListener + , HandlerT (..) , handle + , notFound , route ) where @@ -36,10 +38,12 @@ import qualified Data.Text as T import qualified Data.Map.Lazy as M import qualified Data.ByteString.Lazy as BL +import Data.Maybe (fromMaybe) newtype HandlerT z m a = HandlerT - { runHandler :: WriterT (MergeRooted T.Text (Verbs z m Response)) m a } + { runHandler :: WriterT ( MergeRooted T.Text (Verbs z m Response) + , MergeRooted T.Text (FileExts Response) ) m a } deriving (Functor) deriving instance Applicative m => Applicative (HandlerT z m) @@ -51,75 +55,95 @@ -- | Add a path to the list of routes handle :: Monad m => - [T.Text] -- ^ Input path, separated by slashes + [T.Text] -- ^ Input path, separated by slashes -> VerbListenerT z Response m () -- ^ HTTP Method-oriented monad - -> [HandlerT z m ()] -- ^ Child paths + -> [HandlerT z m ()] -- ^ Child paths -> HandlerT z m () handle ts vl [] = do vfrs <- lift $ execWriterT $ runVerbListenerT vl HandlerT $ tell $ case ts of - [] -> MergeRooted $ Rooted (Just vfrs) [] - _ -> MergeRooted $ Rooted Nothing [Rest (NE.fromList ts) vfrs] + [] -> (MergeRooted $ Rooted (Just vfrs) [], mempty) + _ -> (MergeRooted $ Rooted Nothing [Rest (NE.fromList ts) vfrs], mempty) handle ts vl cs = do vfrs <- lift $ execWriterT $ runVerbListenerT vl - child <- lift $ foldM (\acc c -> (acc <>) <$> (execWriterT $ runHandler c)) mempty cs + (child,_) <- lift $ foldM (\acc c -> (acc <>) <$> (execWriterT $ runHandler c)) mempty cs HandlerT $ tell $ case ts of [] -> case unMergeRooted child of - Rooted _ xs -> MergeRooted $ Rooted (Just vfrs) xs + Rooted _ xs -> (MergeRooted $ Rooted (Just vfrs) xs, mempty) _ -> let child' = push (unMergeRooted child) $ NE.fromList ts in - MergeRooted $ Rooted Nothing [P.assign (NE.fromList ts) (Just vfrs) child'] + (MergeRooted $ Rooted Nothing [P.assign (NE.fromList ts) (Just vfrs) child'], mempty) +notFound :: Monad m => + [T.Text] + -> FileExtListenerT Response m () + -> HandlerT z m () +notFound ts flistener = do + (fes :: FileExts Response) <- lift $ execWriterT $ runFileExtListenerT flistener + HandlerT $ tell $ + case ts of + [] -> (mempty, MergeRooted $ Rooted (Just fes) []) + _ -> (mempty, MergeRooted $ Rooted Nothing [Rest (NE.fromList ts) fes]) + + -- | Turns a @HandlerT@ into a Wai @Application@ route :: (Functor m, Monad m, MonadIO m) => - Response -- ^ Response to give when not found in the router - -> HandlerT z m a -- ^ Assembled @handle@ calls + HandlerT z m a -- ^ Assembled @handle@ calls -> Request - -> (Response -> m b) -> m b -route notFound h req respond = do - trie <- unMergeRooted <$> (execWriterT $ runHandler h) - let mMethod = httpMethodToMSym $ requestMethod req - mFileext = case pathInfo req of - [] -> Just Html - xs -> possibleExts $ getFileExt $ last xs + -> (Response -> IO ResponseReceived) -> m ResponseReceived +route h req respond = do + (rtrie, festrie) <- execWriterT $ runHandler h + let trie = unMergeRooted rtrie + notFoundTrie = unMergeRooted festrie + mMethod = httpMethodToMSym $ requestMethod req + mFileext = case pathInfo req of + [] -> Just Html + xs -> possibleExts $ getFileExt $ last xs + mNotFoundMap :: Maybe (M.Map FileExt Response) + mNotFoundMap = (return . unFileExts) =<< R.lookupNearestParent (pathInfo req) notFoundTrie case (mFileext, mMethod) of - (Just f, Just v) -> let cleanedPathInfo = applyToLast trimFileExt $ pathInfo req in + (Just f, Just v) -> let cleanedPathInfo = applyToLast trimFileExt $ pathInfo req + in case R.lookup cleanedPathInfo trie of - Just vmap -> continue f v vmap + Just vmap -> continue f v vmap mNotFoundMap Nothing -> case trimFileExt $ last $ pathInfo req of "index" -> case R.lookup (init $ pathInfo req) trie of - Just vmap -> continue f v vmap - Nothing -> respond notFound - _ -> respond notFound - _ -> respond notFound + Just vmap -> continue f v vmap mNotFoundMap + Nothing -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f + _ -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f + _ -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin Html where - continue f v vmap = case M.lookup v $ unVerbs vmap of + continue :: MonadIO m => FileExt -> Verb -> Verbs z m Response -> Maybe (M.Map FileExt Response) -> m ResponseReceived + continue f v vmap mNotFoundMap = case M.lookup v $ unVerbs vmap of Just (mreqbodyf,femap) -> case lookupMin f $ unFileExts femap of Just r -> do case mreqbodyf of - Nothing -> respond r + Nothing -> liftIO $ respond r Just (reqbf,Nothing) -> do body <- liftIO $ strictRequestBody req (runReaderT $ reqbf) body - respond r + 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 - respond r - else respond notFound - _ -> respond notFound - Nothing -> respond notFound - Nothing -> respond notFound + liftIO $ respond r + else liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f + _ -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f + Nothing -> liftIO $ respond $ fromMaybe plain404 $ mNotFoundMap >>= lookupMin f + Nothing -> liftIO $ respond $ fromMaybe plain404 $ lookupMin f =<< mNotFoundMap + 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