From 76f8da52e0f532ef08df5ad649aa3d2bb24159f5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 28 Aug 2019 09:46:03 +0200 Subject: [PATCH] feat(users): generalise UserLecturer and UserAdmin to UserFunction Closes #320 BREAKING CHANGE: Remove UserLecturer and UserAdmin --- messages/uniworx/de.msg | 31 +- models/schools | 6 +- models/users | 21 +- routes | 7 +- src/Auth/LDAP.hs | 10 +- src/Foundation.hs | 39 +-- src/Handler/Course/Application/Edit.hs | 4 +- src/Handler/Course/Edit.hs | 25 +- src/Handler/Course/LecturerInvite.hs | 2 +- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/Exam/CorrectorInvite.hs | 2 +- src/Handler/Exam/RegistrationInvite.hs | 2 +- src/Handler/Profile.hs | 59 ++-- src/Handler/School.hs | 18 +- src/Handler/Sheet.hs | 2 +- src/Handler/Submission.hs | 2 +- src/Handler/Tutorial.hs | 2 +- src/Handler/Users.hs | 274 ++++++++++-------- src/Handler/Utils/Invitations.hs | 6 +- src/Handler/Utils/Table/Cells.hs | 10 +- src/Jobs/Handler/QueueNotification.hs | 19 +- .../SendNotification/UserRightsUpdate.hs | 17 +- src/Jobs/Handler/SendNotification/Utils.hs | 4 + src/Jobs/Types.hs | 2 +- src/Model/Migration.hs | 31 ++ src/Model/Types.hs | 1 + src/Model/Types/School.hs | 19 ++ src/Model/Types/TH/PathPiece.hs | 47 +++ src/Utils.hs | 3 + src/Utils/Lens.hs | 2 + templates/mail/userRightsUpdate.hamlet | 28 +- templates/profileData.hamlet | 17 +- .../user-rights-form/user-rights-form.hamlet | 19 +- 33 files changed, 443 insertions(+), 290 deletions(-) create mode 100644 src/Model/Types/School.hs create mode 100644 src/Model/Types/TH/PathPiece.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 3521e81cb..6194df7d2 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -615,7 +615,8 @@ TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"} CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"} ForSchools n@Int: für #{pluralDE n "Institut" "Institute"} UserListTitle: Komprehensive Benutzerliste -AccessRightsSaved: Berechtigungsänderungen wurden gespeichert. +AccessRightsSaved: Berechtigungen erfolgreich verändert +AccessRightsNotChanged: Berechtigungen wurden nicht verändert LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"} @@ -861,6 +862,8 @@ NotificationTriggerKindExamParticipant: Für Prüfungsteilnehmer NotificationTriggerKindCorrector: Für Korrektoren NotificationTriggerKindLecturer: Für Dozenten NotificationTriggerKindAdmin: Für Administratoren +NotificationTriggerKindExamOffice: Für das Prüfungsamt +NotificationTriggerKindEvaluation: Für Vorlesungsumfragen CorrCreate: Abgaben erstellen UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" @@ -1491,17 +1494,18 @@ PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein UserPasswordHeadingFor: Passwort ändern für PasswordChangedSuccess: Passwort erfolgreich geändert -LecturerInviteSchool: Institut -LecturerInviteField: Einzuladende EMail Addressen -LecturerInviteHeading: Dozenten hinzufügen +FunctionaryInviteFunction: Funktion +FunctionaryInviteSchool: Institut +FunctionaryInviteField: Einzuladende EMail Addressen +FunctionaryInviteHeading: Institut-Funktionäre hinzufügen -LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen -LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen +FunctionariesInvited n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} per EMail eingeladen +FunctionariesAdded n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} eingetragen -MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“ -MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“ -SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen. -SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen +MailSubjectSchoolFunctionInvitation school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“ +MailSchoolFunctionInviteHeading school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“ +SchoolFunctionInviteExplanation renderedFunction@Text: Sie wurden eingeladen, als #{renderedFunction} für ein Institut zu wirken. Sie erhalten, nachdem Sie die Einladung annehmen, erweiterte Rechte innerhalb des Instituts. +SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung zum Dozent für „#{school}“ angenommen AllocationActive: Aktiv AllocationName: Name @@ -1573,4 +1577,9 @@ SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst SchoolTitle ssh@SchoolId: Institut „#{ssh}“ TitleSchoolNew: Neues Institut anlegen SchoolCreated ssh@SchoolId: #{ssh} erfolgreich angelegt -SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits \ No newline at end of file +SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits + +SchoolAdmin: Admin +SchoolLecturer: Dozent +SchoolEvaluation: Kursumfragenverwaltung +SchoolExamOffice: Prüfungsamt \ No newline at end of file diff --git a/models/schools b/models/schools index f877a1aeb..da7859057 100644 --- a/models/schools +++ b/models/schools @@ -6,4 +6,8 @@ School json UniqueSchool name UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } - deriving Eq Show Generic + deriving Ord Eq Show Generic +SchoolLdap + school SchoolId + orgUnit (CI Text) + UniqueOrgUnit orgUnit \ No newline at end of file diff --git a/models/users b/models/users index f66651dd5..330102901 100644 --- a/models/users +++ b/models/users @@ -30,14 +30,19 @@ User json -- Each Uni2work user has a corresponding row in this table; create UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory -UserAdmin -- Each row in this table grants school-specific administrator-rights to a specific user - user UserId - school SchoolId - UniqueUserAdmin user school -- combination of user+school must be unique, i.e. no duplicate rows -UserLecturer -- Each row in this table grants school-specific lecturer-rights to a specific user - user UserId - school SchoolId - UniqueSchoolLecturer user school -- combination of user+school must be unique, i.e. no duplicate rows +UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...) + user UserId + school SchoolId + function SchoolFunction + UniqueUserFunction user school function +UserExamOffice + user UserId + field StudyTermsId + UniqueUserExamOffice user field +UserSchool -- Managed by users themselves, encodes "schools of interest" + user UserId + school SchoolId + UniqueUserSchool user school StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login user UserId degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. diff --git a/routes b/routes index 1c42a5478..fe7902d98 100644 --- a/routes +++ b/routes @@ -49,8 +49,8 @@ /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self /users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash -!/users/lecturer-invite/new AdminNewLecturerInviteR GET POST -!/users/lecturer-invite AdminLecturerInviteR GET POST +!/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST +!/users/functionary-invite AdminFunctionaryInviteR GET POST /admin AdminR GET /admin/features AdminFeaturesR GET POST /admin/test AdminTestR GET POST @@ -80,7 +80,8 @@ /school SchoolListR GET !/school/new SchoolNewR GET POST -/school/#SchoolId SchoolShowR GET POST +/school/#SchoolId SchoolR: + / SchoolShowR GET POST /allocation/ AllocationListR GET !free /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 406a3a2d4..e14a79b9a 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -2,14 +2,14 @@ module Auth.LDAP ( apLdap , campusLogin , CampusUserException(..) - , campusUser + , campusUser, campusUser' , CampusMessage(..) , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName ) where -import Import.NoFoundation hiding (userEmail, userDisplayName) +import Import.NoFoundation import Network.Connection import Data.CaseInsensitive (CI) @@ -80,6 +80,8 @@ data CampusUserException = CampusUserLdapError LdapPoolError instance Exception CampusUserException +makePrisms ''CampusUserException + campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do Ldap.bind ldap ldapDn ldapPassword @@ -105,6 +107,10 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs ] +campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList [])) +campusUser' conf pool User{userIdent} + = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) []) + campusForm :: ( RenderMessage site FormMessage , RenderMessage site CampusMessage diff --git a/src/Foundation.hs b/src/Foundation.hs index e0472c50e..7d0354425 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -310,6 +310,7 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''SecretJSONFieldException id embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel +embedRenderMessage ''UniWorX ''SchoolFunction id embedRenderMessage ''UniWorX ''AuthenticationMode id @@ -606,8 +607,9 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do - E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId + E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool + E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId + E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh @@ -617,17 +619,24 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do - E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserAdminSchool - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId + E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool + E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId + E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin E.&&. allocation E.^. AllocationTerm E.==. E.val tid E.&&. allocation E.^. AllocationSchool E.==. E.val ssh E.&&. allocation E.^. AllocationShorthand E.==. E.val ash guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) return Authorized + -- Schools: access only to school admins + SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) + return Authorized -- other routes: access to any admin is granted here _other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] + adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ @@ -636,10 +645,9 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of AdminHijackUserR cID -> exceptT return return $ do myUid <- maybeExceptT AuthenticationRequired $ return mAuthId uid <- decrypt cID - otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] - otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] - mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] [] - guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) + otherSchoolsFunctions <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] [] + mySchools <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] [] + guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) return Authorized r -> $unsupportedAuthPredicate AuthNoEscalation r tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do @@ -680,7 +688,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of -- lecturer for any school will do _ -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] + void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] return Authorized tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId @@ -1725,7 +1733,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb AdminErrMsgR = return ("Test" , Just AdminR) breadcrumb SchoolListR = return ("Institute" , Just AdminR) - breadcrumb (SchoolShowR ssh) = return (original (unSchoolKey ssh), Just SchoolListR) + breadcrumb (SchoolR ssh SchoolShowR) = return (original (unSchoolKey ssh), Just SchoolListR) breadcrumb SchoolNewR = return ("Neu" , Just SchoolListR) breadcrumb InfoR = return ("Information" , Nothing) @@ -2055,7 +2063,7 @@ pageActions (UsersR) = { menuItemType = PageActionPrime , menuItemLabel = MsgMenuLecturerInvite , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AdminNewLecturerInviteR + , menuItemRoute = SomeRoute AdminNewFunctionaryInviteR , menuItemModal = True , menuItemAccessCallback' = return True } @@ -2883,13 +2891,6 @@ pageHeading (TermSchoolCourseListR tid ssh) School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh i18nHeading $ MsgTermSchoolCourseListHeading tid school -pageHeading (SchoolListR) - = Just $ i18nHeading MsgSchoolListHeading -pageHeading (SchoolShowR ssh) - = Just $ do - School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh - i18nHeading $ MsgSchoolHeading school - pageHeading (CourseListR) = Just $ i18nHeading $ MsgCourseListTitle pageHeading CourseNewR diff --git a/src/Handler/Course/Application/Edit.hs b/src/Handler/Course/Application/Edit.hs index 281a21826..29544bd90 100644 --- a/src/Handler/Course/Application/Edit.hs +++ b/src/Handler/Course/Application/Edit.hs @@ -19,8 +19,8 @@ postCAEditR tid ssh csh cID = do mAlloc <- traverse getEntity404 $ courseApplicationAllocation app appUser <- get404 $ courseApplicationUser app isAdmin <- case mAlloc of - Just alloc -> exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool] - Nothing -> exists [UserAdminUser ==. uid, UserAdminSchool ==. course ^. _entityVal . _courseSchool] + Just alloc -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. alloc ^. _entityVal . _allocationSchool, UserFunctionFunction ==. SchoolAdmin] + Nothing -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. course ^. _entityVal . _courseSchool, UserFunctionFunction ==. SchoolAdmin] return (mAlloc, course, app, isAdmin, appUser) afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 248c17571..5888fecd6 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -105,10 +105,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do MsgRenderer mr <- getMsgRenderer uid <- liftHandlerT requireAuthId - (lecSchools, admSchools) <- liftHandlerT . runDB $ (,) - <$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] ) - <*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] ) - let userSchools = lecSchools ++ admSchools + userSchools <- liftHandlerT . runDB $ map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [] termsField <- case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin @@ -278,11 +275,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do _ -> (result, widget) -validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text] +validateCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text] validateCourse CourseForm{..} = do now <- liftIO getCurrentTime uid <- liftHandlerT requireAuthId - userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route + userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolShowR MsgRenderer mr <- getMsgRenderer allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust @@ -291,7 +288,7 @@ validateCourse CourseForm{..} = do prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if - | is _Just userAdmin + | userAdmin -> return Nothing | NTop allocationStaffRegisterTo <= NTop (Just now) -> Just . courseCapacity <$> getJust cid @@ -309,7 +306,7 @@ validateCourse CourseForm{..} = do ( NTop cfRegFrom <= NTop cfDeRegUntil , MsgCourseDeregistrationEndMustBeAfterStart ) - , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin + , ( bool (anyOf (traverse . _Right . _1) (== uid) cfLecturers) True userAdmin , MsgCourseUserMustBeLecturer ) , ( is _Nothing cfAllocation || is _Just cfCapacity @@ -357,8 +354,9 @@ getCourseNewR = do E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId let lecturersSchool = E.exists $ E.from $ \user -> - E.where_ $ user E.^. UserLecturerUser E.==. E.val uid - E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool + E.where_ $ user E.^. UserFunctionUser E.==. E.val uid + E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool + E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer let courseCreated c = E.sub_select . E.from $ \edit -> do -- oldest edit must be creation E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId @@ -527,17 +525,16 @@ courseEditHandler miButtonAction mbCourseForm = do , formEncoding = formEnctype } -upsertAllocationCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () +upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime - uid <- liftHandlerT requireAuthId Course{..} <- getJust cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse - userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid courseSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route + userAdmin <- hasWriteAccessTo $ SchoolR courseSchool SchoolShowR doEdit <- if - | is _Just userAdmin + | userAdmin -> return True | Just Allocation{allocationStaffRegisterTo} <- prevAllocation , NTop allocationStaffRegisterTo <= NTop (Just now) diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 7bc870396..696ba927b 100644 --- a/src/Handler/Course/LecturerInvite.hs +++ b/src/Handler/Course/LecturerInvite.hs @@ -61,7 +61,7 @@ lecturerInvitationConfig = InvitationConfig{..} getKeyBy404 $ TermSchoolCourseShort tid csh ssh invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 97b79e54c..a54af6349 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -74,7 +74,7 @@ participantInvitationConfig = InvitationConfig{..} getKeyBy404 $ TermSchoolCourseShort tid csh ssh invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index f8398487a..738c2a3fb 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/src/Handler/Exam/CorrectorInvite.hs @@ -61,7 +61,7 @@ examCorrectorInvitationConfig = InvitationConfig{..} Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 2b41622b9..5810d3516 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -69,7 +69,7 @@ examRegistrationInvitationConfig = InvitationConfig{..} Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do itAuthority <- liftHandlerT requireAuthId let itExpiresAt = Just $ Just invDBExamRegistrationDeadline diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 11b9728a3..bbf6803da 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -28,12 +28,27 @@ data SettingsForm = SettingsForm , stgNotificationSettings :: NotificationSettings } -data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKExamParticipant | NTKCorrector | NTKLecturer | NTKAdmin - deriving (Eq, Ord, Enum, Bounded, Generic, Typeable) -instance Universe NotificationTriggerKind -instance Finite NotificationTriggerKind +data NotificationTriggerKind + = NTKAll + | NTKCourseParticipant + | NTKExamParticipant + | NTKCorrector + | NTKFunctionary SchoolFunction + deriving (Eq, Ord, Generic, Typeable) +deriveFinite ''NotificationTriggerKind -embedRenderMessage ''UniWorX ''NotificationTriggerKind $ ("NotificationTriggerKind" <>) . mconcat . drop 1 . splitCamel +instance RenderMessage UniWorX NotificationTriggerKind where + renderMessage f ls = \case + NTKAll -> mr MsgNotificationTriggerKindAll + NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant + NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant + NTKCorrector -> mr MsgNotificationTriggerKindCorrector + NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin + NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer + NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice + NTKFunctionary SchoolEvaluation -> mr MsgNotificationTriggerKindEvaluation + where + mr = renderMessage f ls makeSettingForm :: Maybe SettingsForm -> Form SettingsForm @@ -99,13 +114,10 @@ notificationForm template = wFormToAForm $ do | isAdmin = return False | Just uid <- mbUid - , NTKAdmin <- nt - = fmap not . E.selectExists . E.from $ \userAdmin -> - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid - | Just uid <- mbUid - , NTKLecturer <- nt - = fmap not . E.selectExists . E.from $ \userLecturer -> - E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid + , NTKFunctionary f <- nt + = fmap not . E.selectExists . E.from $ \userFunction -> + E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f | Just uid <- mbUid , NTKCorrector <- nt = fmap not . E.selectExists . E.from $ \sheetCorrector -> @@ -141,9 +153,9 @@ notificationForm template = wFormToAForm $ do NTSubmissionRated -> Just NTKCourseParticipant NTSheetActive -> Just NTKCourseParticipant NTSheetSoonInactive -> Just NTKCourseParticipant - NTSheetInactive -> Just NTKLecturer + NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer NTCorrectionsAssigned -> Just NTKCorrector - NTCorrectionsNotDistributed -> Just NTKLecturer + NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer NTUserRightsUpdate -> Just NTKAll NTUserAuthModeUpdate -> Just NTKAll NTExamResult -> Just NTKExamParticipant @@ -255,14 +267,7 @@ getProfileDataR = do makeProfileData :: Entity User -> DB Widget makeProfileData (Entity uid User{..}) = do -- MsgRenderer mr <- getMsgRenderer - admin_rights <- E.select $ E.from $ \(adright `E.InnerJoin` school) -> do - E.where_ $ adright E.^. UserAdminUser E.==. E.val uid - E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId - return (school E.^. SchoolShorthand) - lecturer_rights <- E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do - E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid - E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId - return (school E.^. SchoolShorthand) + functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] [] lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet @@ -314,7 +319,7 @@ mkOwnedCoursesTable = return $ indicatorCell -- return True if one cell is produced here `mappend` termCell tid , sortable (Just "school") (i18nCell MsgCourseSchool) $ - schoolCell <$> view (_dbrOutput . _1 . re _Just) + schoolCell <$> view (_dbrOutput . _1) <*> view (_dbrOutput . _2 ) , sortable (Just "course") (i18nCell MsgCourse) $ courseCellCL <$> view _dbrOutput @@ -362,8 +367,8 @@ mkEnrolledCoursesTable = , sortable (Just "term") (i18nCell MsgTerm) $ termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $ - schoolCell <$> view ( _courseTerm . re _Just) - <*> view _courseSchool + schoolCell <$> view _courseTerm + <*> view _courseSchool , sortable (Just "course") (i18nCell MsgCourse) $ courseCell <$> view (_dbrOutput . _1 . _entityVal) , sortable (Just "time") (i18nCell MsgRegistered) $ do @@ -430,7 +435,7 @@ mkSubmissionTable = , sortable (Just "term") (i18nCell MsgTerm) $ termCell <$> view (_dbrOutput . _1 . _1) , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ - schoolCell <$> view ( _1. re _Just) + schoolCell <$> view _1 <*> view _2 , sortable (Just "course") (i18nCell MsgCourse) $ courseCellCL <$> view (_dbrOutput . _1) @@ -512,7 +517,7 @@ mkSubmissionGroupTable = , sortable (Just "term") (i18nCell MsgTerm) $ termCell <$> view (_dbrOutput . _1 . _1) , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ - schoolCell <$> view ( _1. re _Just) + schoolCell <$> view _1 <*> view _2 , sortable (Just "course") (i18nCell MsgCourse) $ courseCellCL <$> view (_dbrOutput . _1) diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 04eac6bc8..d5cd61820 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -10,7 +10,7 @@ getSchoolListR :: Handler Html getSchoolListR = do let schoolLink :: SchoolId -> SomeRoute UniWorX - schoolLink ssh = SomeRoute $ SchoolShowR ssh + schoolLink ssh = SomeRoute $ SchoolR ssh SchoolShowR dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _ dbtSQLQuery = return @@ -84,11 +84,11 @@ postSchoolShowR ssh = do runDB $ do update ssh [ SchoolName =. sfName ] addMessageI Success $ MsgSchoolUpdated ssh - redirect $ SchoolShowR ssh + redirect $ SchoolR ssh SchoolShowR let sfView' = wrapForm sfView FormSettings { formMethod = POST - , formAction = Just . SomeRoute $ SchoolShowR ssh + , formAction = Just . SomeRoute $ SchoolR ssh SchoolShowR , formEncoding = sfEnctype , formAttrs = [] , formSubmit = FormSubmit @@ -102,20 +102,28 @@ postSchoolShowR ssh = do getSchoolNewR, postSchoolNewR :: Handler Html getSchoolNewR = postSchoolNewR postSchoolNewR = do + uid <- requireAuthId ((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing formResult sfResult $ \SchoolForm{..} -> do let ssh = SchoolKey sfShorthand insertOkay <- runDB $ do - fmap (is _Just) $ insertUnique School + didInsert <- fmap (is _Just) $ insertUnique School { schoolShorthand = sfShorthand , schoolName = sfName } + when didInsert $ + insert_ UserFunction + { userFunctionUser = uid + , userFunctionSchool = ssh + , userFunctionFunction = SchoolAdmin + } + return didInsert if | insertOkay -> do addMessageI Success $ MsgSchoolCreated ssh - redirect $ SchoolShowR ssh + redirect $ SchoolR ssh SchoolShowR | otherwise -> addMessageI Error $ MsgSchoolExists ssh diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5ee6ba68f..96f2ec55f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -902,7 +902,7 @@ correctorInvitationConfig = InvitationConfig{..} Course{..} <- get404 sheetCourse return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 1d14a8d9f..72dca3ce9 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -100,7 +100,7 @@ submissionUserInvitationConfig = InvitationConfig{..} invitationHeading (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] invitationTokenConfig (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index ae2c26ea0..4bacd9cd7 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -258,7 +258,7 @@ tutorInvitationConfig = InvitationConfig{..} Course{..} <- get404 tutorialCourse return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index a8df63296..0b5b3bdac 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -58,30 +58,20 @@ getUsersR = do -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication - , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do - schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do - E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid - E.orderBy [E.asc $ school E.^. SchoolShorthand] - return $ school E.^. SchoolShorthand - return [whamlet| - $newline never -