Skip to content
Snippets Groups Projects
Verified Commit 3b8108dd authored by jan.hamal.dvorak's avatar jan.hamal.dvorak
Browse files

Add a shortcut for route declaration

parent 420c0c59
No related branches found
No related tags found
No related merge requests found
......@@ -19,6 +19,7 @@ module Hikaru.Route
-- ** Path Matching
, seg
, (</)
, arg
, argWith
, rest
......@@ -228,6 +229,13 @@ where
else Nothing
-- |
-- Shortcut to append a path segment in a more readable way.
--
(</) :: Route a -> Text -> Route a
(</) r t = r <* seg t
-- |
-- Match, parse and return following path segment.
--
......
......@@ -105,7 +105,7 @@ where
runAction :: ModelEnv -> Action () -> Application
runAction me act = do
respond $ \ae -> do
respond \ae -> do
runReaderT (unAction act) (DemoEnv ae me)
......@@ -115,23 +115,30 @@ where
-- Register nicer 404 error handler.
handler NotFound handleNotFound
-- Read configuration from environment.
wrapActions (updateConfigFromEnv >>)
-- Negotiate content for the root page.
route $ getRootHtmlR <$ get <* offerHTML
route $ getRootTextR <$ get <* offerText
-- Disable caching for all the following endpoints.
-- Disable caching for these endpoints:
wrapAction (defaultHeader hCacheControl "no-store" >>) do
-- Present a simple greeting page.
route $ getHelloR <$ get <* seg "hello" <*> arg
route $ getHelloR <$ get </ "hello" <*> arg
<* offerText
-- Present an echoing JSON API.
route $ postEchoR <$ post <* seg "api" <* seg "echo"
route $ postEchoR <$ post </ "api" </ "echo"
<* offerJSON <* acceptJSON
-- Case handling.
route $ postCaseR <$ post <* seg "case" <* seg "" <* acceptForm
route $ getCasesR <$ get <* seg "case" <* seg "" <* offerJSON
-- Handle new cases.
route $ postCaseR <$ post </ "case" </ ""
<* acceptForm
-- Handle case listing.
route $ getCasesR <$ get </ "case" </ ""
<* offerJSON
-- Handlers ----------------------------------------------------------------
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment