{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Web.Routing.Router where #if MIN_VERSION_base(4,8,0) #else import Control.Applicative #endif import Control.Monad.RWS.Strict import qualified Data.HashMap.Strict as HM import Data.Hashable import Data.Maybe import qualified Data.Text as T import Web.Routing.SafeRouting newtype RegistryT n b middleware reqTypes (m :: * -> *) a = RegistryT { forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. RegistryT n b middleware reqTypes m a -> RWST (PathInternal '[]) [middleware] (RegistryState n b reqTypes) m a runRegistryT :: RWST (PathInternal '[]) [middleware] (RegistryState n b reqTypes) m a } deriving ( Applicative (RegistryT n b middleware reqTypes m) Applicative (RegistryT n b middleware reqTypes m) => (forall a b. RegistryT n b middleware reqTypes m a -> (a -> RegistryT n b middleware reqTypes m b) -> RegistryT n b middleware reqTypes m b) -> (forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b) -> (forall a. a -> RegistryT n b middleware reqTypes m a) -> Monad (RegistryT n b middleware reqTypes m) forall a. a -> RegistryT n b middleware reqTypes m a forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b forall a b. RegistryT n b middleware reqTypes m a -> (a -> RegistryT n b middleware reqTypes m b) -> RegistryT n b middleware reqTypes 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 forall (n :: * -> *) b middleware reqTypes (m :: * -> *). Monad m => Applicative (RegistryT n b middleware reqTypes m) forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. Monad m => a -> RegistryT n b middleware reqTypes m a forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m a -> (a -> RegistryT n b middleware reqTypes m b) -> RegistryT n b middleware reqTypes m b $c>>= :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m a -> (a -> RegistryT n b middleware reqTypes m b) -> RegistryT n b middleware reqTypes m b >>= :: forall a b. RegistryT n b middleware reqTypes m a -> (a -> RegistryT n b middleware reqTypes m b) -> RegistryT n b middleware reqTypes m b $c>> :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b >> :: forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b $creturn :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. Monad m => a -> RegistryT n b middleware reqTypes m a return :: forall a. a -> RegistryT n b middleware reqTypes m a Monad, (forall a b. (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b) -> (forall a b. a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a) -> Functor (RegistryT n b middleware reqTypes m) forall a b. a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a forall a b. (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Functor m => a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Functor m => (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b $cfmap :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Functor m => (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b fmap :: forall a b. (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b $c<$ :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Functor m => a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a <$ :: forall a b. a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a Functor, Functor (RegistryT n b middleware reqTypes m) Functor (RegistryT n b middleware reqTypes m) => (forall a. a -> RegistryT n b middleware reqTypes m a) -> (forall a b. RegistryT n b middleware reqTypes m (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b) -> (forall a b c. (a -> b -> c) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m c) -> (forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b) -> (forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a) -> Applicative (RegistryT n b middleware reqTypes m) forall a. a -> RegistryT n b middleware reqTypes m a forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b forall a b. RegistryT n b middleware reqTypes m (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b forall a b c. (a -> b -> c) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes 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 (n :: * -> *) b middleware reqTypes (m :: * -> *). Monad m => Functor (RegistryT n b middleware reqTypes m) forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. Monad m => a -> RegistryT n b middleware reqTypes m a forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b c. Monad m => (a -> b -> c) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m c $cpure :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. Monad m => a -> RegistryT n b middleware reqTypes m a pure :: forall a. a -> RegistryT n b middleware reqTypes m a $c<*> :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b <*> :: forall a b. RegistryT n b middleware reqTypes m (a -> b) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b $cliftA2 :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b c. Monad m => (a -> b -> c) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m c liftA2 :: forall a b c. (a -> b -> c) -> RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m c $c*> :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b *> :: forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m b $c<* :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a b. Monad m => RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a <* :: forall a b. RegistryT n b middleware reqTypes m a -> RegistryT n b middleware reqTypes m b -> RegistryT n b middleware reqTypes m a Applicative, Monad (RegistryT n b middleware reqTypes m) Monad (RegistryT n b middleware reqTypes m) => (forall a. IO a -> RegistryT n b middleware reqTypes m a) -> MonadIO (RegistryT n b middleware reqTypes m) forall a. IO a -> RegistryT n b middleware reqTypes m a forall (m :: * -> *). Monad m => (forall a. IO a -> m a) -> MonadIO m forall (n :: * -> *) b middleware reqTypes (m :: * -> *). MonadIO m => Monad (RegistryT n b middleware reqTypes m) forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. MonadIO m => IO a -> RegistryT n b middleware reqTypes m a $cliftIO :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. MonadIO m => IO a -> RegistryT n b middleware reqTypes m a liftIO :: forall a. IO a -> RegistryT n b middleware reqTypes m a MonadIO, MonadReader (PathInternal '[]), MonadWriter [middleware], MonadState (RegistryState n b reqTypes), (forall (m :: * -> *). Monad m => Monad (RegistryT n b middleware reqTypes m)) => (forall (m :: * -> *) a. Monad m => m a -> RegistryT n b middleware reqTypes m a) -> MonadTrans (RegistryT n b middleware reqTypes) forall (m :: * -> *). Monad m => Monad (RegistryT n b middleware reqTypes m) forall (m :: * -> *) a. Monad m => m a -> RegistryT n b middleware reqTypes m a forall (n :: * -> *) b middleware reqTypes (m :: * -> *). Monad m => Monad (RegistryT n b middleware reqTypes m) forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. Monad m => m a -> RegistryT n b middleware reqTypes m a forall (t :: (* -> *) -> * -> *). (forall (m :: * -> *). Monad m => Monad (t m)) => (forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t $clift :: forall (n :: * -> *) b middleware reqTypes (m :: * -> *) a. Monad m => m a -> RegistryT n b middleware reqTypes m a lift :: forall (m :: * -> *) a. Monad m => m a -> RegistryT n b middleware reqTypes m a MonadTrans ) data RegistryState n b reqTypes = RegistryState { forall (n :: * -> *) b reqTypes. RegistryState n b reqTypes -> HashMap reqTypes (Registry n b) rs_registry :: !(HM.HashMap reqTypes (Registry n b)), forall (n :: * -> *) b reqTypes. RegistryState n b reqTypes -> Registry n b rs_anyMethod :: !(Registry n b) } hookAny :: (Monad m, Eq reqTypes, Hashable reqTypes) => reqTypes -> ([T.Text] -> n b) -> RegistryT n b middleware reqTypes m () hookAny :: forall (m :: * -> *) reqTypes (n :: * -> *) b middleware. (Monad m, Eq reqTypes, Hashable reqTypes) => reqTypes -> ([Text] -> n b) -> RegistryT n b middleware reqTypes m () hookAny reqTypes reqType [Text] -> n b action = (RegistryState n b reqTypes -> RegistryState n b reqTypes) -> RegistryT n b middleware reqTypes m () forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify ((RegistryState n b reqTypes -> RegistryState n b reqTypes) -> RegistryT n b middleware reqTypes m ()) -> (RegistryState n b reqTypes -> RegistryState n b reqTypes) -> RegistryT n b middleware reqTypes m () forall a b. (a -> b) -> a -> b $ \RegistryState n b reqTypes rs -> RegistryState n b reqTypes rs { rs_registry = let reg = (PathMap (n b), [[Text] -> n b]) -> Maybe (PathMap (n b), [[Text] -> n b]) -> (PathMap (n b), [[Text] -> n b]) forall a. a -> Maybe a -> a fromMaybe (PathMap (n b), [[Text] -> n b]) forall (m :: * -> *) a. Registry m a emptyRegistry (reqTypes -> HashMap reqTypes (PathMap (n b), [[Text] -> n b]) -> Maybe (PathMap (n b), [[Text] -> n b]) forall k v. Hashable k => k -> HashMap k v -> Maybe v HM.lookup reqTypes reqType (RegistryState n b reqTypes -> HashMap reqTypes (PathMap (n b), [[Text] -> n b]) forall (n :: * -> *) b reqTypes. RegistryState n b reqTypes -> HashMap reqTypes (Registry n b) rs_registry RegistryState n b reqTypes rs)) in HM.insert reqType (fallbackRoute action reg) (rs_registry rs) } hookAnyMethod :: (Monad m) => ([T.Text] -> n b) -> RegistryT n b middleware reqTypes m () hookAnyMethod :: forall (m :: * -> *) (n :: * -> *) b middleware reqTypes. Monad m => ([Text] -> n b) -> RegistryT n b middleware reqTypes m () hookAnyMethod [Text] -> n b action = (RegistryState n b reqTypes -> RegistryState n b reqTypes) -> RegistryT n b middleware reqTypes m () forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify ((RegistryState n b reqTypes -> RegistryState n b reqTypes) -> RegistryT n b middleware reqTypes m ()) -> (RegistryState n b reqTypes -> RegistryState n b reqTypes) -> RegistryT n b middleware reqTypes m () forall a b. (a -> b) -> a -> b $ \RegistryState n b reqTypes rs -> RegistryState n b reqTypes rs { rs_anyMethod = fallbackRoute action (rs_anyMethod rs) } hookRoute :: (Monad m, Eq reqTypes, Hashable reqTypes) => reqTypes -> PathInternal as -> HVectElim' (n b) as -> RegistryT n b middleware reqTypes m () hookRoute :: forall (m :: * -> *) reqTypes (as :: [*]) (n :: * -> *) b middleware. (Monad m, Eq reqTypes, Hashable reqTypes) => reqTypes -> PathInternal as -> HVectElim' (n b) as -> RegistryT n b middleware reqTypes m () hookRoute reqTypes reqType PathInternal as path HVectElim' (n b) as action = do basePath <- RegistryT n b middleware reqTypes m (PathInternal '[]) forall r (m :: * -> *). MonadReader r m => m r ask modify $ \RegistryState n b reqTypes rs -> RegistryState n b reqTypes rs { rs_registry = let reg = (PathMap (n b), [[Text] -> n b]) -> Maybe (PathMap (n b), [[Text] -> n b]) -> (PathMap (n b), [[Text] -> n b]) forall a. a -> Maybe a -> a fromMaybe (PathMap (n b), [[Text] -> n b]) forall (m :: * -> *) a. Registry m a emptyRegistry (reqTypes -> HashMap reqTypes (PathMap (n b), [[Text] -> n b]) -> Maybe (PathMap (n b), [[Text] -> n b]) forall k v. Hashable k => k -> HashMap k v -> Maybe v HM.lookup reqTypes reqType (RegistryState n b reqTypes -> HashMap reqTypes (PathMap (n b), [[Text] -> n b]) forall (n :: * -> *) b reqTypes. RegistryState n b reqTypes -> HashMap reqTypes (Registry n b) rs_registry RegistryState n b reqTypes rs)) reg' = PathInternal as -> HVectElim' (n b) as -> (PathMap (n b), [[Text] -> n b]) -> (PathMap (n b), [[Text] -> n b]) forall (xs :: [*]) (m :: * -> *) a. PathInternal xs -> HVectElim' (m a) xs -> Registry m a -> Registry m a defRoute (PathInternal '[] basePath PathInternal '[] -> PathInternal as -> PathInternal (Append '[] as) forall (as :: [*]) (bs :: [*]). PathInternal as -> PathInternal bs -> PathInternal (Append as bs) </!> PathInternal as path) HVectElim' (n b) as action (PathMap (n b), [[Text] -> n b]) reg in HM.insert reqType reg' (rs_registry rs) } hookRouteAnyMethod :: (Monad m) => PathInternal as -> HVectElim' (n b) as -> RegistryT n b middleware reqTypes m () hookRouteAnyMethod :: forall (m :: * -> *) (as :: [*]) (n :: * -> *) b middleware reqTypes. Monad m => PathInternal as -> HVectElim' (n b) as -> RegistryT n b middleware reqTypes m () hookRouteAnyMethod PathInternal as path HVectElim' (n b) as action = do basePath <- RegistryT n b middleware reqTypes m (PathInternal '[]) forall r (m :: * -> *). MonadReader r m => m r ask modify $ \RegistryState n b reqTypes rs -> RegistryState n b reqTypes rs { rs_anyMethod = defRoute (basePath </!> path) action (rs_anyMethod rs) } middleware :: Monad m => middleware -> RegistryT n b middleware reqTypes m () middleware :: forall (m :: * -> *) middleware (n :: * -> *) b reqTypes. Monad m => middleware -> RegistryT n b middleware reqTypes m () middleware middleware x = [middleware] -> RegistryT n b middleware reqTypes m () forall w (m :: * -> *). MonadWriter w m => w -> m () tell [middleware x] swapMonad :: Monad m => (forall b. n b -> m b) -> RegistryT x y middleware reqTypes n a -> RegistryT x y middleware reqTypes m a swapMonad :: forall (m :: * -> *) (n :: * -> *) (x :: * -> *) y middleware reqTypes a. Monad m => (forall b. n b -> m b) -> RegistryT x y middleware reqTypes n a -> RegistryT x y middleware reqTypes m a swapMonad forall b. n b -> m b liftLower (RegistryT RWST (PathInternal '[]) [middleware] (RegistryState x y reqTypes) n a subReg) = do parentSt <- RegistryT x y middleware reqTypes m (RegistryState x y reqTypes) forall s (m :: * -> *). MonadState s m => m s get basePath <- ask (a, parentSt', middleware') <- lift $ liftLower $ runRWST subReg basePath parentSt put parentSt' tell middleware' return a runRegistry :: (Monad m, Hashable reqTypes, Eq reqTypes) => RegistryT n b middleware reqTypes m a -> m (a, reqTypes -> [T.Text] -> [n b], [middleware]) runRegistry :: forall (m :: * -> *) reqTypes (n :: * -> *) b middleware a. (Monad m, Hashable reqTypes, Eq reqTypes) => RegistryT n b middleware reqTypes m a -> m (a, reqTypes -> [Text] -> [n b], [middleware]) runRegistry (RegistryT RWST (PathInternal '[]) [middleware] (RegistryState n b reqTypes) m a rwst) = do (val, st, w) <- RWST (PathInternal '[]) [middleware] (RegistryState n b reqTypes) m a -> PathInternal '[] -> RegistryState n b reqTypes -> m (a, RegistryState n b reqTypes, [middleware]) forall r w s (m :: * -> *) a. RWST r w s m a -> r -> s -> m (a, s, w) runRWST RWST (PathInternal '[]) [middleware] (RegistryState n b reqTypes) m a rwst PathInternal '[] PI_Empty RegistryState n b reqTypes forall {n :: * -> *} {b} {reqTypes}. RegistryState n b reqTypes initSt return (val, handleF (rs_anyMethod st) (rs_registry st), w) where handleF :: (PathMap (m a), [[Text] -> m a]) -> HashMap k (PathMap (m a), [[Text] -> m a]) -> k -> [Text] -> [m a] handleF (PathMap (m a), [[Text] -> m a]) anyReg HashMap k (PathMap (m a), [[Text] -> m a]) hm k ty [Text] route = let froute :: [Text] froute = (Text -> Bool) -> [Text] -> [Text] forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Bool T.null) [Text] route in case k -> HashMap k (PathMap (m a), [[Text] -> m a]) -> Maybe (PathMap (m a), [[Text] -> m a]) forall k v. Hashable k => k -> HashMap k v -> Maybe v HM.lookup k ty HashMap k (PathMap (m a), [[Text] -> m a]) hm of Maybe (PathMap (m a), [[Text] -> m a]) Nothing -> (PathMap (m a), [[Text] -> m a]) -> [Text] -> [m a] forall (m :: * -> *) a. Registry m a -> [Text] -> [m a] matchRoute (PathMap (m a), [[Text] -> m a]) anyReg [Text] froute Just (PathMap (m a), [[Text] -> m a]) registry -> ((PathMap (m a), [[Text] -> m a]) -> [Text] -> [m a] forall (m :: * -> *) a. Registry m a -> [Text] -> [m a] matchRoute (PathMap (m a), [[Text] -> m a]) registry [Text] froute [m a] -> [m a] -> [m a] forall a. [a] -> [a] -> [a] ++ (PathMap (m a), [[Text] -> m a]) -> [Text] -> [m a] forall (m :: * -> *) a. Registry m a -> [Text] -> [m a] matchRoute (PathMap (m a), [[Text] -> m a]) anyReg [Text] froute) initSt :: RegistryState n b reqTypes initSt = RegistryState { rs_registry :: HashMap reqTypes (Registry n b) rs_registry = HashMap reqTypes (Registry n b) forall k v. HashMap k v HM.empty, rs_anyMethod :: Registry n b rs_anyMethod = Registry n b forall (m :: * -> *) a. Registry m a emptyRegistry }