103 lines
4.0 KiB
Haskell
103 lines
4.0 KiB
Haskell
module Utils.Lang where
|
|
|
|
import ClassyPrelude.Yesod
|
|
|
|
import Utils.Cookies.Registered
|
|
import Utils.Parameters
|
|
import Utils.Session
|
|
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import qualified Data.List as List
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Yesod.Core.Types (HandlerData(handlerRequest))
|
|
import qualified Network.Wai.Parse as NWP
|
|
|
|
import Control.Monad.Trans.Maybe (MaybeT(..))
|
|
import Control.Monad.Reader.Class (local)
|
|
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
import Data.Containers.ListUtils
|
|
|
|
isDe :: Lang -> Bool
|
|
isDe = isPrefixOf "de"
|
|
|
|
isEn :: Lang -> Bool
|
|
isEn = isPrefixOf "en"
|
|
|
|
selectLanguage :: MonadHandler m
|
|
=> NonEmpty Lang -- ^ Available translations, first is default
|
|
-> m Lang
|
|
selectLanguage avL = selectLanguage' avL <$> languages
|
|
|
|
selectLanguage' :: NonEmpty Lang -- ^ Available translations, first is default
|
|
-> [Lang] -- ^ Languages in preference order
|
|
-> Lang
|
|
selectLanguage' avL ls = NonEmpty.head $ selectLanguages avL ls
|
|
|
|
selectLanguages :: NonEmpty Lang -> [Lang] -> NonEmpty Lang
|
|
selectLanguages (defL :| _) [] = defL :| []
|
|
selectLanguages avL (l:ls)
|
|
| not $ null l
|
|
, Just lParts <- nonEmpty $ matchesFor l
|
|
, found <- nubOrd
|
|
[ l'' | lParts' <- NonEmpty.toList lParts
|
|
, l' <- NonEmpty.toList avL
|
|
, l'' <- matchesFor l'
|
|
, langMatches lParts' l''
|
|
]
|
|
= let now = nonEmpty $ sortOn (Down . length) found
|
|
others = selectLanguages avL ls
|
|
in maybe id (\now' others' -> NonEmpty.fromList $ toList now' ++ filter (`notElem` toList now') (toList others')) now others
|
|
| otherwise = selectLanguages avL ls
|
|
|
|
langMatches :: Lang -- ^ Needle
|
|
-> Lang -- ^ Haystack
|
|
-> Bool
|
|
langMatches (CI.foldCase -> needle) (CI.foldCase -> haystack) = needle `elem` matchesFor haystack
|
|
|
|
matchesFor :: Lang -> [Lang]
|
|
matchesFor = mapMaybe (\frags -> Text.intercalate "-" frags <$ guard (not $ null frags)) . reverse . List.inits . Text.splitOn "-"
|
|
|
|
|
|
highPrioRequestedLangs, lowPrioRequestedLangs :: forall m. MonadHandler m => m [Lang]
|
|
highPrioRequestedLangs = fmap (concatMap $ fromMaybe []) . mapM runMaybeT $
|
|
[ lookupGlobalGetParams GetLang
|
|
, lookupRegisteredCookies pure CookieLang
|
|
, fmap pure . MaybeT $ lookupSessionKey SessionLang
|
|
]
|
|
lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader hAcceptLanguage
|
|
|
|
languagesMiddleware :: forall site a. NonEmpty Lang -> HandlerFor site a -> HandlerFor site a
|
|
languagesMiddleware avL act = do
|
|
pLangs <- fmap nubOrd $ (<>) <$> highPrioRequestedLangs <*> lowPrioRequestedLangs
|
|
let langs = toList $ selectLanguages avL pLangs
|
|
setLangs hData = hData{ handlerRequest = (handlerRequest hData){ reqLangs = langs } }
|
|
local setLangs $ ($logDebugS "languages" . tshow . (pLangs,langs,) =<< languages) *> act
|
|
|
|
|
|
renderMessageDispatch :: forall msg site.
|
|
Lang -- ^ Default language
|
|
-> (site -> [Lang] -> msg -> Text) -- ^ Default renderer
|
|
-> HashMap Lang (Either (site -> [Lang] -> msg -> Maybe Text) (site -> [Lang] -> msg -> Text)) -- ^ All renderers
|
|
-> site -> [Lang] -> msg -> Text
|
|
renderMessageDispatch defLang defRender extraRenders app langs msg = go $ selectLanguages avLangs langs
|
|
where
|
|
avLangs = defLang :| HashMap.keys extraRenders
|
|
|
|
go (l :| []) = case HashMap.lookup l extraRenders of
|
|
Nothing -> defRender app langs msg
|
|
Just (Left pRender) -> fromMaybe (defRender app langs msg) $ pRender app langs msg
|
|
Just (Right tRender) -> tRender app langs msg
|
|
go (l1 :| l2 : ls) = case HashMap.lookup l1 extraRenders of
|
|
Nothing -> go (l2 :| ls)
|
|
Just (Left pRender) -> fromMaybe (go $ l2 :| ls) $ pRender app langs msg
|
|
Just (Right tRender) -> tRender app langs msg
|
|
{-# INLINE renderMessageDispatch #-}
|