fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(i18n): store language in user account

Browse Source
This commit is contained in:
Gregor Kleen 2019-10-20 15:55:02 +02:00
parent 59b8bb982d
commit f0f94112f4
16 changed files with 125 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/users.model
View File

@ -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"

56
src/Foundation.hs
View File

@ -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

2
src/Handler/Admin.hs
View File

@ -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

16
src/Handler/Profile.hs
View File

@ -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
{ setCookieName = "_LANG"
, setCookieValue = encodeUtf8 lang
, setCookieExpires = Just $ addUTCTime (400 * avgNominalYear) now
}
setLanguage lang
-- TODO: Write to user
lang' <- runDB . updateUserLanguage $ Just lang
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

2
src/Handler/Users/Add.hs
View File

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

2
src/Handler/Utils/DateTime.hs
View File

@ -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

4
src/Handler/Utils/Mail.hs
View File

@ -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

26
src/Mail.hs
View File

@ -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

8
src/Model/Migration.hs
View File

@ -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";
|]
)
]

1
src/Model/Types.hs
View File

@ -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

25
src/Model/Types/Languages.hs Normal file
View File

@ -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

13
src/Utils/DateTime.hs
View File

@ -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

2
src/Utils/Lang.hs
View File

@ -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

11
templates/mail/support.hamlet
View File

@ -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))
<dt>Präferierte E-Mail Sprachen
$forall lang <- mailLanguages userMailLanguages
<dd>#{lang}
$maybe langs <- fmap (view _Wrapped) userLanguages
$if not (null langs)
<dt>Präferierte E-Mail Sprachen
$forall lang <- langs
<dd>#{lang}
<dt>Zeit
<dd>#{rtime}
$maybe referer <- jReferer

12
test/Database.hs
View File

@ -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

5
test/ModelSpec.hs
View File

@ -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