nested-routes 9.0.0 → 9.0.0.1

raw patch · 4 files changed

+101/−92 lines, 4 filesdep +waidep ~wai-middleware-content-typedep ~wai-middleware-verbsdep ~wai-transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: wai

Dependency ranges changed: wai-middleware-content-type, wai-middleware-verbs, wai-transformers

API changes (from Hackage documentation)

Files

• nested-routes.cabal +10/−8
• src/Web/Routes/Nested.hs +74/−73
• src/Web/Routes/Nested/Types.hs +15/−10
• test/Web/Routes/NestedSpec/Basic.hs +2/−1

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c01d97006f99cd2296688bd70d1bff61663c843911d5c92a8484e2e578934d31+-- hash: 23396eb133d1c0b4eabee7dbb44fc9b6739eb73776e937055a72d9bd86144294  name:           nested-routes-version:        9.0.0+version:        9.0.0.1 synopsis:       Declarative, compositional Wai responses description:    Please see the README on Github at <https://git.localcooking.com/tooling/pred-trie#readme> category:       Web@@ -46,9 +46,10 @@     , text     , tries >=0.0.5     , unordered-containers-    , wai-middleware-content-type >=0.6.0-    , wai-middleware-verbs >=0.3.2-    , wai-transformers >=0.0.7+    , wai >=3.2.1+    , wai-middleware-content-type >=0.6.1.1+    , wai-middleware-verbs >=0.4.0.1+    , wai-transformers >=0.1.0   default-language: Haskell2010  test-suite spec@@ -83,7 +84,8 @@     , text     , tries >=0.0.5     , unordered-containers-    , wai-middleware-content-type >=0.6.0-    , wai-middleware-verbs >=0.3.2-    , wai-transformers >=0.0.7+    , wai >=3.2.1+    , wai-middleware-content-type >=0.6.1.1+    , wai-middleware-verbs >=0.4.0.1+    , wai-transformers >=0.1.0   default-language: Haskell2010

@@ -79,7 +79,8 @@ import           Web.Routes.Nested.Match import           Web.Routes.Nested.Types            (RouterT, execRouterT, Tries (..), ExtrudeSoundly) import           Web.Routes.Nested.Types-import           Network.Wai.Trans                  (MiddlewareT, Request, pathInfo)+import           Network.Wai                        (Request, pathInfo)+import           Network.Wai.Trans                  (MiddlewareT) import           Network.Wai.Middleware.Verbs import           Network.Wai.Middleware.ContentType hiding (responseStatus, responseHeaders, responseData) @@ -134,11 +135,11 @@ --   Generally, if the routes you are building get grouped --   by a predicate with 'matchGroup', --   then we would need another level of arity /before/ the @Double@.-match :: ( Monad m-         , Match xs' xs childContent resultContent-         ) => UrlChunks xs -- ^ Predicative path to match against-           -> childContent -- ^ The response to send-           -> RouterT resultContent sec m ()+match :: Monad m+      => Match xs' xs childContent resultContent+      => UrlChunks xs -- ^ Predicative path to match against+      -> childContent -- ^ The response to send+      -> RouterT resultContent sec m () match !ts !vl =   tell' $ Tries (singleton ts vl)                 mempty@@ -148,9 +149,9 @@ {-# INLINEABLE match #-}  -- | Create a handle for the /current/ route - an alias for @\h -> match o_ h@.-matchHere :: ( Monad m-             ) => childContent -- ^ The response to send-               -> RouterT childContent sec m ()+matchHere :: Monad m+          => childContent -- ^ The response to send+          -> RouterT childContent sec m () matchHere = match origin_  {-# INLINEABLE matchHere #-}@@ -159,9 +160,9 @@ -- | Match against any route, as a last resort against all failing matches - --   use this for a catch-all at some level in their routes, something --   like a @not-found 404@ page is useful.-matchAny :: ( Monad m-            ) => childContent -- ^ The response to send-              -> RouterT childContent sec m ()+matchAny :: Monad m+         => childContent -- ^ The response to send+         -> RouterT childContent sec m () matchAny !vl =   tell' $ Tries mempty                 (singleton origin_ vl)@@ -174,11 +175,11 @@ -- | Prepends a common route to an existing set of routes. You should note that --   doing this with a parser or regular expression will necessitate the existing --   arity in the handlers before the progam can compile.-matchGroup :: ( Monad m-              , MatchGroup xs' xs childContent resultContent childSec resultSec-              ) => UrlChunks xs -- ^ Predicative path to match against-                -> RouterT childContent  childSec  m () -- ^ Child routes to nest-                -> RouterT resultContent resultSec m ()+matchGroup :: Monad m+           => MatchGroup xs' xs childContent resultContent childSec resultSec+           => UrlChunks xs -- ^ Predicative path to match against+           -> RouterT childContent  childSec  m () -- ^ Child routes to nest+           -> RouterT resultContent resultSec m () matchGroup !ts cs = do   (Tries trieContent' trieNotFound trieSec) <- lift $ execRouterT cs   tell' $ Tries (extrude ts trieContent')@@ -205,14 +206,14 @@  -- | Sets the security role and error handler for a set of routes, optionally -- including its parent route.-auth :: ( Monad m-        ) => sec -- ^ Your security token-          -> AuthScope-          -> RouterT content (SecurityToken sec) m ()+auth :: Monad m+     => sec -- ^ Your security token+     -> AuthScope+     -> RouterT content (SecurityToken sec) m () auth !token !scope =-  tell' $ Tries mempty+  tell'  (Tries mempty                 mempty-                (singleton origin_ $ SecurityToken token scope)+                (singleton origin_ (SecurityToken token scope)))   {-# INLINEABLE auth #-}@@ -227,9 +228,9 @@ --   with 'routeAuth': -- --   > route routes . routeAuth routes-route :: ( MonadIO m-         ) => RouterT (MiddlewareT m) sec m a -- ^ The Router-           -> MiddlewareT m+route :: MonadIO m+      => RouterT (MiddlewareT m) sec m a -- ^ The Router+      -> MiddlewareT m route hs app req resp = do   let path = pathInfo req   mightMatch <- extractMatch path hs@@ -247,11 +248,11 @@ --   an exception based on the current 'Network.Wai.Middleware.Request' and --   the /layers/ of 'auth' tokens passed in your router, turn your router --   into a 'Control.Monad.guard' for middlewares, basically.-routeAuth :: ( MonadIO m-             , MonadThrow m-             ) => (Request -> [sec] -> m ()) -- ^ authorization method-               -> RouterT (MiddlewareT m) (SecurityToken sec) m a -- ^ The Router-               -> MiddlewareT m+routeAuth :: MonadIO m+          => MonadThrow m+          => (Request -> [sec] -> m ()) -- ^ authorization method+          -> RouterT (MiddlewareT m) (SecurityToken sec) m a -- ^ The Router+          -> MiddlewareT m routeAuth authorize hs app req resp = do   extractAuth authorize req hs   route hs app req resp@@ -259,10 +260,10 @@ -- * Extraction -------------------------------  -- | Extracts only the normal 'match', 'matchGroup' and 'matchHere' routes.-extractMatch :: ( MonadIO m-                ) => [T.Text] -- ^ The path to match against-                  -> RouterT r sec m a -- ^ The Router-                  -> m (Maybe r)+extractMatch :: MonadIO m+             => [T.Text] -- ^ The path to match against+             -> RouterT r sec m a -- ^ The Router+             -> m (Maybe r) extractMatch path !hs = do   Tries{trieContent} <- execRouterT hs   let mResult = lookupWithLRPT trimFileExt path trieContent@@ -278,10 +279,10 @@   -- | Extracts only the 'matchAny' responses; something like the greatest-lower-bound.-extractMatchAny :: ( MonadIO m-                   ) => [T.Text] -- ^ The path to match against-                     -> RouterT r sec m a -- ^ The Router-                     -> m (Maybe r)+extractMatchAny :: MonadIO m+                => [T.Text] -- ^ The path to match against+                -> RouterT r sec m a -- ^ The Router+                -> m (Maybe r) extractMatchAny path = extractNearestVia path (\x -> trieCatchAll <$> execRouterT x)  {-# INLINEABLE extractMatchAny #-}@@ -290,10 +291,10 @@  -- | Find the security tokens / authorization roles affiliated with --   a request for a set of routes.-extractAuthSym :: ( MonadIO m-                  ) => [T.Text] -- ^ The path to match against-                    -> RouterT x (SecurityToken sec) m a -- ^ The Router-                    -> m [sec]+extractAuthSym :: MonadIO m+               => [T.Text] -- ^ The path to match against+               -> RouterT x (SecurityToken sec) m a -- ^ The Router+               -> m [sec] extractAuthSym path hs = do   Tries{trieSecurity} <- execRouterT hs   liftIO . stToIO $ do@@ -306,12 +307,12 @@ {-# INLINEABLE extractAuthSym #-}  -- | Extracts only the security handling logic, and turns it into a guard.-extractAuth :: ( MonadIO m-               , MonadThrow m-               ) => (Request -> [sec] -> m ()) -- ^ authorization method-                 -> Request-                 -> RouterT x (SecurityToken sec) m a-                 -> m ()+extractAuth :: MonadIO m+            => MonadThrow m+            => (Request -> [sec] -> m ()) -- ^ authorization method+            -> Request+            -> RouterT x (SecurityToken sec) m a+            -> m () extractAuth authorize req hs = do   ss <- extractAuthSym (pathInfo req) hs   authorize req ss@@ -322,11 +323,11 @@ -- | Given a way to draw out a special-purpose trie from our route set, route --   to the responses based on a /furthest-route-reached/ method, or like a --   greatest-lower-bound.-extractNearestVia :: ( MonadIO m-                     ) => [T.Text] -- ^ The path to match against-                       -> (RouterT r sec m a -> m (RootedPredTrie T.Text r))-                       -> RouterT r sec m a-                       -> m (Maybe r)+extractNearestVia :: MonadIO m+                  => [T.Text] -- ^ The path to match against+                  -> (RouterT r sec m a -> m (RootedPredTrie T.Text r))+                  -> RouterT r sec m a+                  -> m (Maybe r) extractNearestVia path extr hs = do   trie <- extr hs   pure (mid <$> Interface.match path trie)@@ -353,19 +354,19 @@  -- | A quirky function for processing the last element of a lookup path, only -- on /literal/ matches.-lookupWithLPT :: ( Hashable s-                 , Eq s-                 ) => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)+lookupWithLPT :: Hashable s+              => Eq s+              => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a) lookupWithLPT f tss (PredTrie (HashMapStep ls) (PredStep ps)) =   getFirst $ First (goLit f tss ls)           <> foldMap (First . goPred f tss) ps -goLit :: ( Hashable s-         , Eq s-         ) => (s -> s)-           -> NonEmpty s-           -> HM.HashMap s (HashMapChildren PredTrie s a)-           -> Maybe ([s], a)+goLit :: Hashable s+      => Eq s+      => (s -> s)+      -> NonEmpty s+      -> HM.HashMap s (HashMapChildren PredTrie s a)+      -> Maybe ([s], a) goLit f (t:|ts) xs = do   (HashMapChildren mx mxs) <- getFirst $ First (HM.lookup t xs)                                       <> First (  if null ts@@ -375,12 +376,12 @@   then ([f t],) <$> mx   else first (t:) <$> (lookupWithLPT f (fromList ts) =<< mxs) -goPred :: ( Hashable s-          , Eq s-          ) => (s -> s)-            -> NonEmpty s-            -> Pred PredTrie s a-            -> Maybe ([s], a)+goPred :: Hashable s+       => Eq s+       => (s -> s)+       -> NonEmpty s+       -> Pred PredTrie s a+       -> Maybe ([s], a) goPred f (t:|ts) (Pred predicate mx xs) = do   d <- predicate t   if null ts@@ -392,9 +393,9 @@ {-# INLINEABLE lookupWithLPT #-}  -lookupWithLRPT :: ( Hashable s-                 , Eq s-                 ) => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a)+lookupWithLRPT :: Hashable s+               => Eq s+               => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a) lookupWithLRPT _ [] (RootedPredTrie mx _) = ([],) <$> mx lookupWithLRPT f ts (RootedPredTrie _ xs) = lookupWithLPT f (fromList ts) xs @@ -403,7 +404,7 @@ {-# INLINEABLE lookupWithLRPT #-}  -tell' :: (Monoid w, S.MonadState w m) => w -> m ()+tell' :: Monoid w => S.MonadState w m => w -> m () tell' x = S.modify' (<> x)  {-# INLINEABLE tell' #-}

@@ -29,9 +29,10 @@   ) where  import           Web.Routes.Nested.Match             (UrlChunks)-import           Network.Wai.Middleware.Verbs        (VerbListenerT, execVerbListenerT, lookupVerb, getVerb)+import           Network.Wai.Middleware.Verbs        (VerbListenerT, execVerbListenerT, getVerbFromRequest) import           Network.Wai.Middleware.ContentType  (FileExtListenerT, fileExtsToMiddleware) import           Network.Wai.Trans                   (MiddlewareT)+import           Network.Wai                         (strictRequestBody) import           Data.Trie.Pred.Base                 (RootedPredTrie (..)) import           Data.Trie.Pred.Interface.Types      (Extrude (..), CatMaybes) @@ -39,10 +40,11 @@ import qualified Data.Text                           as T import           Data.Function.Poly                  (ArityTypeListIso) import           Data.Singleton.Class                (Extractable)+import qualified Data.HashMap.Lazy                   as HM import           Control.Monad.Trans                 (MonadTrans) import           Control.Monad.IO.Class              (MonadIO) import qualified Control.Monad.State                 as S-import           Control.Monad.Trans.Control.Aligned (MonadBaseControl)+import           Control.Monad.Trans.Control.Aligned (MonadBaseControl (liftBaseWith))   @@ -57,9 +59,7 @@ instance Monoid (Tries x s) where   mempty = Tries mempty mempty mempty   mappend (Tries x1 x2 x3) (Tries y1 y2 y3) =-    ((Tries $! x1 <> y1)-            $! x2 <> y2)-            $! x3 <> y3+    Tries (x1 <> y1) (x2 <> y2) (x3 <> y3)  -- | The (syntactic) monad for building a router with functions like --   "Web.Routes.Nested.match".@@ -97,9 +97,14 @@ --   is satisfiable (i.e. @Accept@ headers are O.K., etc.) action :: MonadBaseControl IO m stM        => Extractable stM-       => ActionT m () -> MiddlewareT m+       => ActionT m ()+       -> MiddlewareT m action xs app req respond = do-  vmap <- fmap fileExtsToMiddleware <$> execVerbListenerT xs-  case lookupVerb (getVerb req) vmap of-    Nothing  -> app req respond-    Just mid -> mid app req respond+  vmap <- execVerbListenerT xs+  case HM.lookup (getVerbFromRequest req) vmap of+    Nothing -> app req respond+    Just eR -> do+      c <- case eR of+        Left c' -> pure c'+        Right f -> f <$> liftBaseWith (\_ -> strictRequestBody req)+      fileExtsToMiddleware c app req respond

@@ -9,7 +9,8 @@ module Web.Routes.NestedSpec.Basic where  import Web.Routes.Nested (o_, p_, l_, r_, (</>), match, matchHere, matchGroup, auth, AuthScope (..), textOnly, routeAuth)-import Network.Wai.Trans (Middleware, Application, Request, catchMiddlewareT)+import Network.Wai (Middleware, Application, Request)+import Network.Wai.Trans (catchMiddlewareT) import Network.HTTP.Types (status401, status404, status200) import Text.Regex (mkRegex) import Data.Attoparsec.Text (double)