nested-routes-5.0.0: src/Web/Routes/Nested.hs
{-# LANGUAGE
GADTs
, PolyKinds
, TypeFamilies
, DeriveFunctor
, TypeOperators
, TupleSections
, DoAndIfThenElse
, ConstraintKinds
, FlexibleContexts
, OverloadedStrings
, ScopedTypeVariables
, GeneralizedNewtypeDeriving
#-}
-- |
-- Module : Web.Routes.Nested
-- Copyright : (c) 2015 Athan Clark
--
-- License : BSD-style
-- Maintainer : athan.clark@gmail.com
-- Stability : experimental
-- Portability : GHC
--
-- This module exports most of what you'll need for sophisticated routing -
-- all the tools from <https://hackage.haskell.org/package/wai-middleware-verbs wai-middleware-verbs>
-- (routing for the incoming HTTP method) and
-- <https://hackage.haskell.org/package/wai-middleware-content-type wai-middleware-content-type>
-- (routing for the incoming Accept header, and implied file extension),
-- <https://hackage.haskell.org/package/wai WAI> itself, and
-- <https://hackage.haskell.org/package/wai-transformers wai-transformers> - some simple
-- type aliases wrapped around WAI's @Application@ and @Middleware@ types, allowing us
-- to embed monad transformer stacks for our applications.
--
-- The routing system lets you embed these complicated HTTP verb / content-type
-- sensative responses just as easily as a WAI @Middleware@. There is enough
-- tooling provided to use one paradigm or the other. Note - nested-routes
-- does not affect the @pathInfo@ of the incoming @Request@ in any way, but merely
-- matches on it and passes control to the designated response.
--
-- To match a route, you have a few options - you can match against a string literal,
-- a regular expression (via <https://hackage.haskell.org/package/regex-compat regex-compat>),
-- or an <https://hackage.haskell.org/package/attoparsec attoparsec> parser. This list
-- will most likely grow in the future, depending on demand.
--
-- There is also support for embedding security layers in your routes, in the same
-- nested manner. By "tagging" a set of routes with an authorization role (with @auth@),
-- you populate a list of roles breached during any request. In the authentication
-- parameter in @routeAuth@ and @routeActionAuth@, the function
-- keeps the session integrity in-place, while @auth@ lets you create your authorization
-- boundaries. Both are symbiotic and neccessary for establishing security, and both allow
-- you to tap into the monad transformer stack to do logging, STM, database queries,
-- etc.
--
-- To use your set of routes in a WAI application, you need to "extract" the
-- functionality from your route set - using the @route@, @routeAuth@, @routeAction@,
-- and @routeActionAuth@
-- functions, you can create monolithic apps very easily.
-- But, if you would like to extract the security middleware to place before
-- say, a /static/ middleware you already have in place, use the @extractAuth@
-- functions, and others for their respective purposes. This way, you can decompose
-- the routing system into each subject matter, and re-compose (@.@) them in whichever
-- order you like for your application.
module Web.Routes.Nested
( module X
-- * Types
, Tries
, HandlerT (..)
, execHandlerT
, ActionT
, RoutableT
, RoutableActionT
, AuthScope (..)
, ExtrudeSoundly
-- * Combinators
, handle
, handleAction
, parent
, auth
, notFound
, notFoundAction
, action
-- * Routing
, route
, routeAuth
, routeAction
, routeActionAuth
-- * Extraction
, extractContent
, extractNotFound
, extractAuthSym
, extractAuth
, extractNearestVia
, actionToMiddleware
) where
import Web.Routes.Nested.Types as X
import Network.Wai.Trans as X
import Network.Wai.Middleware.Verbs as X
import Network.Wai.Middleware.ContentType as X
import Data.Trie.Pred (RootedPredTrie (..), PredTrie (..))
import qualified Data.Trie.Pred as PT -- only using lookups
import Data.Trie.Pred.Step (PredStep (..), PredSteps (..))
import qualified Data.Trie.Class as TC
import Data.Trie.Map (MapStep (..))
import qualified Data.Map as Map
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Foldable
import Data.Functor.Syntax
import Data.Function.Poly
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Trans.Except
import qualified Control.Monad.State as S
type Tries x s e = ( RootedPredTrie T.Text x
, RootedPredTrie T.Text x
, RootedPredTrie T.Text s
, RootedPredTrie T.Text e
)
newtype HandlerT x sec err aux m a = HandlerT
{ runHandlerT :: S.StateT (Tries x sec err) m a }
deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadTrans
, S.MonadState (Tries x sec err)
)
execHandlerT :: Monad m => HandlerT x sec err aux m a -> m (Tries x sec err)
execHandlerT hs = S.execStateT (runHandlerT hs) mempty
type ActionT e u m a = VerbListenerT (FileExtListenerT (MiddlewareT m) m a) e u m a
-- | Turn an @ActionT@ into a @MiddlewareT@ - could be used to make middleware-based
-- route sets cooperate with the content-type and verb combinators.
action :: MonadIO m => ActionT e u m () -> MiddlewareT m
action xs = verbsToMiddleware $ mapVerbs fileExtsToMiddleware xs
type RoutableT s e u ue m a =
HandlerT (MiddlewareT m) (s, AuthScope) (e -> MiddlewareT m) (e,u,ue) m a
type RoutableActionT s e u ue m a =
HandlerT (ActionT ue u m ()) (s, AuthScope) (e -> ActionT ue u m ()) (e,u,ue) m a
type ExtrudeSoundly cleanxs xs c r =
( cleanxs ~ CatMaybes xs
, ArityTypeListIso c cleanxs r
, Extrude (UrlChunks xs)
(RootedPredTrie T.Text c)
(RootedPredTrie T.Text r)
)
-- | Embed an @ActionT@ into a set of routes directly, without first converting
-- it to a @MiddlewareT@.
handleAction :: ( Monad m
, Functor m
, cleanxs ~ CatMaybes xs
, HasResult childContent (ActionT ue u m ())
, HasResult childErr (e -> ActionT ue u m ())
, ExpectArity cleanxs childContent
, ExpectArity cleanxs childSec
, ExpectArity cleanxs childErr
, Singleton (UrlChunks xs)
childContent
(RootedPredTrie T.Text resultContent)
, ExtrudeSoundly cleanxs xs childContent resultContent
, ExtrudeSoundly cleanxs xs childSec resultSec
, ExtrudeSoundly cleanxs xs childErr resultErr
) => UrlChunks xs
-> Maybe childContent
-> Maybe (HandlerT childContent childSec childErr (e,u,ue) m ())
-> HandlerT resultContent resultSec resultErr (e,u,ue) m ()
handleAction ts (Just vl) Nothing = tell' (singleton ts vl, mempty, mempty, mempty)
handleAction ts mvl (Just cs) = do
(RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs
tell' ( extrude ts $ RootedPredTrie mvl trieContent
, extrude ts trieNotFound
, extrude ts trieSec
, extrude ts trieErr
)
handleAction _ Nothing Nothing = return ()
-- | Embed a @MiddlewareT@ into a set of routes.
handle :: ( Monad m
, Functor m
, cleanxs ~ CatMaybes xs
, HasResult childContent (MiddlewareT m)
, HasResult childErr (e -> MiddlewareT m)
, ExpectArity cleanxs childContent
, ExpectArity cleanxs childSec
, ExpectArity cleanxs childErr
, Singleton (UrlChunks xs)
childContent
(RootedPredTrie T.Text resultContent)
, ExtrudeSoundly cleanxs xs childContent resultContent
, ExtrudeSoundly cleanxs xs childSec resultSec
, ExtrudeSoundly cleanxs xs childErr resultErr
) => UrlChunks xs
-> Maybe childContent
-> Maybe (HandlerT childContent childSec childErr (e,u,ue) m ())
-> HandlerT resultContent resultSec resultErr (e,u,ue) m ()
handle ts (Just vl) Nothing = tell' (singleton ts vl, mempty, mempty, mempty)
handle ts mvl (Just cs) = do
(RootedPredTrie _ trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs
tell' ( extrude ts $ RootedPredTrie mvl trieContent
, extrude ts trieNotFound
, extrude ts trieSec
, extrude ts trieErr
)
handle _ Nothing Nothing = return ()
-- | Prepend a path to an existing set of routes.
parent :: ( Monad m
, Functor m
, cleanxs ~ CatMaybes xs
, Singleton (UrlChunks xs)
childContent
(RootedPredTrie T.Text resultContent)
, ExtrudeSoundly cleanxs xs childContent resultContent
, ExtrudeSoundly cleanxs xs childSec resultSec
, ExtrudeSoundly cleanxs xs childErr resultErr
) => UrlChunks xs
-> HandlerT childContent childSec childErr aux m ()
-> HandlerT resultContent resultSec resultErr aux m ()
parent ts cs = do
(trieContent,trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs
tell' ( extrude ts trieContent
, extrude ts trieNotFound
, extrude ts trieSec
, extrude ts trieErr
)
-- | Designate the scope of security to the set of routes - either only the adjacent
-- routes, or the adjacent /and/ the parent container node (root node if not
-- declared).
data AuthScope = ProtectParent | ProtectChildren
deriving (Show, Eq)
-- | Sets the security role and error handler for a set of routes, optionally
-- including its parent route.
auth :: ( Monad m
, Functor m
) => sec
-> err
-> AuthScope
-> HandlerT content (sec, AuthScope) err aux m ()
auth token handleFail scope =
tell' ( mempty
, mempty
, RootedPredTrie (Just (token,scope)) mempty
, RootedPredTrie (Just handleFail) mempty
)
-- | Embed an @ActionT@ as a not-found handler into a set of routes, without first converting
-- it to a @MiddlewareT@.
notFoundAction :: ( Monad m
, Functor m
, cleanxs ~ CatMaybes xs
, HasResult childContent (ActionT ue u m ())
, HasResult childErr (e -> ActionT ue u m ())
, ExpectArity cleanxs childContent
, ExpectArity cleanxs childSec
, ExpectArity cleanxs childErr
, Singleton (UrlChunks xs)
childContent
(RootedPredTrie T.Text resultContent)
, ExtrudeSoundly cleanxs xs childContent resultContent
, ExtrudeSoundly cleanxs xs childSec resultSec
, ExtrudeSoundly cleanxs xs childErr resultErr
) => UrlChunks xs
-> Maybe childContent
-> Maybe (HandlerT childContent childSec childErr (e,u,ue) m ())
-> HandlerT resultContent resultSec resultErr (e,u,ue) m ()
notFoundAction ts (Just vl) Nothing = tell' (mempty, singleton ts vl, mempty, mempty)
notFoundAction ts mvl (Just cs) = do
(trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs
tell' ( extrude ts trieContent
, extrude ts $ RootedPredTrie mvl trieNotFound
, extrude ts trieSec
, extrude ts trieErr
)
notFoundAction _ Nothing Nothing = return ()
-- | Embed a @MiddlewareT@ as a not-found handler into a set of routes.
notFound :: ( Monad m
, Functor m
, cleanxs ~ CatMaybes xs
, HasResult childContent (MiddlewareT m)
, HasResult childErr (e -> MiddlewareT m)
, ExpectArity cleanxs childContent
, ExpectArity cleanxs childSec
, ExpectArity cleanxs childErr
, Singleton (UrlChunks xs)
childContent
(RootedPredTrie T.Text resultContent)
, ExtrudeSoundly cleanxs xs childContent resultContent
, ExtrudeSoundly cleanxs xs childSec resultSec
, ExtrudeSoundly cleanxs xs childErr resultErr
) => UrlChunks xs
-> Maybe childContent
-> Maybe (HandlerT childContent childSec childErr (e,u,ue) m ())
-> HandlerT resultContent resultSec resultErr (e,u,ue) m ()
notFound ts (Just vl) Nothing = tell' (mempty, singleton ts vl, mempty, mempty)
notFound ts mvl (Just cs) = do
(trieContent,RootedPredTrie _ trieNotFound,trieSec,trieErr) <- lift $ execHandlerT cs
tell' ( extrude ts trieContent
, extrude ts $ RootedPredTrie mvl trieNotFound
, extrude ts trieSec
, extrude ts trieErr
)
notFound _ Nothing Nothing = return ()
-- * Routing ---------------------------------------
-- | Turns a @HandlerT@ containing @MiddlewareT@s into a @MiddlewareT@.
route :: ( Functor m
, Monad m
, MonadIO m
) => HandlerT (MiddlewareT m) sec err aux m () -- ^ Assembled @handle@ calls
-> MiddlewareT m
route hs = extractContent hs . extractNotFound hs
-- | Given a security verification function that returns a method to updating the session,
-- turn a set of routes containing @MiddlewareT@s into a @MiddlewareT@, where a session
-- is secured before responding.
routeAuth :: ( Functor m
, Monad m
, MonadIO m
) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- ^ authorize
-> RoutableT sec e u ue m () -- ^ Assembled @handle@ calls
-> MiddlewareT m
routeAuth authorize hs = extractAuth authorize hs . route hs
-- | Exactly like @route@, except specialized to route sets that contain @ActionT@s -
-- essentially @fmap@ing @action@ to each element.
routeAction :: ( Functor m
, Monad m
, MonadIO m
) => RoutableActionT sec e u ue m ()
-> MiddlewareT m
routeAction = route . actionToMiddleware
-- | Exactly like @routeAuth@, but specialized for @ActionT@.
routeActionAuth :: ( Functor m
, Monad m
, MonadIO m
) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- ^ authorize
-> RoutableActionT sec e u ue m () -- ^ Assembled @handle@ calls
-> MiddlewareT m
routeActionAuth authorize = routeAuth authorize . actionToMiddleware
-- | Turns a @HandlerT@ containing @ActionT@s into a @HandlerT@ containing @MiddlewareT@s.
actionToMiddleware :: MonadIO m =>
RoutableActionT sec e u ue m ()
-> RoutableT sec e u ue m ()
actionToMiddleware hs = do
(rtrie,nftrie,strie,errtrie) <- lift $ execHandlerT hs
tell' ( action <$> rtrie
, action <$> nftrie
, strie
, (action .) <$> errtrie
)
-- * Extraction -------------------------------
-- | Extracts only the normal @handle@ (content) routes into
-- a @MiddlewareT@, disregarding security and not-found responses.
extractContent :: ( Functor m
, Monad m
, MonadIO m
) => HandlerT (MiddlewareT m) sec err aux m a
-> MiddlewareT m
extractContent hs app req respond = do
(trie,_,_,_) <- execHandlerT hs
case lookupWithLRPT trimFileExt (pathInfo req) trie of
Nothing -> fromMaybe (app req respond) $ do
guard $ not . null $ pathInfo req
guard $ trimFileExt (last $ pathInfo req) == "index"
mid <- TC.lookup (init $ pathInfo req) trie
Just $ mid app req respond
Just mid -> mid app req respond
-- | Find the security tokens / authorization roles affiliated with
-- a request for a set of routes.
extractAuthSym :: ( Functor m
, Monad m
) => HandlerT x (sec, AuthScope) err aux m a
-> Request
-> m [sec]
extractAuthSym hs req = do
(_,_,trie,_) <- execHandlerT hs
return $ foldl go [] (PT.matchesRPT (pathInfo req) trie)
where
go ys (_,(_,ProtectChildren),[]) = ys
go ys (_,(x,_ ),_ ) = ys ++ [x]
-- | Extracts only the security handling logic into a @MiddlewareT@.
extractAuth :: ( Functor m
, Monad m
, MonadIO m
) => (Request -> [sec] -> ExceptT e m (Response -> Response)) -- authorization method
-> HandlerT x (sec, AuthScope) (e -> MiddlewareT m) aux m a
-> MiddlewareT m
extractAuth authorize hs app req respond = do
(_,_,_,trie) <- execHandlerT hs
ss <- extractAuthSym hs req
ef <- runExceptT $ authorize req ss
either (\e -> maybe (app req respond)
(\mid -> mid app req respond)
$ (getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie) <$~> e)
(\f -> app req (respond . f))
ef
-- | Extracts only the @notFound@ responses into a @MiddlewareT@.
extractNotFound :: ( Functor m
, Monad m
, MonadIO m
) => HandlerT (MiddlewareT m) sec err aux m a
-> MiddlewareT m
extractNotFound = extractNearestVia (execHandlerT >=> \(_,t,_,_) -> return t)
-- | Given a way to draw out a special-purpose trie from our route set, route
-- to the responses based on a /furthest-reached/ method.
extractNearestVia :: ( Functor m
, Monad m
, MonadIO m
) => (HandlerT (MiddlewareT m) sec err aux m a -> m (RootedPredTrie T.Text (MiddlewareT m)))
-> HandlerT (MiddlewareT m) sec err aux m a
-> MiddlewareT m
extractNearestVia extr hs app req respond = do
trie <- extr hs
maybe (app req respond)
(\mid -> mid app req respond)
$ getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie
getResultsFromMatch :: ([s],a,[s]) -> a
getResultsFromMatch (_,x,_) = x
-- * Pred-Trie related -----------------
-- | Removes @.txt@ from @foo.txt@
trimFileExt :: T.Text -> T.Text
trimFileExt s =
let lastExt = getLastExt (T.unpack s)
in if lastExt `elem` possibleExts
then T.pack lastExt
else s
where
possibleExts = [ ".html",".htm",".txt",".json",".lucid"
, ".julius",".css",".cassius",".lucius"
]
getLastExt ts = S.evalState (foldrM go [] ts) False
where
go c soFar = do
sawPeriod <- S.get
if sawPeriod
then return soFar
else if c == '.'
then do S.put True
return ('.' : soFar)
else return (c : soFar)
-- | A quirky function for processing the last element of a lookup path, only
-- on /literal/ matches.
lookupWithLPT :: Ord s => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe a
lookupWithLPT f (t:|ts) (PredTrie (MapStep ls) (PredSteps ps))
| null ts = getFirst $ First (goLit (f t) ls) <> foldMap (First . goPred) ps
| otherwise = getFirst $ First (goLit t ls) <> foldMap (First . goPred) ps
where
goLit t' xs = do
(mx,mxs) <- Map.lookup t' xs
if null ts
then mx
else lookupWithLPT f (NE.fromList ts) =<< mxs
goPred (PredStep _ predicate mx xs) = do
d <- predicate t
if null ts
then mx <$~> d
else lookupWithLPT f (NE.fromList ts) xs <$~> d
lookupWithLRPT :: Ord s => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe a
lookupWithLRPT _ [] (RootedPredTrie mx _) = mx
lookupWithLRPT f ts (RootedPredTrie _ xs) = lookupWithLPT f (NE.fromList ts) xs
tell' :: (Monoid w, S.MonadState w m) => w -> m ()
tell' x = do
xs <- S.get
S.put $ xs <> x