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

Add support for the lang parameter and cookie

parent b7098b2f
Branches
Tags
No related merge requests found
...@@ -24,6 +24,7 @@ module Web.Hikaru.Action ...@@ -24,6 +24,7 @@ module Web.Hikaru.Action
, getAcceptCharset , getAcceptCharset
, getAcceptEncoding , getAcceptEncoding
, getAcceptLanguage , getAcceptLanguage
, getLanguages
, getContentType , getContentType
, getPathInfo , getPathInfo
, getPathInfoRaw , getPathInfoRaw
...@@ -314,6 +315,29 @@ where ...@@ -314,6 +315,29 @@ where
<$> getHeaderMaybe hAcceptLanguage <$> 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 -- Obtain the Content-Type header value or the default value of
-- @\"application/octet-stream\"@ (true, but meaningless). -- @\"application/octet-stream\"@ (true, but meaningless).
......
...@@ -46,7 +46,6 @@ where ...@@ -46,7 +46,6 @@ where
import Data.Text (Text) import Data.Text (Text)
import Lucid import Lucid
import Web.Hikaru.Action import Web.Hikaru.Action
import Web.Hikaru.Media
-- | -- |
...@@ -72,15 +71,12 @@ where ...@@ -72,15 +71,12 @@ where
-- | -- |
-- Localize given message to the language indicated by the -- Localize given message to the language indicated by the 'getLanguages'
-- 'getAcceptLanguage' function executed in the context of -- function executed in the context of the current action.
-- the current action.
-- --
lc_ :: (MonadAction m, Localized a) => a -> HtmlT m () lc_ :: (MonadAction m, Localized a) => a -> HtmlT m ()
lc_ msg = do lc_ msg = do
langs <- getAcceptLanguage langs <- getLanguages
<&> filter ((> 0) . mediaQuality)
<&> map mediaMainType
case mapMaybe (flip localize msg) langs of case mapMaybe (flip localize msg) langs of
[] -> toHtml msg [] -> toHtml msg
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment