diff --git a/messages/frontend/de.msg b/messages/frontend/de-de-formal.msg similarity index 50% rename from messages/frontend/de.msg rename to messages/frontend/de-de-formal.msg index f01c31640..a17c4540c 100644 --- a/messages/frontend/de.msg +++ b/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! \ No newline at end of file +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! \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de-de-formal.msg similarity index 100% rename from messages/uniworx/de.msg rename to messages/uniworx/de-de-formal.msg diff --git a/src/Foundation.hs b/src/Foundation.hs index 608d784ac..9f973bfd5 100644 --- a/src/Foundation.hs +++ b/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')) - | ["de", "DE"] <- lang' = mr MsgGermanGermany - | ("de" : _) <- lang' = mr MsgGerman - | ["en", "EU"] <- lang' = mr MsgEnglishEurope - | ("en" : _) <- lang' = mr MsgEnglish + renderMessage foundation ls (MsgLanguage lang@(map mk . Text.splitOn "-" -> lang')) + | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany + | ("de" : _) <- lang' = mr MsgGerman + | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope + | ("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 - let userLanguages' = nub . filter (`elem` appLanguages) <$> userLanguages ^? _Just . _Wrapped - lang <- case (userLanguages', setLangs) of - (Just (l : _), _) + setLangs <- toList . selectLanguages appLanguages <$> languages + highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs + let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped + 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 diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs index c0de743ba..82103b848 100644 --- a/src/Utils/Lang.hs +++ b/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 (l:ls) +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.nonEmpty $ Text.splitOn "-" l - , found <- [ l' | lParts' <- reverse . List.inits $ NonEmpty.toList lParts - , l' <- NonEmpty.toList avL - , langMatches (Text.intercalate "-" lParts') l' - ] - = fromMaybe (selectLanguage' avL ls) . listToMaybe $ sortOn (Down . length) found - | otherwise = selectLanguage' avL ls + , 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 . 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