feat(users): generalise UserLecturer and UserAdmin to UserFunction
Closes #320 BREAKING CHANGE: Remove UserLecturer and UserAdmin
This commit is contained in:
Gregor Kleen
parent
18ae28abbc
commit
76f8da52e0
@ -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
|
||||
SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits
|
||||
|
||||
SchoolAdmin: Admin
|
||||
SchoolLecturer: Dozent
|
||||
SchoolEvaluation: Kursumfragenverwaltung
|
||||
SchoolExamOffice: Prüfungsamt
|
||||
@ -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
|
||||
21
models/users
21
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.
|
||||
|
||||
7
routes
7
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:
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall (E.Value sh) <- schools
|
||||
<li>#{sh}
|
||||
|]
|
||||
, sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
|
||||
E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
|
||||
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
|
||||
E.orderBy [E.asc $ school E.^. SchoolShorthand]
|
||||
return $ school E.^. SchoolShorthand
|
||||
return [whamlet|
|
||||
$newline never
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall (E.Value sh) <- schools
|
||||
<li>#{sh}
|
||||
|]
|
||||
, flip foldMap universeF $ \function ->
|
||||
sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
|
||||
E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
|
||||
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
|
||||
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
|
||||
E.orderBy [E.asc $ school E.^. SchoolShorthand]
|
||||
return $ school E.^. SchoolShorthand
|
||||
return [whamlet|
|
||||
$newline never
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall (E.Value sh) <- schools
|
||||
<li>#{sh}
|
||||
|]
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
|
||||
cID <- encrypt uid
|
||||
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
|
||||
@ -142,14 +132,8 @@ getUsersR = do
|
||||
, ( "school", FilterColumn $ \user criterion -> if
|
||||
| Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> let schools = E.valList (Set.toList criterion) in
|
||||
E.exists ( E.from $ \ulectr -> do
|
||||
E.where_ $ ulectr E.^. UserLecturerUser E.==. user E.^. UserId
|
||||
E.where_ $ ulectr E.^. UserLecturerSchool `E.in_` schools
|
||||
) E.||.
|
||||
E.exists ( E.from $ \uadmin -> do
|
||||
E.where_ $ uadmin E.^. UserAdminUser E.==. user E.^. UserId
|
||||
E.where_ $ uadmin E.^. UserAdminSchool `E.in_` schools
|
||||
)
|
||||
E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
|
||||
E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
|
||||
)
|
||||
]
|
||||
, dbtFilterUI = \mPrev -> mconcat
|
||||
@ -199,56 +183,57 @@ getAdminUserR = postAdminUserR
|
||||
postAdminUserR uuid = do
|
||||
adminId <- requireAuthId
|
||||
uid <- decrypt uuid
|
||||
let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal)
|
||||
let unValueRights (school, E.Value isAdmin, E.Value isLecturer) = (school,isAdmin,isLecturer)
|
||||
(user@User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
|
||||
<$> get404 uid
|
||||
<*> selectList [UserAdminUser ==. adminId] []
|
||||
<*> E.select ( E.from $ \school -> do
|
||||
E.orderBy [E.asc $ school E.^. SchoolName]
|
||||
let schAdmin = E.exists $ E.from $ \userAdmin -> do
|
||||
E.where_ $ userAdmin E.^. UserAdminSchool E.==. school E.^. SchoolId
|
||||
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
|
||||
let schLecturer = E.exists $ E.from $ \userLecturer -> do
|
||||
E.where_ $ userLecturer E.^. UserLecturerSchool E.==. school E.^. SchoolId
|
||||
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
|
||||
return (school,schAdmin,schLecturer)
|
||||
)
|
||||
(user@User{..}, adminSchools, functions, schools) <- runDB $ do
|
||||
user <- get404 uid
|
||||
|
||||
schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do
|
||||
E.on $ userFunction E.?. UserFunctionSchool E.==. E.just (school E.^. SchoolId)
|
||||
E.&&. userFunction E.?. UserFunctionUser E.==. E.just (E.val uid)
|
||||
let isAdmin = E.exists . E.from $ \adminFunction ->
|
||||
E.where_ $ adminFunction E.^. UserFunctionUser E.==. E.val adminId
|
||||
E.&&. adminFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
|
||||
E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||
return (school, userFunction E.?. UserFunctionFunction, isAdmin)
|
||||
|
||||
return ( user
|
||||
, setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools
|
||||
, setOf (folded . folding (\x -> (,) <$> preview (_2 . _Value . _Just) x <*> preview (_1 . _entityKey) x)) schools
|
||||
, setOf (folded . _1) schools
|
||||
)
|
||||
let allFunctions = Set.fromList universeF
|
||||
allSchools = Set.mapMonotonic entityKey schools
|
||||
|
||||
-- above data is needed for both form generation and result evaluation
|
||||
let userRightsForm :: Form [(SchoolId, Bool, Bool)]
|
||||
let userRightsForm :: Form (Set (SchoolFunction, SchoolId))
|
||||
userRightsForm = identifyForm FIDuserRights $ \csrf -> do
|
||||
boxRights <- forM userRights $ \(school@(Entity sid _), isAdmin, isLecturer) ->
|
||||
if Set.member sid adminSchools
|
||||
then do
|
||||
cbAdmin <- mreq checkBoxField "" (Just isAdmin)
|
||||
cbLecturer <- mreq checkBoxField "" (Just isLecturer)
|
||||
return (school, cbAdmin, cbLecturer)
|
||||
else do
|
||||
cbAdmin <- mforced checkBoxField "" isAdmin
|
||||
cbLecturer <- mforced checkBoxField "" isLecturer
|
||||
return (school, cbAdmin, cbLecturer)
|
||||
let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
|
||||
(,,) <$> pure sid <*> resAdmin <*> resLecturer
|
||||
return (result,$(widgetFile "widgets/user-rights-form/user-rights-form"))
|
||||
boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if
|
||||
| sid `Set.member` adminSchools
|
||||
-> mpopt checkBoxField "" . Just $ (function, sid) `Set.member` functions
|
||||
| otherwise
|
||||
-> mforced checkBoxField "" $ (function, sid) `Set.member` functions
|
||||
let result = Map.keysSet . Map.filter id <$> mapM (view _1) boxRights
|
||||
return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
|
||||
userAuthenticationForm :: Form ButtonAuthMode
|
||||
userAuthenticationForm = buttonForm' $ if
|
||||
| userAuthentication == AuthLDAP -> [BtnAuthPWHash]
|
||||
| otherwise -> [BtnAuthLDAP, BtnPasswordReset]
|
||||
let userRightsAction changes = do
|
||||
runDBJobs $ do
|
||||
forM_ changes $ \(sid, userAdmin, userLecturer) ->
|
||||
if Set.notMember sid adminSchools
|
||||
then return ()
|
||||
else do
|
||||
if userAdmin
|
||||
then void . insertUnique $ UserAdmin uid sid
|
||||
else deleteBy $ UniqueUserAdmin uid sid
|
||||
if userLecturer
|
||||
then void . insertUnique $ UserLecturer uid sid
|
||||
else deleteBy $ UniqueSchoolLecturer uid sid
|
||||
-- Note: deleteWhere would not work well here since we filter by adminSchools
|
||||
queueDBJob . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference
|
||||
addMessageI Info MsgAccessRightsSaved
|
||||
let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes)
|
||||
updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff
|
||||
if
|
||||
| not $ Set.null updates -> runDBJobs $ do
|
||||
$logInfoS "user-rights-update" $ tshow updates
|
||||
forM_ updates $ \(function, sid) -> do
|
||||
$logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|]
|
||||
if
|
||||
| (function, sid) `Set.member` changes
|
||||
-> void . insertUnique $ UserFunction uid sid function
|
||||
| otherwise
|
||||
-> deleteBy $ UniqueUserFunction uid sid function
|
||||
queueDBJob . JobQueueNotification . NotificationUserRightsUpdate uid $ Set.mapMonotonic (over _2 unSchoolKey) functions -- original rights to check for difference
|
||||
addMessageI Success MsgAccessRightsSaved
|
||||
| otherwise
|
||||
-> addMessageI Info MsgAccessRightsNotChanged
|
||||
redirect $ AdminUserR uuid
|
||||
|
||||
userAuthenticationAction = \case
|
||||
@ -435,54 +420,76 @@ postUserPasswordR cID = do
|
||||
}
|
||||
|
||||
|
||||
instance IsInvitableJunction UserLecturer where
|
||||
type InvitationFor UserLecturer = School
|
||||
data InvitableJunction UserLecturer = JunctionUserLecturer
|
||||
instance IsInvitableJunction UserFunction where
|
||||
type InvitationFor UserFunction = School
|
||||
data InvitableJunction UserFunction = JunctionUserFunction
|
||||
{ jFunction :: SchoolFunction
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData UserLecturer = InvDBDataUserLecturer
|
||||
data InvitationDBData UserFunction = InvDBDataUserFunction
|
||||
{ invDBUserFunctionDeadline :: UTCTime
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData UserLecturer = InvTokenDataUserLecturer
|
||||
{ invTokenUserLecturerSchool :: SchoolShorthand
|
||||
data InvitationTokenData UserFunction = InvTokenDataUserFunction
|
||||
{ invTokenUserFunctionSchool :: SchoolShorthand
|
||||
, invTokenUserFunctionFunction :: SchoolFunction
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\UserLecturer{..} -> (userLecturerUser, userLecturerSchool, JunctionUserLecturer))
|
||||
(\(userLecturerUser, userLecturerSchool, JunctionUserLecturer) -> UserLecturer{..})
|
||||
(\UserFunction{..} -> (userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction))
|
||||
(\(userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction) -> UserFunction{..})
|
||||
|
||||
instance ToJSON (InvitableJunction UserLecturer) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction UserLecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
|
||||
instance ToJSON (InvitableJunction UserFunction) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
}
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
}
|
||||
instance FromJSON (InvitableJunction UserFunction) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
}
|
||||
|
||||
instance ToJSON (InvitationDBData UserLecturer) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationDBData UserLecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
instance ToJSON (InvitationDBData UserFunction) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationDBData UserFunction) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
|
||||
instance ToJSON (InvitationTokenData UserLecturer) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData UserLecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance ToJSON (InvitationTokenData UserFunction) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData UserFunction) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
|
||||
lecturerInvitationConfig :: InvitationConfig UserLecturer
|
||||
lecturerInvitationConfig = InvitationConfig{..}
|
||||
functionInvitationConfig :: InvitationConfig UserFunction
|
||||
functionInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute _ _ = return AdminLecturerInviteR
|
||||
invitationResolveFor InvTokenDataUserLecturer{..} = return $ SchoolKey invTokenUserLecturerSchool
|
||||
invitationSubject (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSubjectSchoolLecturerInvitation schoolName
|
||||
invitationHeading (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSchoolLecturerInviteHeading schoolName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSchoolLecturerInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
invitationRoute _ _ = return AdminFunctionaryInviteR
|
||||
invitationResolveFor InvTokenDataUserFunction{..} = return $ SchoolKey invTokenUserFunctionSchool
|
||||
invitationSubject (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return . SomeMessage . MsgMailSubjectSchoolFunctionInvitation schoolName $ mr invTokenUserFunctionFunction
|
||||
invitationHeading (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return . SomeMessage . MsgMailSchoolFunctionInviteHeading schoolName $ mr invTokenUserFunctionFunction
|
||||
invitationExplanation _ (_, InvTokenDataUserFunction{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
|
||||
invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
let itExpiresAt = Just $ Just invDBUserFunctionDeadline
|
||||
itAddAuth = Nothing
|
||||
itStartsAt = Nothing
|
||||
return InvitationTokenConfig{..}
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure $ (JunctionUserLecturer, ())
|
||||
invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ School{..}) _ = return . SomeMessage $ MsgSchoolLecturerInvitationAccepted schoolName
|
||||
invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return . SomeMessage . MsgSchoolFunctionInvitationAccepted schoolName $ mr userFunctionFunction
|
||||
invitationUltDest (Entity ssh _) _ = do
|
||||
currentTerm <- E.select . E.from $ \term -> do
|
||||
E.where_ $ term E.^. TermActive
|
||||
@ -494,39 +501,50 @@ lecturerInvitationConfig = InvitationConfig{..}
|
||||
_other -> CourseListR
|
||||
|
||||
|
||||
getAdminNewLecturerInviteR, postAdminNewLecturerInviteR :: Handler Html
|
||||
getAdminNewLecturerInviteR = postAdminNewLecturerInviteR
|
||||
postAdminNewLecturerInviteR = do
|
||||
getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html
|
||||
getAdminNewFunctionaryInviteR = postAdminNewFunctionaryInviteR
|
||||
postAdminNewFunctionaryInviteR = do
|
||||
uid <- requireAuthId
|
||||
userSchools <- runDB . E.select . E.from $ \userAdmin -> do
|
||||
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
|
||||
return $ userAdmin E.^. UserAdminSchool
|
||||
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val uid
|
||||
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||
return $ userAdmin E.^. UserFunctionSchool
|
||||
|
||||
((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgLecturerInviteSchool) Nothing
|
||||
users <- wreq (multiUserField False Nothing) (fslI MsgLecturerInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
|
||||
return $ (,) <$> school <*> users
|
||||
now <- liftIO getCurrentTime
|
||||
let
|
||||
localNow = utcToLocalTime now
|
||||
beginToday = case localTimeToUTC (LocalTime (localDay localNow) midnight) of
|
||||
LTUUnique utc' _ -> utc'
|
||||
_other -> UTCTime (utctDay now) 0
|
||||
defDeadline = beginToday{ utctDay = 14 `addDays` utctDay beginToday }
|
||||
|
||||
formResultModal invitesResult UsersR $ \(schoolId, users) -> do
|
||||
function <- wreq (selectField optionsFinite) (fslI MsgFunctionaryInviteFunction) Nothing
|
||||
school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgFunctionaryInviteSchool) Nothing
|
||||
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
|
||||
users <- wreq (multiUserField False Nothing) (fslI MsgFunctionaryInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
|
||||
return $ (,,,) <$> function <*> school <*> deadline <*> users
|
||||
|
||||
formResultModal invitesResult UsersR $ \(function, schoolId, deadline, users) -> do
|
||||
let (emails, uids) = partitionEithers $ Set.toList users
|
||||
lift . runDBJobs $ do
|
||||
forM_ uids $ \lecId ->
|
||||
void . insertUnique $ UserLecturer lecId schoolId
|
||||
void . insertUnique $ UserFunction lecId schoolId function
|
||||
|
||||
sinkInvitationsF lecturerInvitationConfig [ (mail, schoolId, (InvDBDataUserLecturer, InvTokenDataUserLecturer $ unSchoolKey schoolId)) | mail <- emails ]
|
||||
sinkInvitationsF functionInvitationConfig [ (mail, schoolId, (InvDBDataUserFunction deadline, InvTokenDataUserFunction (unSchoolKey schoolId) function)) | mail <- emails ]
|
||||
|
||||
unless (null emails) $
|
||||
tell . pure <=< messageI Success . MsgLecturersInvited $ length emails
|
||||
tell . pure <=< messageI Success . MsgFunctionariesInvited $ length emails
|
||||
unless (null uids) $
|
||||
tell . pure <=< messageI Success . MsgLecturersAdded $ length uids
|
||||
tell . pure <=< messageI Success . MsgFunctionariesAdded $ length uids
|
||||
|
||||
siteLayoutMsg MsgLecturerInviteHeading $ do
|
||||
setTitleI MsgLecturerInviteHeading
|
||||
siteLayoutMsg MsgFunctionaryInviteHeading $ do
|
||||
setTitleI MsgFunctionaryInviteHeading
|
||||
wrapForm invitesWgt def
|
||||
{ formEncoding = invitesEncoding
|
||||
, formAction = Just $ SomeRoute AdminNewLecturerInviteR
|
||||
, formAction = Just $ SomeRoute AdminNewFunctionaryInviteR
|
||||
}
|
||||
|
||||
getAdminLecturerInviteR, postAdminLecturerInviteR :: Handler Html
|
||||
getAdminLecturerInviteR = postAdminLecturerInviteR
|
||||
postAdminLecturerInviteR = invitationR lecturerInvitationConfig
|
||||
getAdminFunctionaryInviteR, postAdminFunctionaryInviteR :: Handler Html
|
||||
getAdminFunctionaryInviteR = postAdminFunctionaryInviteR
|
||||
postAdminFunctionaryInviteR = invitationR functionInvitationConfig
|
||||
|
||||
@ -122,7 +122,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
|
||||
-- ^ Subject of the e-mail which sends the token to the user
|
||||
, invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
|
||||
-- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR`
|
||||
, invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
|
||||
, invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> DB (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
|
||||
-- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`)
|
||||
, invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig
|
||||
-- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
|
||||
@ -222,7 +222,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
|
||||
jwt <- encodeToken token
|
||||
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
|
||||
let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur
|
||||
jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation fEnt dat)
|
||||
|
||||
queueDBJob JobInvitation{..}
|
||||
|
||||
@ -308,7 +308,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
ur <- getUrlRenderParams
|
||||
heading <- invitationHeading fEnt iData
|
||||
let explanation = invitationExplanation fEnt iData (toHtml . mr) ur
|
||||
explanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> invitationExplanation fEnt iData
|
||||
|
||||
fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
|
||||
Nothing -> do
|
||||
|
||||
@ -234,18 +234,14 @@ termCell tid = anchorCell link name
|
||||
termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
|
||||
termCellCL (tid,_,_) = termCell tid
|
||||
|
||||
schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a
|
||||
schoolCell (Just tid) ssh = anchorCell link name
|
||||
schoolCell :: IsDBTable m a => TermId -> SchoolId -> DBCell m a
|
||||
schoolCell tid ssh = anchorCell link name
|
||||
where
|
||||
link = TermSchoolCourseListR tid ssh
|
||||
name = toWgt ssh
|
||||
schoolCell Nothing ssh = anchorCell link name
|
||||
where
|
||||
link = SchoolShowR ssh
|
||||
name = toWgt ssh
|
||||
|
||||
schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a
|
||||
schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh
|
||||
schoolCellCL (tid,ssh,_) = schoolCell tid ssh
|
||||
|
||||
courseCellCL :: IsDBTable m a => CourseLink -> DBCell m a
|
||||
courseCellCL (tid,ssh,csh) = anchorCell link name
|
||||
|
||||
@ -2,9 +2,9 @@ module Jobs.Handler.QueueNotification
|
||||
( dispatchJobQueueNotification
|
||||
) where
|
||||
|
||||
import Import hiding ((\\))
|
||||
import Import
|
||||
|
||||
import Data.List (nub, (\\))
|
||||
import Data.List (nub)
|
||||
|
||||
import Jobs.Types
|
||||
|
||||
@ -12,6 +12,8 @@ import qualified Database.Esqueleto as E
|
||||
import Utils.Sql
|
||||
import Jobs.Queue
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
dispatchJobQueueNotification :: Notification -> Handler ()
|
||||
dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
|
||||
@ -59,14 +61,15 @@ determineNotificationCandidates NotificationUserRightsUpdate{..} = do
|
||||
-- always send to affected user
|
||||
affectedUser <- selectList [UserId ==. nUser] []
|
||||
-- send to same-school admins only if there was an update
|
||||
currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] []
|
||||
let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- nOriginalRights ]
|
||||
newAdminSchools = currentAdminSchools \\ oldAdminSchools
|
||||
currentAdminSchools <- setOf (folded . _entityVal . _userFunctionSchool) <$> selectList [UserFunctionUser ==. nUser, UserFunctionFunction ==. SchoolAdmin] []
|
||||
let oldAdminSchools = setOf (folded . filtered ((== SchoolAdmin) . view _1) . _2 . from _SchoolId) nOriginalRights
|
||||
newAdminSchools = currentAdminSchools `Set.difference` oldAdminSchools
|
||||
affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do
|
||||
E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId
|
||||
E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools
|
||||
E.on $ admin E.^. UserFunctionUser E.==. user E.^. UserId
|
||||
E.where_ $ admin E.^. UserFunctionSchool `E.in_` E.valList (Set.toList newAdminSchools)
|
||||
E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||
return user
|
||||
return $ nub $ affectedUser <> affectedAdmins
|
||||
return . nub $ affectedUser <> affectedAdmins
|
||||
determineNotificationCandidates NotificationUserAuthModeUpdate{..}
|
||||
= selectList [UserId ==. nUser] []
|
||||
determineNotificationCandidates notif@NotificationExamResult{..} = do
|
||||
|
||||
@ -6,24 +6,25 @@ module Jobs.Handler.SendNotification.UserRightsUpdate
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils.Database
|
||||
import Handler.Utils.Mail
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Text.Hamlet
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
dispatchNotificationUserRightsUpdate :: UserId -> [(SchoolShorthand,Bool,Bool)]-> UserId -> Handler ()
|
||||
dispatchNotificationUserRightsUpdate :: UserId -> Set (SchoolFunction, SchoolShorthand) -> UserId -> Handler ()
|
||||
dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMailT jRecipient $ do
|
||||
(User{..}, adminSchools, lecturerSchools) <- liftHandlerT . runDB $ do
|
||||
user <-getJust nUser
|
||||
adminSchools <- getSchoolsOf nUser UserAdminSchool UserAdminUser
|
||||
lecturerSchools <- getSchoolsOf nUser UserLecturerSchool UserLecturerUser
|
||||
return (user,adminSchools,lecturerSchools)
|
||||
(User{..}, functions) <- liftHandlerT . runDB $ do
|
||||
user <- getJust nUser
|
||||
functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. nUser] []
|
||||
return (user, functions)
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
|
||||
-- MsgRenderer mr <- getMailMsgRenderer
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addAlternatives $
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
|
||||
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Jobs.Handler.SendNotification.Utils
|
||||
( mkEditNotifications
|
||||
, ihamletSomeMessage
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -9,6 +10,9 @@ import Text.Hamlet
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
|
||||
ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
|
||||
ihamletSomeMessage f trans rUrl = f (trans . SomeMessage) rUrl
|
||||
|
||||
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
mkEditNotifications uid = liftHandlerT $ do
|
||||
cID <- encrypt uid
|
||||
|
||||
@ -57,7 +57,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||
| NotificationSheetInactive { nSheet :: SheetId }
|
||||
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
|
||||
| NotificationCorrectionsNotDistributed { nSheet :: SheetId }
|
||||
| NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow
|
||||
| NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
|
||||
| NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
|
||||
| NotificationExamResult { nExam :: ExamId }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
@ -454,6 +454,37 @@ customMigrations = Map.fromListWith (>>)
|
||||
whenM (tableExists "allocation_deregister") $ do
|
||||
[executeQQ|ALTER TABLE allocation_deregister DROP COLUMN IF EXISTS allocation;|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|18.0.0|] [version|19.0.0|]
|
||||
, do
|
||||
[executeQQ|
|
||||
CREATe TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text );
|
||||
|]
|
||||
|
||||
whenM (tableExists "user_admin") $ do
|
||||
let getAdminEntries = rawQuery [st|SELECT user_admin.id, user_admin.user, user_admin.school FROM user_admin;|] []
|
||||
moveAdminEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
|
||||
[executeQQ|
|
||||
INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolAdmin});
|
||||
DELETE FROM "user_admin" WHERE "id" = #{eId};
|
||||
|]
|
||||
moveAdminEntry _ = return ()
|
||||
runConduit $ getAdminEntries .| C.mapM_ moveAdminEntry
|
||||
tableDropEmpty "user_admin"
|
||||
whenM (tableExists "user_lecturer") $ do
|
||||
let getLecturerEntries = rawQuery [st|SELECT user_lecturer.id, user_lecturer.user, user_lecturer.school FROM user_lecturer;|] []
|
||||
moveLecturerEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
|
||||
[executeQQ|
|
||||
INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolLecturer});
|
||||
DELETE FROM "user_lecturer" WHERE "id" = #{eId};
|
||||
|]
|
||||
moveLecturerEntry _ = return ()
|
||||
runConduit $ getLecturerEntries .| C.mapM_ moveLecturerEntry
|
||||
tableDropEmpty "user_lecturer"
|
||||
whenM (tableExists "invitation") $ do
|
||||
[executeQQ|
|
||||
DELETE FROM "invitation" WHERE "for"->'junction' = '"UserLecturer"';
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -12,3 +12,4 @@ import Model.Types.Security as Types
|
||||
import Model.Types.Sheet as Types
|
||||
import Model.Types.Submission as Types
|
||||
import Model.Types.Misc as Types
|
||||
import Model.Types.School as Types
|
||||
|
||||
19
src/Model/Types/School.hs
Normal file
19
src/Model/Types/School.hs
Normal file
@ -0,0 +1,19 @@
|
||||
module Model.Types.School where
|
||||
|
||||
import Import.NoModel
|
||||
import Model.Types.TH.PathPiece
|
||||
|
||||
data SchoolFunction
|
||||
= SchoolAdmin
|
||||
| SchoolLecturer
|
||||
| SchoolEvaluation
|
||||
| SchoolExamOffice
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe SchoolFunction
|
||||
instance Finite SchoolFunction
|
||||
instance Hashable SchoolFunction
|
||||
|
||||
nullaryPathPiece ''SchoolFunction $ camelToPathPiece' 1
|
||||
pathPieceJSON ''SchoolFunction
|
||||
pathPieceJSONKey ''SchoolFunction
|
||||
derivePersistFieldPathPiece ''SchoolFunction
|
||||
47
src/Model/Types/TH/PathPiece.hs
Normal file
47
src/Model/Types/TH/PathPiece.hs
Normal file
@ -0,0 +1,47 @@
|
||||
module Model.Types.TH.PathPiece
|
||||
( derivePersistFieldPathPiece
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Data.List (foldl)
|
||||
import Database.Persist.Sql
|
||||
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Datatype
|
||||
|
||||
|
||||
derivePersistFieldPathPiece :: Name -> DecsQ
|
||||
derivePersistFieldPathPiece tName = do
|
||||
DatatypeInfo{..} <- reifyDatatype tName
|
||||
vars <- forM datatypeVars (const $ newName "a")
|
||||
let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
|
||||
iCxt
|
||||
| null vars = cxt []
|
||||
| otherwise = cxt [[t|PathPiece|] `appT` t]
|
||||
sqlCxt
|
||||
| null vars = cxt []
|
||||
| otherwise = cxt [[t|PersistField|] `appT` t]
|
||||
sequence
|
||||
[ instanceD iCxt ([t|PersistField|] `appT` t)
|
||||
[ funD 'toPersistValue
|
||||
[ clause [] (normalB [e|PersistText . toPathPiece|]) []
|
||||
]
|
||||
, funD 'fromPersistValue
|
||||
[ do
|
||||
bs <- newName "bs"
|
||||
clause [[p|PersistByteString $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistByteString") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
|
||||
, do
|
||||
text <- newName "text"
|
||||
clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistTetx") Right $ fromPathPiece $(varE text)|]) []
|
||||
, clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText or PersistByteString"|]) []
|
||||
]
|
||||
]
|
||||
, instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
|
||||
[ funD 'sqlType
|
||||
[ clause [wildP] (normalB [e|SqlString|]) []
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
@ -395,6 +395,9 @@ setIntersections (h:t) = foldl' Set.intersection h t
|
||||
setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
|
||||
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
|
||||
|
||||
setProduct :: (Ord a, Ord b) => Set a -> Set b -> Set (a, b)
|
||||
setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs
|
||||
|
||||
----------
|
||||
-- Maps --
|
||||
----------
|
||||
|
||||
@ -169,6 +169,8 @@ makeLenses_ ''File
|
||||
|
||||
makeLenses_ ''School
|
||||
|
||||
makeLenses_ ''UserFunction
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
@ -11,25 +11,21 @@ $newline never
|
||||
}
|
||||
<body>
|
||||
<h1>
|
||||
_{MsgMailUserRightsIntro userDisplayName userEmail}
|
||||
$with numSchools <- length adminSchools
|
||||
$if numSchools > 0
|
||||
<p>
|
||||
<h2>_{MsgAdminFor} _{MsgForSchools numSchools}
|
||||
_{SomeMessage $ MsgMailUserRightsIntro userDisplayName userEmail}
|
||||
<dl>
|
||||
$forall (function, schools) <- Map.toList functions
|
||||
<dt>_{SomeMessage $ function}
|
||||
<dd>
|
||||
<ul>
|
||||
$forall sn <- adminSchools
|
||||
<li>#{sn}
|
||||
$with numSchools <- length lecturerSchools
|
||||
$forall sn <- schools
|
||||
<li>
|
||||
#{sn}
|
||||
$with numSchools <- maybe 0 Set.size $ Map.lookup SchoolLecturer functions
|
||||
$if numSchools > 0
|
||||
<p>
|
||||
<h2>_{MsgLecturerFor} _{MsgForSchools numSchools}
|
||||
<ul>
|
||||
$forall sn <- lecturerSchools
|
||||
<li>#{sn}
|
||||
<p>
|
||||
<a href=@{CourseNewR}>
|
||||
_{MsgMailLecturerRights numSchools}
|
||||
_{SomeMessage $ MsgMailLecturerRights numSchools}
|
||||
$else
|
||||
<p>_{MsgMailNoLecturerRights}
|
||||
<p>_{SomeMessage $ MsgMailNoLecturerRights}
|
||||
|
||||
^{editNotifications}
|
||||
^{ihamletSomeMessage editNotifications}
|
||||
|
||||
@ -16,22 +16,13 @@
|
||||
#{llogin}
|
||||
$nothing
|
||||
_{MsgNever}
|
||||
$if not $ null admin_rights
|
||||
<dt .deflist__dt>_{MsgAdminFor}
|
||||
$forall (function, schools) <- Map.toList functions
|
||||
<dt .deflist__dt>_{function}
|
||||
<dd .deflist__dd>
|
||||
<ul .list-ul>
|
||||
$forall (E.Value institute) <- admin_rights
|
||||
$forall ssh <- schools
|
||||
<li .list-ul__item>
|
||||
<a href=@{SchoolShowR $ SchoolKey institute}>
|
||||
#{institute}
|
||||
$if not $ null lecturer_rights
|
||||
<dt .deflist__dt>_{MsgLecturerFor}
|
||||
<dd .deflist__dd>
|
||||
<ul .list-ul>
|
||||
$forall (E.Value institute) <- lecturer_rights
|
||||
<li .list-ul__item>
|
||||
<a href=@{SchoolShowR $ SchoolKey institute}>
|
||||
#{institute}
|
||||
#{ssh}
|
||||
$if not $ null lecture_corrector
|
||||
<dt .deflist__dt> Korrektor
|
||||
<dd .deflist__dd>
|
||||
|
||||
@ -5,10 +5,15 @@ $newline never
|
||||
<tr .table__row .table__row--head>
|
||||
<th>
|
||||
$# empty cell
|
||||
<th .table__th>_{MsgAdminFor}
|
||||
<th .table__th>_{MsgLecturerFor}
|
||||
$forall (Entity _ (School name _), (_,cbAdmin), (_,cbLecturer)) <- boxRights
|
||||
<tr .table__row>
|
||||
<th .table__th>#{name}
|
||||
<td .table__td>^{fvInput cbAdmin}
|
||||
<td .table__td>^{fvInput cbLecturer}
|
||||
$forall function <- allFunctions
|
||||
<th .table__th>
|
||||
_{function}
|
||||
$forall school <- schools
|
||||
$with Entity sid School{schoolName} <- school
|
||||
<tr .table__row>
|
||||
<th .table__th>
|
||||
#{schoolName}
|
||||
$forall function <- allFunctions
|
||||
<td .table__td>
|
||||
$maybe (_, boxView) <- Map.lookup (function, sid) boxRights
|
||||
^{fvInput boxView}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user