module Network.Wai.Middleware.Routes.Monad
(
RouteM
, middleware
, route
, catchall
, defaultAction
, waiApp
, toWaiApp
)
where
import Network.Wai
import Network.Wai.Middleware.Routes.Routes
import Network.HTTP.Types
import Control.Applicative (Applicative, (<*>), pure)
newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r }
instance Functor f => Functor (F f) where
fmap f (F g) = F (\kp -> g (kp . f))
instance Functor f => Applicative (F f) where
pure a = F (\kp _ -> kp a)
F f <*> F g = F (\kp kf -> f (\a -> g (kp . a) kf) kf)
instance Functor f => Monad (F f) where
return a = F (\kp _ -> kp a)
F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf)
wrap :: Functor f => f (F f a) -> F f a
wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f))
liftF :: Functor f => f a -> F f a
liftF = wrap . fmap return
data RouterF x = M Middleware x | D Application deriving Functor
type RouteM = F RouterF
catchall :: Application -> RouteM ()
catchall a = liftF $ D a
defaultAction :: Application -> RouteM ()
defaultAction = catchall
middleware :: Middleware -> RouteM ()
middleware m = liftF $ M m ()
route :: (Routable master master) => master -> RouteM ()
route = middleware . routeDispatch
defaultApplication :: Application
defaultApplication _req h = h $ responseLBS status404 [("Content-Type", "text/plain")] "Error : 404 - Document not found"
waiApp :: RouteM () -> Application
waiApp (F r) = r (const defaultApplication) f
where
f (M m r) = m r
f (D a) = a
toWaiApp :: Monad m => RouteM () -> m Application
toWaiApp = return . waiApp