From f497e8275571704eb49d0b6b2de37f637f3c2b61 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Wed, 8 May 2019 00:50:02 +0200
Subject: [PATCH] Add support for the lang parameter and cookie
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/Web/Hikaru/Action.hs | 24 ++++++++++++++++++++++++
lib/Web/Hikaru/Locale.hs | 10 +++-------
2 files changed, 27 insertions(+), 7 deletions(-)
diff --git a/lib/Web/Hikaru/Action.hs b/lib/Web/Hikaru/Action.hs
index c3c0b61..ad72e4b 100644
--- a/lib/Web/Hikaru/Action.hs
+++ b/lib/Web/Hikaru/Action.hs
@@ -24,6 +24,7 @@ module Web.Hikaru.Action
, getAcceptCharset
, getAcceptEncoding
, getAcceptLanguage
+ , getLanguages
, getContentType
, getPathInfo
, getPathInfoRaw
@@ -314,6 +315,29 @@ where
<$> getHeaderMaybe hAcceptLanguage
+ -- |
+ -- Return list of best languages based on the current value of the @lang@
+ -- query string parameter or @lang@ cookie followed by whatever the
+ -- 'getAcceptLanguage' returns.
+ --
+ -- If the @lang@ query string parameter was supplied, also sets the @lang@
+ -- cookie so that the selection is more permanent.
+ --
+ getLanguages :: (MonadAction m) => m [Text]
+ getLanguages = do
+ preferred <- getParamMaybe "lang"
+ previous <- getCookieMaybe "lang"
+ acceptable <- getAcceptLanguage
+ <&> filter ((> 0) . mediaQuality)
+ <&> map mediaMainType
+
+ case preferred of
+ Nothing -> return ()
+ Just lang -> setCookie "lang" (cs lang)
+
+ return $ nub $ maybeToList preferred <> maybeToList previous <> acceptable
+
+
-- |
-- Obtain the Content-Type header value or the default value of
-- @\"application/octet-stream\"@ (true, but meaningless).
diff --git a/lib/Web/Hikaru/Locale.hs b/lib/Web/Hikaru/Locale.hs
index e5d9ad7..2d99999 100644
--- a/lib/Web/Hikaru/Locale.hs
+++ b/lib/Web/Hikaru/Locale.hs
@@ -46,7 +46,6 @@ where
import Data.Text (Text)
import Lucid
import Web.Hikaru.Action
- import Web.Hikaru.Media
-- |
@@ -72,15 +71,12 @@ where
-- |
- -- Localize given message to the language indicated by the
- -- 'getAcceptLanguage' function executed in the context of
- -- the current action.
+ -- Localize given message to the language indicated by the 'getLanguages'
+ -- function executed in the context of the current action.
--
lc_ :: (MonadAction m, Localized a) => a -> HtmlT m ()
lc_ msg = do
- langs <- getAcceptLanguage
- <&> filter ((> 0) . mediaQuality)
- <&> map mediaMainType
+ langs <- getLanguages
case mapMaybe (flip localize msg) langs of
[] -> toHtml msg
--
GitLab