70 lines
2.7 KiB
Haskell
70 lines
2.7 KiB
Haskell
module Utils.Lang where
|
|
|
|
import ClassyPrelude.Yesod
|
|
|
|
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)
|
|
|
|
|
|
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 <- List.nub
|
|
[ 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 $
|
|
[ lookupGetParams "_LANG"
|
|
, lookupCookies "_LANG"
|
|
, fmap pure . MaybeT $ lookupSession "_LANG"
|
|
]
|
|
lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.decodeUtf8') . NWP.parseHttpAccept) <$> lookupHeader "Accept-Language"
|
|
|
|
languagesMiddleware :: forall site a. NonEmpty Lang -> HandlerFor site a -> HandlerFor site a
|
|
languagesMiddleware avL act = do
|
|
pLangs <- fmap List.nub $ (<>) <$> 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
|