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: 7.1.1 +Version: 7.2.0 Author: Athan Clark Maintainer: Athan Clark License: BSD3 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 @@ -41,22 +41,23 @@ you populate a list of roles breached during any request. The function argument to 'routeAuth' guards a Request to pass or fail at the high level, while 'auth' lets you create your authorization boundaries on a case-by-case basis. Both allow -you to tap into the monad transformer stack for logging, STM variables, database queries, +you to tap into the monad transformer stack for logging, STRefs, database queries, etc. -} module Web.Routes.Nested - ( -- * Combinators + ( -- * Router Construction match , matchHere , matchAny , matchGroup , auth - , -- * Routing + , -- * Routing Middleware route , routeAuth - , extractMatch + , -- ** Precise Route Extraction + extractMatch , extractMatchAny , extractAuthSym , extractAuth @@ -64,6 +65,8 @@ , -- * Metadata SecurityToken (..) , AuthScope (..) + , Match + , MatchGroup , -- * Re-Exports module Web.Routes.Nested.Match , module Web.Routes.Nested.Types @@ -98,6 +101,20 @@ import Control.Monad.ST +-- | The constraints necessary for 'match'. +type Match xs' xs childContent resultContent = + ( Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent) + , ArityTypeListIso childContent xs' resultContent + ) + + +-- | The constraints necessary for 'matchGroup'. +type MatchGroup xs' xs childContent resultContent childSec resultSec = + ( ExtrudeSoundly xs' xs childContent resultContent + , ExtrudeSoundly xs' xs childSec resultSec + ) + + -- | Embed a 'Network.Wai.Trans.MiddlewareT' into a set of routes via a matching string. You should -- expect the match to create /arity/ in your handler - the @childContent@ variable. -- The arity of @childContent@ may grow or shrink, depending on the heterogeneous @@ -114,14 +131,11 @@ -- by a predicate with 'matchGroup', -- then we would need another level of arity /before/ the @Double@. match :: ( Monad m - , Singleton (UrlChunks xs) - childContent - (RootedPredTrie T.Text resultContent) - , cleanxs ~ CatMaybes xs - , ArityTypeListIso childContent cleanxs resultContent - ) => UrlChunks xs - -> childContent - -> HandlerT resultContent sec m () + , xs' ~ CatMaybes xs + , 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 @@ -132,8 +146,8 @@ -- | Create a handle for the /current/ route - an alias for @\h -> match o_ h@. matchHere :: ( Monad m - ) => content - -> HandlerT content sec m () + ) => content -- ^ The response to send + -> RouterT content sec m () matchHere = match origin_ {-# INLINEABLE matchHere #-} @@ -143,8 +157,8 @@ -- use this for a catch-all at some level in their routes, something -- like a @not-found 404@ page is useful. matchAny :: ( Monad m - ) => content - -> HandlerT content sec m () + ) => content -- ^ The response to send + -> RouterT content sec m () matchAny !vl = tell' $ Tries mempty (singleton origin_ vl) @@ -158,14 +172,13 @@ -- doing this with a parser or regular expression will necessitate the existing -- arity in the handlers before the progam can compile. matchGroup :: ( Monad m - , cleanxs ~ CatMaybes xs - , ExtrudeSoundly cleanxs xs childContent resultContent - , ExtrudeSoundly cleanxs xs childSec resultSec - ) => UrlChunks xs - -> HandlerT childContent childSec m () - -> HandlerT resultContent resultSec m () + , xs' ~ CatMaybes xs + , 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 $ execHandlerT cs + (Tries trieContent' trieNotFound trieSec) <- lift $ execRouterT cs tell' $ Tries (extrude ts trieContent') (extrude ts trieNotFound) (extrude ts trieSec) @@ -191,9 +204,9 @@ -- | Sets the security role and error handler for a set of routes, optionally -- including its parent route. auth :: ( Monad m - ) => sec + ) => sec -- ^ Your security token -> AuthScope - -> HandlerT content (SecurityToken sec) m () + -> RouterT content (SecurityToken sec) m () auth !token !scope = tell' $ Tries mempty mempty @@ -205,10 +218,17 @@ -- * Routing --------------------------------------- +-- | Use this function to run your 'RouterT' into a 'MiddlewareT'; +-- making your router executable in WAI. Note that this only +-- responds with content, and doesn't protect your routes with +-- your calls to 'auth'; to protect routes, postcompose this +-- with 'routeAuth': +-- +-- > route routes . routeAuth routes route :: ( Monad m , MonadIO m , Typeable m - ) => HandlerT (MiddlewareT m) sec m a + ) => RouterT (MiddlewareT m) sec m a -- ^ The Router -> MiddlewareT m route hs app req resp = do let path = pathInfo req @@ -222,13 +242,18 @@ mMatch Just mid -> mid app req resp + +-- | Supply a method to decide whether or not to 'Control.Monad.Catch.throwM' +-- 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 :: ( Monad m , MonadIO m , MonadThrow m , Typeable sec , Typeable m - ) => (Request -> [sec] -> m ()) - -> HandlerT (MiddlewareT m) (SecurityToken sec) m a + ) => (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 @@ -236,15 +261,15 @@ -- * Extraction ------------------------------- --- | Extracts only the normal 'match' and 'matchHere' +-- | Extracts only the normal 'match', 'matchGroup' and 'matchHere' routes. extractMatch :: ( Monad m , MonadIO m , Typeable r - ) => [T.Text] - -> HandlerT r sec m a + ) => [T.Text] -- ^ The path to match against + -> RouterT r sec m a -- ^ The Router -> m (Maybe r) extractMatch path !hs = do - tries <- execHandlerT hs + tries <- execRouterT hs liftIO $ stToIO $ do trie <- trieContentMutable tries mResult <- lookupWithLRPT trimFileExt path trie @@ -259,14 +284,14 @@ {-# INLINEABLE extractMatch #-} --- | Extracts only the @notFound@ responses +-- | Extracts only the 'matchAny' responses; something like the greatest-lower-bound. extractMatchAny :: ( Monad m , MonadIO m , Typeable r - ) => [T.Text] - -> HandlerT r sec m a + ) => [T.Text] -- ^ The path to match against + -> RouterT r sec m a -- ^ The Router -> m (Maybe r) -extractMatchAny path = extractNearestVia path (\x -> trieCatchAll <$> execHandlerT x) +extractMatchAny path = extractNearestVia path (\x -> trieCatchAll <$> execRouterT x) {-# INLINEABLE extractMatchAny #-} @@ -277,11 +302,11 @@ extractAuthSym :: ( Monad m , MonadIO m , Typeable sec - ) => [T.Text] - -> HandlerT x (SecurityToken sec) m a + ) => [T.Text] -- ^ The path to match against + -> RouterT x (SecurityToken sec) m a -- ^ The Router -> m [sec] extractAuthSym path hs = do - tries <- execHandlerT hs + tries <- execRouterT hs liftIO . stToIO $ do results <- MPT.matchesR path =<< trieSecurityMutable tries pure $! foldr go [] results @@ -291,14 +316,14 @@ {-# INLINEABLE extractAuthSym #-} --- | Extracts only the security handling logic, and turns it into a guard +-- | Extracts only the security handling logic, and turns it into a guard. extractAuth :: ( Monad m , MonadIO m , MonadThrow m , Typeable sec - ) => (Request -> [sec] -> m ()) -- authorization method + ) => (Request -> [sec] -> m ()) -- ^ authorization method -> Request - -> HandlerT x (SecurityToken sec) m a + -> RouterT x (SecurityToken sec) m a -> m () extractAuth authorize req hs = do ss <- extractAuthSym (pathInfo req) hs @@ -308,13 +333,14 @@ -- | Given a way to draw out a special-purpose trie from our route set, route --- to the responses based on a /furthest-reached/ method. +-- to the responses based on a /furthest-route-reached/ method, or like a +-- greatest-lower-bound. extractNearestVia :: ( MonadIO m , Monad m , Typeable r - ) => [T.Text] - -> (HandlerT r sec m a -> m (RootedPredTrie T.Text r)) - -> HandlerT r sec m a + ) => [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 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 @@ -6,8 +6,31 @@ , GeneralizedNewtypeDeriving #-} -module Web.Routes.Nested.Types where +{- | +Module : Web.Routes.Nested.Types +Copyright : (c) 2015 Athan Clark +License : BSD-style +Maintainer : athan.clark@gmail.com +Stability : experimental +Portability : GHC +-} + +module Web.Routes.Nested.Types + ( -- * Internal Structure + Tries (..) + , trieContentMutable + , trieCatchAllMutable + , trieSecurityMutable + , -- * Builder + RouterT (..) + , execRouterT + , ActionT + , action + , -- * Book Keeping + ExtrudeSoundly + ) where + import Web.Routes.Nested.Match import Network.Wai.Middleware.Verbs import Network.Wai.Middleware.ContentType @@ -17,14 +40,14 @@ import Data.Trie.Pred.Base (RootedPredTrie (..)) import Data.Trie.Pred.Interface.Types (Extrude (..), CatMaybes) -import Data.Typeable +import Data.Typeable import Data.Monoid import qualified Data.Text as T import Data.Function.Poly import Control.Monad.Trans import qualified Control.Monad.State as S +import Control.Monad.ST -import Control.Monad.ST -- | The internal data structure built during route declaration. @@ -34,6 +57,7 @@ , trieSecurity :: !(RootedPredTrie T.Text s) } + trieContentMutable :: ( Typeable x , Typeable s ) => Tries x s' @@ -59,31 +83,36 @@ $! x2 <> y2) $! x3 <> y3 --- | The return type of a route building expression like `match` - --- it should have a shape of @HandlerT (MiddlewareT m) (SecurityToken s) m a@ --- when used with `route`. -newtype HandlerT x sec m a = HandlerT - { runHandlerT :: S.StateT (Tries x sec) m a +-- | The (syntactic) monad for building a router with functions like +-- "Web.Routes.Nested.match". +-- it should have a shape of @RouterT (MiddlewareT m) (SecurityToken s) m a@ +-- when used with "Web.Routes.Nested.route". +newtype RouterT x sec m a = RouterT + { runRouterT :: S.StateT (Tries x sec) m a } deriving ( Functor, Applicative, Monad, MonadIO, MonadTrans , S.MonadState (Tries x sec)) -- | Run the monad, only getting the built state and throwing away @a@. -execHandlerT :: Monad m => HandlerT x sec m a -> m (Tries x sec) -execHandlerT hs = S.execStateT (runHandlerT hs) mempty +execRouterT :: Monad m => RouterT x sec m a -> m (Tries x sec) +execRouterT hs = S.execStateT (runRouterT hs) mempty -{-# INLINEABLE execHandlerT #-} +{-# INLINEABLE execRouterT #-} --- | Deductive proof that prepending a list of types to a function as arity --- can be deconstructed. -type ExtrudeSoundly cleanxs xs c r = - ( cleanxs ~ CatMaybes xs - , ArityTypeListIso c cleanxs r +-- | Soundness constraint showing that a function's arity +-- can be represented as a type-level list. +type ExtrudeSoundly xs' xs c r = + ( xs' ~ CatMaybes xs + , ArityTypeListIso c xs' r , Extrude (UrlChunks xs) (RootedPredTrie T.Text c) (RootedPredTrie T.Text r) ) --- | The type of content builders. + +-- | The type of "content" builders; using the +-- +-- and +-- packages. type ActionT m a = VerbListenerT (FileExtListenerT m a) m a -- | Run the content builder into a middleware that responds when the content