fix(i18n): custom language inference

messages/frontend/de-de-formal.msg

@@ -1,4 +1,4 @@
 FilesSelected: Dateien ausgewählt
 SelectFile: Datei auswählen
 SelectFiles: Datei(en) auswählen
-AsyncFormFailure: Da ist etwas schief gelaufen, das tut uns Leid. Falls das erneut passiert schicke uns gerne eine kurze Beschreibung dieses Ereignisses über das Hilfe-Widget rechts oben. Vielen Dank für deine Hilfe!
+AsyncFormFailure: Da ist etwas schief gelaufen, das tut uns Leid. Falls das erneut passiert schicken Sie uns bitte eine kurze Beschreibung dieses Ereignisses über das Hilfe-Widget rechts oben. Vielen Dank für Ihre Hilfe!

src/Foundation.hs

@@ -253,12 +253,12 @@ maybeToMessage _      Nothing  _     = mempty
 maybeToMessage before (Just x) after = before <> (toMessage x) <> after
 
 -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
-mkMessage "UniWorX" "messages/uniworx" "de"
+mkMessage "UniWorX" "messages/uniworx" "de-de-formal"
 mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
 mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
 mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
 mkMessageVariant "UniWorX" "Button" "messages/button" "de"
-mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de"
+mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de-de-formal"
 
 instance RenderMessage UniWorX TermIdentifier where
   renderMessage foundation ls TermIdentifier{..} = case season of
@@ -299,11 +299,11 @@ instance RenderMessage UniWorX Load where
 newtype MsgLanguage = MsgLanguage Lang
   deriving (Eq, Ord, Show, Read)
 instance RenderMessage UniWorX MsgLanguage where
-  renderMessage foundation ls (MsgLanguage lang@(Text.splitOn "-" -> lang'))
+  renderMessage foundation ls (MsgLanguage lang@(map mk . Text.splitOn "-" -> lang'))
-    | ["de", "DE"] <- lang' = mr MsgGermanGermany
+    | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
-    | ("de" : _)   <- lang' = mr MsgGerman
+    | ("de" : _)        <- lang' = mr MsgGerman
-    | ["en", "EU"] <- lang' = mr MsgEnglishEurope
+    | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
-    | ("en" : _)   <- lang' = mr MsgEnglish 
+    | ("en" : _)        <- lang' = mr MsgEnglish 
     | otherwise = lang
     where
       mr = renderMessage foundation ls
@@ -511,13 +511,13 @@ instance Button UniWorX ButtonSubmit where
 
 
 getTimeLocale' :: [Lang] -> TimeLocale
-getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8"), ("en", "en_IE.utf8")])
+getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-eu", "en_IE.utf8")])
 
 appTZ :: TZ
 appTZ = $(includeSystemTZ "Europe/Berlin")
 
 appLanguages :: NonEmpty Lang
-appLanguages = "de" :| ["en"]
+appLanguages = "de-de-formal" :| ["en-eu"]
 
 appLanguagesOpts :: ( MonadHandler m
                     , HandlerSite m ~ UniWorX
@@ -1571,7 +1571,7 @@ instance Yesod UniWorX where
     --   b) Validates that incoming write requests include that token in either a header or POST parameter.
     -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-    yesodMiddleware = headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
+    yesodMiddleware = languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
       where
         updateFavouritesMiddleware :: Handler a -> Handler a
         updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
@@ -3632,24 +3632,25 @@ updateUserLanguage (Just lang) = do
       updateUserLanguage Nothing
     Nothing -> do
       setLangCookie lang
-      setLanguage lang
       return $ Just lang
 updateUserLanguage Nothing = runMaybeT $ do
   uid <- MaybeT maybeAuthId
   User{..} <- MaybeT $ get uid
-  setLangs <- nub . filter (`elem` appLanguages) <$> languages
+  setLangs <- toList . selectLanguages appLanguages <$> languages
-  let userLanguages' = nub . filter (`elem` appLanguages) <$> userLanguages ^? _Just . _Wrapped
+  highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
-  lang <- case (userLanguages', setLangs) of
+  let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
-    (Just (l : _), _)
+  lang <- case (userLanguages', setLangs, highPrioSetLangs) of
+    (_, _, hpl : _)
+      -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
+    (Just (l : _), _, _)
       -> return l
-    (Nothing, l : _)
+    (Nothing, l : _, _)
       -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
-    (Just [], l : _)
+    (Just [], l : _, _)
       -> return l
-    (_, [])
+    (_, [], _)
       -> mzero
   setLangCookie lang
-  setLanguage lang
   return lang
 
 

src/Utils/Lang.hs

@@ -3,11 +3,22 @@ module Utils.Lang where
 import ClassyPrelude.Yesod
 
 import qualified Data.List.NonEmpty as NonEmpty
-import Data.List.NonEmpty (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 Control.Lens (none)
+
+import Yesod.Core.Types (HandlerData(handlerRequest), YesodRequest(reqLangs))
+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
@@ -17,18 +28,44 @@ selectLanguage avL = selectLanguage' avL <$> languages
 selectLanguage' :: NonEmpty Lang -- ^ Available translations, first is default
                 -> [Lang] -- ^ Languages in preference order
                 -> Lang
-selectLanguage' (defL :| _) [] = defL
+selectLanguage' avL ls = NonEmpty.head $ selectLanguages avL ls
-selectLanguage' avL (l:ls)
+
+selectLanguages :: NonEmpty Lang -> [Lang] -> NonEmpty Lang
+selectLanguages (defL :| _) [] = defL :| []
+selectLanguages avL (l:ls)
   | not $ null l
-  , Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l
+  , Just lParts <- nonEmpty $ matchesFor l
-  , found <- [ l' | lParts' <- reverse . List.inits $ NonEmpty.toList lParts
+  , found <- List.nub
-                  , l' <- NonEmpty.toList avL
+      [ l'' | lParts' <- NonEmpty.toList lParts
-                  , langMatches (Text.intercalate "-" lParts') l'
+            , l' <- NonEmpty.toList avL
-                  ]
+            , l'' <- matchesFor l'
-  = fromMaybe (selectLanguage' avL ls) . listToMaybe $ sortOn (Down . length) found
+            , langMatches lParts' l''
-  | otherwise = selectLanguage' avL ls
+            ]
+  = let now = nonEmpty . filter (\l' -> none (((==) `on` CI.mk) l') ls) $ 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 = isPrefixOf `on` Text.splitOn "-"
+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 = fromMaybe [] . fmap (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