From 7d927fdd5fe6e1e4abd315abf4b415c58f99e89b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 29 Aug 2019 08:43:02 +0200 Subject: [PATCH] feat(user-schools): allow users to override automatic school assoc' --- messages/uniworx/de.msg | 2 + src/Foundation.hs | 28 +++++++++----- src/Handler/Profile.hs | 82 +++++++++++++++++++++++++++-------------- 3 files changed, 75 insertions(+), 37 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 43a3c5673..a3aa6fa5b 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -629,6 +629,8 @@ DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern a WarningDays: Fristen-Vorschau WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Klausuren etc. auf Ihrer Startseite angezeigt werden? NotificationSettings: Erwünschte Benachrichtigungen +UserSchools: Relevante Institute +UserSchoolsTip: Sie erhalten nur institutweite Benachrichtigungen für Institute, die hier ausgewählt sind. FormNotifications: Benachrichtigungen FormBehaviour: Verhalten FormCosmetics: Oberfläche diff --git a/src/Foundation.hs b/src/Foundation.hs index 4390305fb..1c54c1093 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -3167,15 +3167,7 @@ upsertCampusUser ldapData Creds{..} = do insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True] - - schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] [] - forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) -> - void $ insertUnique UserSchool - { userSchoolUser = userId - , userSchoolSchool = schoolTermsSchool - , userSchoolIsOptOut = False - } - + associateUserSchoolsByTerms userId let userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools @@ -3212,6 +3204,19 @@ upsertCampusUser ldapData Creds{..} = do isDummy = credsPlugin == "dummy" isPWHash = credsPlugin == "PWHash" +associateUserSchoolsByTerms :: UserId -> DB () +associateUserSchoolsByTerms uid = do + sfs <- selectList [StudyFeaturesUser ==. uid] [] + + forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do + schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] [] + forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) -> + void $ insertUnique UserSchool + { userSchoolUser = uid + , userSchoolSchool = schoolTermsSchool + , userSchoolIsOptOut = False + } + instance YesodAuth UniWorX where type AuthId UniWorX = UserId @@ -3273,6 +3278,11 @@ instance YesodAuth UniWorX where acceptExisting = do res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + case res of + Authenticated uid + -> associateUserSchoolsByTerms uid + _other + -> return () case res of Authenticated uid | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index bbf6803da..e9d0a6ad0 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -15,6 +15,7 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto ((^.)) +import qualified Data.CaseInsensitive as CI data SettingsForm = SettingsForm @@ -25,6 +26,7 @@ data SettingsForm = SettingsForm , stgTime :: DateTimeFormat , stgDownloadFiles :: Bool , stgWarningDays :: NominalDiffTime + , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings } @@ -70,38 +72,36 @@ makeSettingForm template html = do & setTooltip MsgWarningDaysTip ) (stgWarningDays <$> template) <* aformSection MsgFormNotifications + <*> schoolsForm (stgSchools <$> template) <*> notificationForm (stgNotificationSettings <$> template) return (result, widget) -- no validation required here where themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF] --- --- Version with proper grouping: --- --- makeSettingForm :: Maybe SettingsForm -> Form SettingsForm --- makeSettingForm template = identForm FIDsettings $ \html -> do --- (result, widget) <- flip (renderAForm FormStandard) html $ settingsFormT5T2 --- <$> aFormGroup "Cosmetics" cosmeticsForm --- <*> aFormGroup "Notifications" notificationsForm --- <* submitButton --- return (result, widget) -- no validation required here --- where --- settingsFormT5T2 :: (Int,Theme,DateTimeFormat,DateTimeFormat,DateTimeFormat) -> (Bool,NotificationSettings) -> SettingsForm --- settingsFormT5T2 = $(uncurryN 2) . $(uncurryN 5) SettingsForm --- themeList = [Option (display t) t (toPathPiece t) | t <- universeF] --- cosmeticsForm = (,,,,) --- <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here --- (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) --- <*> areq (selectField . return $ mkOptionList themeList) --- (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template) --- <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) --- <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) --- <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) --- notificationsForm = (,) --- <$> areq checkBoxField (fslI MsgDownloadFiles --- & setTooltip MsgDownloadFilesTip --- ) (stgDownloadFiles <$> template) --- <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True) --- nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template) + +schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId) +schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty + where + schoolsForm' :: WForm Handler (FormResult (Set SchoolId)) + schoolsForm' = do + allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName] + + let + schoolForm (Entity ssh School{schoolName}) + = fmap (bool Set.empty $ Set.singleton ssh) <$> wpopt checkBoxField (fsl $ CI.original schoolName) (Set.member ssh <$> template) + + fold <$> mapM schoolForm allSchools + + schoolsFormView :: (FormResult (Set SchoolId), Widget) -> MForm Handler (FormResult (Set SchoolId), [FieldView UniWorX]) + schoolsFormView (res, fvInput) = do + mr <- getMessageRender + let fvLabel = toHtml $ mr MsgUserSchools + fvTooltip = Just . toHtml $ mr MsgUserSchoolsTip + fvRequired = False + fvErrors + | FormFailure (err : _) <- res = Just $ toHtml err + | otherwise = Nothing + fvId <- newIdent + return (res, pure FieldView{..}) notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = wFormToAForm $ do @@ -189,6 +189,12 @@ getProfileR, postProfileR :: Handler Html getProfileR = postProfileR postProfileR = do (uid, User{..}) <- requireAuthPair + userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do + E.where_ . E.exists . E.from $ \userSchool -> + E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut) + E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid + E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId + return $ school E.^. SchoolId let settingsTemplate = Just SettingsForm { stgMaxFavourties = userMaxFavourites , stgTheme = userTheme @@ -196,6 +202,7 @@ postProfileR = do , stgDate = userDateFormat , stgTime = userTimeFormat , stgDownloadFiles = userDownloadFiles + , stgSchools = userSchools , stgNotificationSettings = userNotificationSettings , stgWarningDays = userWarningDays } @@ -219,6 +226,25 @@ postProfileR = do , OffsetBy stgMaxFavourties ] mapM_ delete oldFavs + let + symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools) + forM_ symDiff $ \ssh -> if + | ssh `Set.member` stgSchools + -> void $ upsert UserSchool + { userSchoolSchool = ssh + , userSchoolUser = uid + , userSchoolIsOptOut = False + } + [ UserSchoolIsOptOut =. False + ] + | otherwise + -> void $ upsert UserSchool + { userSchoolSchool = ssh + , userSchoolUser = uid + , userSchoolIsOptOut = True + } + [ UserSchoolIsOptOut =. True + ] addMessageI Info MsgSettingsUpdate redirect $ ProfileR :#: ProfileSettings