module Web.Routes.Nested
(
match
, matchHere
, matchAny
, matchGroup
, auth
,
route
, routeAuth
,
extractMatch
, extractMatchAny
, extractAuthSym
, extractAuth
, extractNearestVia
,
SecurityToken (..)
, AuthScope (..)
, Match
, MatchGroup
,
module Web.Routes.Nested.Match
, module Web.Routes.Nested.Types
, module Network.Wai.Middleware.Verbs
, module Network.Wai.Middleware.ContentType
) where
import Web.Routes.Nested.Match (UrlChunks, origin_)
import Web.Routes.Nested.Match
import Web.Routes.Nested.Types (RouterT, execRouterT, Tries (..), ExtrudeSoundly)
import Web.Routes.Nested.Types
import Network.Wai (Request, pathInfo)
import Network.Wai.Trans (MiddlewareT)
import Network.Wai.Middleware.Verbs
import Network.Wai.Middleware.ContentType hiding (responseStatus, responseHeaders, responseData)
import Data.Trie.Pred.Base (RootedPredTrie (..), PredTrie (..))
import Data.Trie.Pred.Base.Step (PredStep (..), Pred (..))
import qualified Data.Trie.Pred.Interface as Interface
import Data.Trie.Pred.Interface.Types (Singleton (..), Extrude (..), CatMaybes)
import Data.Trie.HashMap (HashMapStep (..), HashMapChildren (..))
import Data.List.NonEmpty (NonEmpty (..), fromList)
import qualified Data.Text as T
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HM
import Data.Monoid ((<>), First (..))
import Data.Function.Poly (ArityTypeListIso)
import Data.Bifunctor (bimap)
import qualified Control.Monad.State as S
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Arrow (first)
import Control.Monad.ST (stToIO)
type Match xs' xs childContent resultContent =
( xs' ~ CatMaybes xs
, Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent)
, ArityTypeListIso childContent xs' resultContent
)
type MatchGroup xs' xs childContent resultContent childSec resultSec =
( ExtrudeSoundly xs' xs childContent resultContent
, ExtrudeSoundly xs' xs childSec resultSec
)
match :: Monad m
=> Match xs' xs childContent resultContent
=> UrlChunks xs
-> childContent
-> RouterT resultContent sec m ()
match !ts !vl =
tell' $ Tries (singleton ts vl)
mempty
mempty
matchHere :: Monad m
=> childContent
-> RouterT childContent sec m ()
matchHere = match origin_
matchAny :: Monad m
=> childContent
-> RouterT childContent sec m ()
matchAny !vl =
tell' $ Tries mempty
(singleton origin_ vl)
mempty
matchGroup :: Monad m
=> MatchGroup xs' xs childContent resultContent childSec resultSec
=> UrlChunks xs
-> RouterT childContent childSec m ()
-> RouterT resultContent resultSec m ()
matchGroup !ts cs = do
(Tries trieContent' trieNotFound trieSec) <- lift $ execRouterT cs
tell' $ Tries (extrude ts trieContent')
(extrude ts trieNotFound)
(extrude ts trieSec)
data SecurityToken s = SecurityToken
{ securityToken :: !s
, securityScope :: !AuthScope
} deriving (Show)
data AuthScope
= ProtectHere
| DontProtectHere
deriving (Show, Eq)
auth :: Monad m
=> sec
-> AuthScope
-> RouterT content (SecurityToken sec) m ()
auth !token !scope =
tell' (Tries mempty
mempty
(singleton origin_ (SecurityToken token scope)))
route :: MonadIO m
=> RouterT (MiddlewareT m) sec m a
-> MiddlewareT m
route hs app req resp = do
let path = pathInfo req
mightMatch <- extractMatch path hs
case mightMatch of
Nothing -> do
mMatch <- extractMatchAny path hs
maybe
(app req resp)
(\mid -> mid app req resp)
mMatch
Just mid -> mid app req resp
routeAuth :: MonadIO m
=> MonadThrow m
=> (Request -> [sec] -> m ())
-> RouterT (MiddlewareT m) (SecurityToken sec) m a
-> MiddlewareT m
routeAuth authorize hs app req resp = do
extractAuth authorize req hs
route hs app req resp
extractMatch :: MonadIO m
=> [T.Text]
-> RouterT r sec m a
-> m (Maybe r)
extractMatch path !hs = do
Tries{trieContent} <- execRouterT hs
let mResult = lookupWithLRPT trimFileExt path trieContent
case mResult of
Nothing ->
if not (null path)
&& trimFileExt (last path) == "index"
then pure $ Interface.lookup (init path) trieContent
else pure Nothing
Just (_,r) -> pure (Just r)
extractMatchAny :: MonadIO m
=> [T.Text]
-> RouterT r sec m a
-> m (Maybe r)
extractMatchAny path = extractNearestVia path (\x -> trieCatchAll <$> execRouterT x)
extractAuthSym :: MonadIO m
=> [T.Text]
-> RouterT x (SecurityToken sec) m a
-> m [sec]
extractAuthSym path hs = do
Tries{trieSecurity} <- execRouterT hs
liftIO . stToIO $ do
let results = Interface.matches path trieSecurity
pure $! foldr go [] results
where
go (_,SecurityToken _ DontProtectHere,[]) ys = ys
go (_,SecurityToken x _ ,_ ) ys = x:ys
extractAuth :: MonadIO m
=> MonadThrow m
=> (Request -> [sec] -> m ())
-> Request
-> RouterT x (SecurityToken sec) m a
-> m ()
extractAuth authorize req hs = do
ss <- extractAuthSym (pathInfo req) hs
authorize req ss
extractNearestVia :: MonadIO m
=> [T.Text]
-> (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)
where
mid (_,r,_) = r
trimFileExt :: T.Text -> T.Text
trimFileExt !s =
case T.breakOnEnd "." s of
(f,e) | f /= ""
&& e /= ""
&& T.length f > 0 -> T.dropEnd 1 f
_ -> s
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 f (t:|ts) xs = do
(HashMapChildren mx mxs) <- getFirst $ First (HM.lookup t xs)
<> First ( if null ts
then HM.lookup (f t) xs
else Nothing)
if null ts
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 f (t:|ts) (Pred predicate mx xs) = do
d <- predicate t
if null ts
then (([t],) . ($ d)) <$> mx
else bimap (t:) ($ d) <$> lookupWithLPT f (fromList ts) xs
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
tell' :: Monoid w => S.MonadState w m => w -> m ()
tell' x = S.modify' (<> x)