{-# LANGUAGE
DeriveFunctor
, ConstraintKinds
, TypeFamilies
, FlexibleContexts
, GeneralizedNewtypeDeriving
#-}
module Web.Routes.Nested.Types
(
Tries (..)
,
RouterT (..)
, execRouterT
, ActionT
, action
,
ExtrudeSoundly
) where
import Web.Routes.Nested.Match (UrlChunks)
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)
import Data.Monoid ((<>))
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 (liftBaseWith))
data Tries x s = Tries
{ forall x s. Tries x s -> RootedPredTrie Text x
trieContent :: !(RootedPredTrie T.Text x)
, forall x s. Tries x s -> RootedPredTrie Text x
trieCatchAll :: !(RootedPredTrie T.Text x)
, forall x s. Tries x s -> RootedPredTrie Text s
trieSecurity :: !(RootedPredTrie T.Text s)
}
instance Semigroup (Tries x s) where
(Tries RootedPredTrie Text x
x1 RootedPredTrie Text x
x2 RootedPredTrie Text s
x3) <> :: Tries x s -> Tries x s -> Tries x s
<> (Tries RootedPredTrie Text x
y1 RootedPredTrie Text x
y2 RootedPredTrie Text s
y3) =
forall x s.
RootedPredTrie Text x
-> RootedPredTrie Text x -> RootedPredTrie Text s -> Tries x s
Tries (RootedPredTrie Text x
x1 forall a. Semigroup a => a -> a -> a
<> RootedPredTrie Text x
y1) (RootedPredTrie Text x
x2 forall a. Semigroup a => a -> a -> a
<> RootedPredTrie Text x
y2) (RootedPredTrie Text s
x3 forall a. Semigroup a => a -> a -> a
<> RootedPredTrie Text s
y3)
instance Monoid (Tries x s) where
mempty :: Tries x s
mempty = forall x s.
RootedPredTrie Text x
-> RootedPredTrie Text x -> RootedPredTrie Text s -> Tries x s
Tries forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
newtype RouterT x sec m a = RouterT
{ forall x sec (m :: * -> *) a.
RouterT x sec m a -> StateT (Tries x sec) m a
runRouterT :: S.StateT (Tries x sec) m a
} deriving ( forall a b. a -> RouterT x sec m b -> RouterT x sec m a
forall a b. (a -> b) -> RouterT x sec m a -> RouterT x sec m b
forall x sec (m :: * -> *) a b.
Functor m =>
a -> RouterT x sec m b -> RouterT x sec m a
forall x sec (m :: * -> *) a b.
Functor m =>
(a -> b) -> RouterT x sec m a -> RouterT x sec m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RouterT x sec m b -> RouterT x sec m a
$c<$ :: forall x sec (m :: * -> *) a b.
Functor m =>
a -> RouterT x sec m b -> RouterT x sec m a
fmap :: forall a b. (a -> b) -> RouterT x sec m a -> RouterT x sec m b
$cfmap :: forall x sec (m :: * -> *) a b.
Functor m =>
(a -> b) -> RouterT x sec m a -> RouterT x sec m b
Functor, forall a. a -> RouterT x sec m a
forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m a
forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
forall a b.
RouterT x sec m (a -> b) -> RouterT x sec m a -> RouterT x sec m b
forall a b c.
(a -> b -> c)
-> RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m c
forall {x} {sec} {m :: * -> *}.
Monad m =>
Functor (RouterT x sec m)
forall x sec (m :: * -> *) a. Monad m => a -> RouterT x sec m a
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m a
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m (a -> b) -> RouterT x sec m a -> RouterT x sec m b
forall x sec (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m a
$c<* :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m a
*> :: forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
$c*> :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
liftA2 :: forall a b c.
(a -> b -> c)
-> RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m c
$cliftA2 :: forall x sec (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m c
<*> :: forall a b.
RouterT x sec m (a -> b) -> RouterT x sec m a -> RouterT x sec m b
$c<*> :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m (a -> b) -> RouterT x sec m a -> RouterT x sec m b
pure :: forall a. a -> RouterT x sec m a
$cpure :: forall x sec (m :: * -> *) a. Monad m => a -> RouterT x sec m a
Applicative, forall a. a -> RouterT x sec m a
forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
forall a b.
RouterT x sec m a -> (a -> RouterT x sec m b) -> RouterT x sec m b
forall x sec (m :: * -> *).
Monad m =>
Applicative (RouterT x sec m)
forall x sec (m :: * -> *) a. Monad m => a -> RouterT x sec m a
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> (a -> RouterT x sec m b) -> RouterT x sec m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> RouterT x sec m a
$creturn :: forall x sec (m :: * -> *) a. Monad m => a -> RouterT x sec m a
>> :: forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
$c>> :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
>>= :: forall a b.
RouterT x sec m a -> (a -> RouterT x sec m b) -> RouterT x sec m b
$c>>= :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> (a -> RouterT x sec m b) -> RouterT x sec m b
Monad, forall a. IO a -> RouterT x sec m a
forall {x} {sec} {m :: * -> *}.
MonadIO m =>
Monad (RouterT x sec m)
forall x sec (m :: * -> *) a.
MonadIO m =>
IO a -> RouterT x sec m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> RouterT x sec m a
$cliftIO :: forall x sec (m :: * -> *) a.
MonadIO m =>
IO a -> RouterT x sec m a
MonadIO, forall x sec (m :: * -> *) a. Monad m => m a -> RouterT x sec m a
forall (m :: * -> *) a. Monad m => m a -> RouterT x sec m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> RouterT x sec m a
$clift :: forall x sec (m :: * -> *) a. Monad m => m a -> RouterT x sec m a
MonadTrans
, S.MonadState (Tries x sec))
execRouterT :: Monad m => RouterT x sec m a -> m (Tries x sec)
execRouterT :: forall (m :: * -> *) x sec a.
Monad m =>
RouterT x sec m a -> m (Tries x sec)
execRouterT RouterT x sec m a
hs = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
S.execStateT (forall x sec (m :: * -> *) a.
RouterT x sec m a -> StateT (Tries x sec) m a
runRouterT RouterT x sec m a
hs) forall a. Monoid a => a
mempty
{-# INLINEABLE execRouterT #-}
type ExtrudeSoundly xs' xs c r =
( xs' ~ CatMaybes xs
, ArityTypeListIso c xs' r
, Extrude (UrlChunks xs)
(RootedPredTrie T.Text c)
(RootedPredTrie T.Text r)
)
type ActionT urlbase m a = VerbListenerT (FileExtListenerT urlbase m a) m a
action :: MonadBaseControl IO m stM
=> Extractable stM
=> ActionT urlbase m ()
-> MiddlewareT m
action :: forall (m :: * -> *) (stM :: * -> *) urlbase.
(MonadBaseControl IO m stM, Extractable stM) =>
ActionT urlbase m () -> MiddlewareT m
action ActionT urlbase m ()
xs ApplicationT m
app Request
req Response -> m ResponseReceived
respond = do
VerbMap (FileExtListenerT urlbase m ())
vmap <- forall (m :: * -> *) r a.
Monad m =>
VerbListenerT r m a -> m (VerbMap r)
execVerbListenerT ActionT urlbase m ()
xs
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Request -> Verb
getVerbFromRequest Request
req) VerbMap (FileExtListenerT urlbase m ())
vmap of
Maybe
(Either
(FileExtListenerT urlbase m ())
(ByteString -> FileExtListenerT urlbase m ()))
Nothing -> ApplicationT m
app Request
req Response -> m ResponseReceived
respond
Just Either
(FileExtListenerT urlbase m ())
(ByteString -> FileExtListenerT urlbase m ())
eR -> do
FileExtListenerT urlbase m ()
c <- case Either
(FileExtListenerT urlbase m ())
(ByteString -> FileExtListenerT urlbase m ())
eR of
Left FileExtListenerT urlbase m ()
c' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FileExtListenerT urlbase m ()
c'
Right ByteString -> FileExtListenerT urlbase m ()
f -> ByteString -> FileExtListenerT urlbase m ()
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith (\RunInBase m IO stM
_ -> Request -> IO ByteString
strictRequestBody Request
req)
forall (m :: * -> *) (stM :: * -> *) urlbase a.
(MonadBaseControl IO m stM, Extractable stM) =>
FileExtListenerT urlbase m a -> MiddlewareT m
fileExtsToMiddleware FileExtListenerT urlbase m ()
c ApplicationT m
app Request
req Response -> m ResponseReceived
respond