feat(user-schools): allow users to override automatic school assoc'

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

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]
-
+  associateUserSchoolsByTerms userId
-    schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
-    forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
-      void $ insertUnique UserSchool
-        { userSchoolUser     = userId
-        , userSchoolSchool   = schoolTermsSchool
-        , userSchoolIsOptOut = False
-        }
-      
 
   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 ]

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:
+schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
---
+schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty
--- makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
+  where
--- makeSettingForm template = identForm FIDsettings $ \html -> do
+    schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
---     (result, widget) <- flip (renderAForm FormStandard) html $ settingsFormT5T2
+    schoolsForm' = do
---       <$> aFormGroup "Cosmetics"     cosmeticsForm
+      allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName]
---       <*> aFormGroup "Notifications" notificationsForm
+
---       <*  submitButton
+      let
---     return (result, widget) -- no validation required here
+        schoolForm (Entity ssh School{schoolName})
---   where
+          = fmap (bool Set.empty $ Set.singleton ssh) <$> wpopt checkBoxField (fsl $ CI.original schoolName) (Set.member ssh <$> template)
---     settingsFormT5T2 :: (Int,Theme,DateTimeFormat,DateTimeFormat,DateTimeFormat) -> (Bool,NotificationSettings) -> SettingsForm
+
---     settingsFormT5T2 = $(uncurryN 2) . $(uncurryN 5) SettingsForm
+      fold <$> mapM schoolForm allSchools
---     themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
+
---     cosmeticsForm = (,,,,)
+    schoolsFormView :: (FormResult (Set SchoolId), Widget) -> MForm Handler (FormResult (Set SchoolId), [FieldView UniWorX])
---       <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
+    schoolsFormView (res, fvInput) = do
---             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
+      mr <- getMessageRender
---       <*> areq (selectField . return $ mkOptionList themeList)
+      let fvLabel = toHtml $ mr MsgUserSchools
---             (fslI  MsgTheme) { fsId = Just "theme-select" } (stgTheme         <$> template)
+          fvTooltip = Just . toHtml $ mr MsgUserSchoolsTip
---       <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
+          fvRequired = False
---       <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
+          fvErrors
---       <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
+            | FormFailure (err : _) <- res = Just $ toHtml err
---     notificationsForm = (,)
+            | otherwise = Nothing
---       <$> areq checkBoxField (fslI MsgDownloadFiles
+      fvId <- newIdent
---                                & setTooltip MsgDownloadFilesTip
+      return (res, pure FieldView{..})
---                              ) (stgDownloadFiles <$> template)
---       <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
---     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
 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