diff --git a/nested-routes.cabal b/nested-routes.cabal --- a/nested-routes.cabal +++ b/nested-routes.cabal @@ -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 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 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 @@ -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' #-} diff --git a/src/Web/Routes/Nested/Types.hs b/src/Web/Routes/Nested/Types.hs --- a/src/Web/Routes/Nested/Types.hs +++ b/src/Web/Routes/Nested/Types.hs @@ -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 diff --git a/test/Web/Routes/NestedSpec/Basic.hs b/test/Web/Routes/NestedSpec/Basic.hs --- a/test/Web/Routes/NestedSpec/Basic.hs +++ b/test/Web/Routes/NestedSpec/Basic.hs @@ -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)