feat(i18n): store language in user account

models/users.model

@@ -28,7 +28,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     dateFormat     DateTimeFormat "default='%d.%m.%Y'"       -- preferred Date-only display format for user; user-defined
     timeFormat     DateTimeFormat "default='%R'"             -- preferred Time-only display format for user; user-defined
     downloadFiles  Bool default=false           -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this)
-    mailLanguages  MailLanguages "default='[]'::jsonb"  -- Preferred language for eMail; i18n not yet implemented; user-defined
+    languages      Languages Maybe          -- Preferred language; user-defined
     notificationSettings NotificationSettings   -- Bit-array for which events email notifications are requested by user; user-defined
     warningDays    NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos
     csvOptions     CsvOptions "default='{}'::jsonb"

src/Foundation.hs

@@ -43,7 +43,9 @@ import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 import qualified Data.HashSet as HashSet
 
-import Data.List (nubBy, (!!), findIndex)
+import Data.List (nubBy, (!!), findIndex, inits)
+
+import Web.Cookie
 
 import Data.Monoid (Any(..))
 
@@ -3487,7 +3489,7 @@ upsertCampusUser ldapData Creds{..} = do
       , userWarningDays          = userDefaultWarningDays
       , userShowSex              = userDefaultShowSex
       , userNotificationSettings = def
-      , userMailLanguages        = def
+      , userLanguages            = Nothing
       , userCsvOptions           = def
       , userTokensIssuedAfter    = Nothing
       , userCreated              = now
@@ -3607,6 +3609,49 @@ associateUserSchoolsByTerms uid = do
         , userSchoolIsOptOut = False
         }
 
+setLangCookie :: MonadHandler m => Lang -> m ()
+setLangCookie lang = do
+  now <- liftIO getCurrentTime
+  setCookie $ def
+    { setCookieName    = "_LANG"
+    , setCookieValue   = encodeUtf8 lang
+    , setCookieExpires = Just $ addUTCTime (400 * avgNominalYear) now
+    , setCookiePath    = Just "/"
+    }
+
+updateUserLanguage :: Maybe Lang -> DB (Maybe Lang)
+updateUserLanguage (Just lang) = do
+  unless (lang `elem` appLanguages) $
+    invalidArgs ["Unsupported language"]
+
+  muid <- maybeAuthId
+  case muid of
+    Just uid -> do
+      langs <- languages
+      update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
+      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 : _), _)
+      -> return l
+    (Nothing, l : _)
+      -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
+    (Just [], l : _)
+      -> return l
+    (_, [])
+      -> mzero
+  setLangCookie lang
+  setLanguage lang
+  return lang
+
 
 instance YesodAuth UniWorX where
     type AuthId UniWorX = UserId
@@ -3698,7 +3743,12 @@ instance YesodAuth UniWorX where
 
     authHttpManager = getsYesod appHttpManager
 
-    onLogin = addMessageI Success Auth.NowLoggedIn
+    onLogin = liftHandler $ do
+      mlang <- runDB $ updateUserLanguage Nothing
+      app <- getYesod
+      let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
+             | otherwise = renderMessage app []
+      addMessage Success . toHtml $ mr Auth.NowLoggedIn
 
     onErrorHtml dest msg = do
       addMessage Error $ toHtml msg

src/Handler/Admin.hs

@@ -58,7 +58,7 @@ emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext)
 emailTestForm = (,)
             <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
             <*> ( MailContext
-                  <$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
+                  <$> (Languages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
                   <*> (toMailDateTimeFormat
                         <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
                         <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing

src/Handler/Profile.hs

@@ -30,8 +30,6 @@ import qualified Data.CaseInsensitive as CI
 
 import Jobs
 
-import Web.Cookie
-
 
 data SettingsForm = SettingsForm
       { stgDisplayName          :: UserDisplayName
@@ -847,18 +845,12 @@ postLangR :: Handler ()
 postLangR = do
   ((langRes, _), _) <- runFormPost $ identifyForm FIDLanguage langForm
 
-  now <- liftIO getCurrentTime
   formResult langRes $ \(lang, route) -> do
-    setCookie $ def
+    lang' <- runDB . updateUserLanguage $ Just lang
-      { setCookieName    = "_LANG"
+    
-      , setCookieValue   = encodeUtf8 lang
-      , setCookieExpires = Just $ addUTCTime (400 * avgNominalYear) now
-      }
-    setLanguage lang
-    -- TODO: Write to user
-
     app <- getYesod
-    let mr = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
+    let mr | Just lang'' <- lang' = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang''
+           | otherwise = renderMessage app []
     addMessage Success . toHtml $ mr MsgLanguageChanged
     redirect route
 

src/Handler/Users/Add.hs

@@ -76,7 +76,7 @@ postAdminUserAddR = do
         , userWarningDays             = userDefaultWarningDays
         , userShowSex                 = userDefaultShowSex
         , userNotificationSettings    = def
-        , userMailLanguages           = def
+        , userLanguages               = Nothing
         , userCsvOptions              = def
         , userTokensIssuedAfter       = Nothing
         , userCreated                 = now

src/Handler/Utils/DateTime.hs

@@ -90,7 +90,7 @@ formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
 formatTimeW s t = toWidget =<< formatTime s t
 
 formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
-formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
+formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . view _Wrapped <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
 
 getTimeLocale :: MonadHandler m => m TimeLocale
 getTimeLocale = getTimeLocale' <$> languages

src/Handler/Utils/Mail.hs

@@ -47,14 +47,14 @@ userMailT :: ( MonadHandler m
              ) => UserId -> MailT m a -> m a
 userMailT uid mAct = do
   user@User
-    { userMailLanguages
+    { userLanguages
     , userDateTimeFormat
     , userDateFormat
     , userTimeFormat
     } <- liftHandler . runDB $ getJust uid
   let
     ctx = MailContext
-      { mcLanguages = userMailLanguages
+      { mcLanguages = fromMaybe def userLanguages
       , mcDateTimeFormat = \case
           SelFormatDateTime -> userDateTimeFormat
           SelFormatDate -> userDateFormat

src/Mail.hs

@@ -10,7 +10,7 @@ module Mail
   , MailT, defMailT
   , MailSmtpData(..)
   , _MailSmtpDataSet
-  , MailContext(..), MailLanguages(..)
+  , MailContext(..)
   , MonadMail(..)
   , getMailMessageRender, getMailMsgRenderer
     -- * YesodMail
@@ -38,7 +38,7 @@ module Mail
 
 import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
 
-import Model.Types.TH.JSON
+import Model.Types.Languages
 
 import Network.Mail.Mime hiding (addPart, addAttachment)
 import qualified Network.Mail.Mime as Mime (addPart)
@@ -109,8 +109,6 @@ import Data.Universe.Instances.Reverse ()
 import Data.Universe.Instances.Reverse.JSON ()
 import Data.Universe.Instances.Reverse.Hashable ()
 
-import GHC.Exts (IsList)
-
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 import Data.CaseInsensitive (CI)
@@ -160,19 +158,8 @@ _MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
   ]
 
 
-newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
-  deriving (Eq, Ord, Show, Read, Generic, Typeable)
-  deriving newtype (FromJSON, ToJSON, IsList)
-
-instance Default MailLanguages where
-  def = MailLanguages []
-
-instance Hashable MailLanguages
-instance NFData MailLanguages
-
-
 data MailContext = MailContext
-  { mcLanguages :: MailLanguages
+  { mcLanguages :: Languages
   , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
@@ -191,7 +178,7 @@ instance Default MailContext where
 makeLenses_ ''MailContext
 
 class (MonadHandler m, MonadState Mail m) => MonadMail m where
-  askMailLanguages :: m MailLanguages
+  askMailLanguages :: m Languages
   askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
   tellMailSmtpData :: MailSmtpData -> m ()
 
@@ -214,7 +201,7 @@ getMailMessageRender :: ( MonadMail m
                         , HandlerSite m ~ site
                         , RenderMessage site msg
                         ) => m (msg -> Text)
-getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
+getMailMessageRender = renderMessage <$> getYesod <*> (view _Wrapped <$> askMailLanguages)
 
 getMailMsgRenderer :: forall site m.
                       ( MonadMail m
@@ -559,6 +546,3 @@ setMailSmtpData = do
         in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
     | otherwise
     -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }
-
-
-derivePersistFieldJSON ''MailLanguages

src/Model/Migration.hs

@@ -577,6 +577,14 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "allocation" DROP COLUMN "matching_log";
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
+    , whenM (tableExists "user") $
+        [executeQQ|
+          ALTER TABLE "user" ADD COLUMN "languages" jsonb;
+          UPDATE TABLE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
+          ALTER TABLE "user" DROP COLUMN "mail_languages";
+        |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -14,3 +14,4 @@ import Model.Types.Submission as Types
 import Model.Types.Misc as Types
 import Model.Types.School as Types
 import Model.Types.Allocation as Types
+import Model.Types.Languages as Types

src/Model/Types/Languages.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
+
+module Model.Types.Languages
+  ( Languages(..)
+  ) where
+
+import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
+import GHC.Exts (IsList)
+
+import Model.Types.TH.JSON
+
+import Control.Lens.TH (makeWrapped)
+  
+
+newtype Languages = Languages [Lang]
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+  deriving newtype (FromJSON, ToJSON, IsList)
+
+instance Default Languages where
+  def = Languages []
+
+instance Hashable Languages
+instance NFData Languages
+derivePersistFieldJSON ''Languages
+makeWrapped ''Languages

src/Utils/DateTime.hs

@@ -19,6 +19,8 @@ import Data.Time (TimeLocale(..), NominalDiffTime, nominalDay)
 import Data.Time.Zones (TZ)
 import Data.Time.Zones.TH (includeSystemTZ)
 
+import qualified Data.List.NonEmpty as NonEmpty
+
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
 import Instances.TH.Lift ()
@@ -49,21 +51,18 @@ timeLocaleMap extra@((_, defLocale):_) = do
   localeMap <- newName "localeMap"
 
   let
-    localeMap' = funD localeMap $ map matchLang extra ++ [reduceLangList, defaultLang]
+    langs = NonEmpty.fromList $ map fst extra
+    
+    localeMap' = funD localeMap $ map matchLang extra ++ [defaultLang]
 
     defaultLang :: ClauseQ
     defaultLang =
       clause [listP []] (normalB $ localeExp defLocale) []
 
-    reduceLangList :: ClauseQ
-    reduceLangList = do
-      ls <- newName "ls"
-      clause [[p|(_ : $(varP ls))|]] (normalB [e|$(varE localeMap) $(varE ls)|]) []
-
     matchLang :: (Lang, String) -> ClauseQ
     matchLang (lang, localeStr) = do
       lang' <- newName "lang"
-      clause [[p|($(varP lang') : _)|]] (guardedB [(,) <$> normalG [e|$(varE lang') == lang|] <*> localeExp localeStr]) []
+      clause [varP lang'] (guardedB [(,) <$> normalG [e|selectLanguage' langs $(varE lang') == lang|] <*> localeExp localeStr]) []
 
     localeExp :: String -> ExpQ
     localeExp = lift <=< runIO . getLocale . Just

src/Utils/Lang.hs

@@ -25,7 +25,7 @@ selectLanguage' avL (l:ls)
                   , l' <- NonEmpty.toList avL
                   , langMatches (Text.intercalate "-" lParts') l'
                   ]
-  = fromMaybe (selectLanguage' avL ls) $ listToMaybe found
+  = fromMaybe (selectLanguage' avL ls) . listToMaybe $ sortOn (Down . length) found
   | otherwise = selectLanguage' avL ls
 
 langMatches :: Lang -- ^ Needle

templates/mail/support.hamlet

@@ -15,7 +15,7 @@ $newline never
         $of Left  Nothing
         $of Right Nothing
           <dt>Ungültige UserId erhalten!
-        $of Right (Just (Entity _ User{userDisplayName, userSurname, userIdent, userEmail, userMatrikelnummer, userMailLanguages}))
+        $of Right (Just (Entity _ User{userDisplayName, userSurname, userIdent, userEmail, userMatrikelnummer, userLanguages}))
           <dt>Name
           <dd>^{const (const (nameHtml userDisplayName userSurname))}
           <dt>Identifikation
@@ -25,10 +25,11 @@ $newline never
           $maybe matrnr <- userMatrikelnummer
             <dt>Matrikelnummer
             <dd>#{matrnr}
-          $if not (null (mailLanguages userMailLanguages))
+          $maybe langs <- fmap (view _Wrapped) userLanguages
-            <dt>Präferierte E-Mail Sprachen
+            $if not (null langs)
-            $forall lang <- mailLanguages userMailLanguages
+              <dt>Präferierte E-Mail Sprachen
-              <dd>#{lang}
+              $forall lang <- langs
+                <dd>#{lang}
       <dt>Zeit
       <dd>#{rtime}
       $maybe referer <- jReferer

test/Database.hs

@@ -108,7 +108,7 @@ fillDb = do
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
     , userWarningDays = userDefaultWarningDays
-    , userMailLanguages = MailLanguages ["en"]
+    , userLanguages = Just $ Languages ["en"]
     , userNotificationSettings = def
     , userCreated = now
     , userLastLdapSynchronisation = Nothing
@@ -136,7 +136,7 @@ fillDb = do
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
     , userWarningDays = userDefaultWarningDays
-    , userMailLanguages = MailLanguages ["de"]
+    , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
     , userLastLdapSynchronisation = Nothing
@@ -164,7 +164,7 @@ fillDb = do
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
     , userWarningDays = userDefaultWarningDays
-    , userMailLanguages = MailLanguages ["de"]
+    , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
     , userLastLdapSynchronisation = Nothing
@@ -192,7 +192,7 @@ fillDb = do
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
     , userWarningDays = userDefaultWarningDays
-    , userMailLanguages = MailLanguages ["de"]
+    , userLanguages = Just $ Languages ["de"]
     , userNotificationSettings = def
     , userCreated = now
     , userLastLdapSynchronisation = Nothing
@@ -220,7 +220,7 @@ fillDb = do
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
     , userWarningDays = userDefaultWarningDays
-    , userMailLanguages = MailLanguages ["de"]
+    , userLanguages = Just $ Languages ["sn"]
     , userNotificationSettings = def
     , userCreated = now
     , userLastLdapSynchronisation = Nothing
@@ -248,7 +248,7 @@ fillDb = do
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
     , userWarningDays = userDefaultWarningDays
-    , userMailLanguages = MailLanguages ["de"]
+    , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
     , userLastLdapSynchronisation = Nothing

test/ModelSpec.hs

@@ -106,7 +106,10 @@ instance Arbitrary User where
 
     userDownloadFiles <- arbitrary
     userWarningDays <- arbitrary
-    userMailLanguages <- fmap MailLanguages $ sublistOf =<< shuffle (toList appLanguages)
+    userLanguages <- choose
+      [ pure Nothing
+      , fmap (Just . Languages) $ sublistOf =<< shuffle (toList appLanguages)
+      ]
     userNotificationSettings <- arbitrary
     userCsvOptions <- arbitrary
     userShowSex <- arbitrary