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.3.2 +Version: 0.3.2.1 Author: Athan Clark Maintainer: Athan Clark License: BSD3 @@ -122,6 +122,7 @@ , wai , wai-extra , http-types + , http-media , mtl , transformers , semigroups @@ -135,7 +136,7 @@ , attoparsec , regex-compat , pred-trie >= 0.1 - , poly-arity >= 0.0.3 + , poly-arity >= 0.0.4 Test-Suite spec Type: exitcode-stdio-1.0 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 @@ -36,6 +36,7 @@ import Web.Routes.Nested.VerbListener import Network.HTTP.Types +import Network.HTTP.Media import Network.Wai import Control.Applicative @@ -102,11 +103,8 @@ HandlerT $ tell (singleton ts vl, mempty) handleLit ts vl (Just cs) = do ((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs + HandlerT $ tell (extrude ts $ Rooted (Just vl) ctrie, mempty) - HandlerT $ tell $ let - child = extrude ts $ Rooted (Just vl) ctrie - in - (child, mempty) -- | For routes ending with a parser. handleParse :: ( Monad m @@ -132,11 +130,7 @@ 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) + HandlerT $ tell (extrude ts $ Rooted (Just vl) ctrie, mempty) notFoundLit :: ( Monad m @@ -162,11 +156,7 @@ 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) + HandlerT $ tell (mempty, extrude ts $ Rooted (Just vl) ctrie) notFoundParse :: ( Monad m @@ -192,11 +182,7 @@ 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) + HandlerT $ tell (mempty, extrude ts $ Rooted (Just vl) ctrie) -- | Turns a @HandlerT@ into a Wai @Application@ @@ -208,6 +194,7 @@ -> Request -> (Response -> IO ResponseReceived) -> m ResponseReceived route h req respond = do + -- liftIO $ print $ (return . parseContentType) =<< (Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req) (rtrie, nftrie) <- execWriterT $ runHandler h let mMethod = httpMethodToMSym $ requestMethod req mFileext = case pathInfo req of @@ -217,44 +204,45 @@ notFoundBasic <- handleNotFound (Just Html) Get meitherNotFound - case mMethod of - Just v -> do - menf <- handleNotFound mFileext v meitherNotFound + maybe (liftIO $ respond404 notFoundBasic) (\v -> do + menf <- handleNotFound mFileext v meitherNotFound + let cleanedPathInfo = applyToLast trimFileExt $ pathInfo req + fail = liftIO $ respond404 menf - 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 + maybe (case pathInfo req of + [] -> fail + _ -> case trimFileExt $ last $ pathInfo req of + "index" -> maybe fail + (\eitherM -> continue mFileext v eitherM menf) + (P.lookup (init $ pathInfo req) rtrie) + _ -> fail + ) (\eitherM -> continue mFileext v eitherM menf) + (P.lookup cleanedPathInfo rtrie) + ) mMethod where + onJustM :: Monad m => (a -> m (Maybe b)) -> Maybe a -> m (Maybe b) + onJustM f mx = maybe (return Nothing) f mx + + 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 + handleNotFound mf v meitherNotFound = + let handleEither (Left litmonad) = + onJustM (\f -> do + vmapLit <- execWriterT $ runVerbListenerT litmonad + onJustM (\(_, femonad) -> do + femap <- execWriterT $ runFileExtListenerT femonad + return $ lookupMin f $ unFileExts femap) $ + M.lookup v $ unVerbs vmapLit) mf + handleEither (Right predmonad) = do + vmapPred <- execWriterT $ runVerbListenerT predmonad + onJustM (\(_, r) -> return $ Just r) $ M.lookup v $ unVerbs vmapPred + in + onJustM handleEither meitherNotFound continue :: MonadIO m => @@ -264,43 +252,41 @@ -> 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 + Left litmonad -> maybe (liftIO $ respond404 mnfResp) (\f -> do + vmapLit <- execWriterT $ runVerbListenerT litmonad + continueLit f v (unVerbs vmapLit) mnfResp) + mf 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 + continueLit f v vmap mnfResp = + let fail = liftIO $ respond404 mnfResp in + maybe fail (\(mreqbodyf, femonad) -> do + femap <- execWriterT $ runFileExtListenerT femonad + maybe fail (\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 fail + _ -> fail) $ + lookupMin f $ unFileExts femap) $ M.lookup v vmap continuePred :: MonadIO m => @@ -308,8 +294,9 @@ -> 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) -> + continuePred v vmap mnfResp = + let fail = liftIO $ respond404 mnfResp in + maybe fail (\(mreqbodyf, r) -> case mreqbodyf of Nothing -> liftIO $ respond r Just (reqbf,Nothing) -> do @@ -318,13 +305,14 @@ 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 + KnownLength bl' -> + if bl' <= bl + then do body <- liftIO $ strictRequestBody req + (runReaderT $ reqbf) body + liftIO $ respond r + else fail + _ -> fail + ) $ M.lookup v vmap respond404 :: Maybe Response -> IO ResponseReceived @@ -336,6 +324,17 @@ 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 + + lookupProper :: FileExt -> M.Map FileExt a -> Maybe a + lookupProper k map = case M.lookup k map of + Nothing -> case M.lookup (feSequence k !! 0) map of + Nothing -> M.lookup (feSequence k !! 1) map + Just x -> Just x + Just x -> Just x + where + feSequence Html = [Text, Json] + feSequence Json = [Text, Html] + feSequence Text = [Json, Html] applyToLast :: (a -> a) -> [a] -> [a] applyToLast _ [] = []