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
{ trieContent :: !(RootedPredTrie T.Text x)
, trieCatchAll :: !(RootedPredTrie T.Text x)
, trieSecurity :: !(RootedPredTrie T.Text s)
}
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)
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))
execRouterT :: Monad m => RouterT x sec m a -> m (Tries x sec)
execRouterT hs = S.execStateT (runRouterT hs) mempty
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 m a = VerbListenerT (FileExtListenerT m a) m a
action :: MonadBaseControl IO m stM
=> Extractable stM
=> ActionT m ()
-> MiddlewareT m
action xs app req respond = do
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