nested-routes 0.3.2 → 0.3.2.1

raw patch · 2 files changed

+87/−87 lines, 2 filesdep +http-mediadep ~poly-arityPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-media

Dependency ranges changed: poly-arity

API changes (from Hackage documentation)

Files

• nested-routes.cabal +3/−2
• src/Web/Routes/Nested.hs +84/−85

@@ -1,5 +1,5 @@ Name:                   nested-routes-Version:                0.3.2+Version:                0.3.2.1 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> 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

@@ -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 _ [] = []