{-# LANGUAGE OverloadedStrings, TypeFamilies, RankNTypes, DeriveFunctor #-}
module Routes.Monad
(
RouteM
, DefaultMaster(..)
, Route(DefaultRoute)
, handler
, middleware
, route
, catchall
, defaultAction
, waiApp
, toWaiApp
)
where
import Network.Wai
import Routes.Routes
import Routes.DefaultRoute
import Network.HTTP.Types (status404)
import Util.Free (F(..), liftF)
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 ()
handler :: HandlerS DefaultMaster DefaultMaster -> RouteM ()
handler h = middleware $ customRouteDispatch dispatcher' DefaultMaster
where
dispatcher' env req = runHandler h env (Just $ DefaultRoute $ getRoute req) req
getRoute req = (pathInfo $ waiReq req, readQueryString $ queryString $ waiReq req)
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