feat(user-schools): allow users to override automatic school assoc'
This commit is contained in:
Gregor Kleen
parent
12067de2ff
commit
7d927fdd5f
@ -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
|
||||
|
||||
@ -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 ]
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user