diff --git a/lib/Web/Hikaru/Action.hs b/lib/Web/Hikaru/Action.hs index c3c0b61aa558fd52f9e990d17ee2c142392c65d8..ad72e4b97cb5aa2beac25aaef2352ee1a92697fc 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 e5d9ad732557e3412d6984ded50b1b70e7e34cc5..2d99999736a4af035343580956dd4768c2d6aac6 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