From 3b8108ddca2e3aa5152170da9af0ca1282c548f6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Sat, 26 Sep 2020 20:35:22 +0200
Subject: [PATCH] Add a shortcut for route declaration
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>
---
lib/Hikaru/Route.hs | 8 ++++++++
test/Hikaru/Demo.hs | 21 ++++++++++++++-------
2 files changed, 22 insertions(+), 7 deletions(-)
diff --git a/lib/Hikaru/Route.hs b/lib/Hikaru/Route.hs
index fe8742f..e8902e1 100644
--- a/lib/Hikaru/Route.hs
+++ b/lib/Hikaru/Route.hs
@@ -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.
--
diff --git a/test/Hikaru/Demo.hs b/test/Hikaru/Demo.hs
index 4bc1e73..437b7b1 100644
--- a/test/Hikaru/Demo.hs
+++ b/test/Hikaru/Demo.hs
@@ -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 ----------------------------------------------------------------
--
GitLab