module Network.Wai.Middleware.Routes.Routes
(
parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, mkRoute
, routeDispatch
, showRoute
, Handler
, Routable(..)
, RenderRoute(..)
)
where
import Network.Wai (Middleware, Application, pathInfo, requestMethod)
import Network.HTTP.Types (StdMethod(GET), parseMethod)
import Yesod.Routes.Class (Route, RenderRoute(..))
import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)
import Yesod.Routes.TH (mkRenderRouteInstance, mkDispatchClause, ResourceTree(..))
import qualified Data.Text as T
import Data.Text (Text)
import Language.Haskell.TH.Syntax
mkRoute :: String -> [ResourceTree String] -> Q [Dec]
mkRoute typName routes = do
let typ = parseType typName
inst <- mkRenderRouteInstance typ $ map (fmap parseType) routes
disp <- mkDispatchClause [|runHandler|] [|dispatcher|] [|id|] routes
return $ InstanceD []
(ConT ''Routable `AppT` typ)
[FunD (mkName "dispatcher") [disp]]
: inst
type Handler master = master -> Application
runHandler
:: Handler master
-> master
-> master
-> Maybe (Route master)
-> (Route master -> Route master)
-> Handler master
runHandler h _ _ _ _ = h
class Routable master where
dispatcher
:: master
-> master
-> (Route master -> Route master)
-> Handler master
-> (Route master -> Handler master)
-> Text
-> [Text]
-> Handler master
routeDispatch :: Routable master => master -> Middleware
routeDispatch master def req = app master req
where
app = dispatcher master master id def404 def405 (T.pack $ show $ method req) (pathInfo req)
def404 = const def
def405 = const $ const def
method req' = case parseMethod $ requestMethod req' of
Right m -> m
Left _ -> GET
showRoute :: RenderRoute master => Route master -> Text
showRoute = T.intercalate (T.pack "/") . (T.pack "" :) . fst . renderRoute