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