fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

feat(users): generalise UserLecturer and UserAdmin to UserFunction

Browse Source 
Closes #320
BREAKING CHANGE: Remove UserLecturer and UserAdmin
This commit is contained in:
Gregor Kleen 2019-08-28 09:46:03 +02:00
parent 18ae28abbc
commit 76f8da52e0
33 changed files with 443 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
messages/uniworx/de.msg
View File

@ -615,7 +615,8 @@ TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"}
CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"} CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"}
ForSchools n@Int: für #{pluralDE n "Institut" "Institute"} ForSchools n@Int: für #{pluralDE n "Institut" "Institute"}
UserListTitle: Komprehensive Benutzerliste 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"} LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"}
@ -861,6 +862,8 @@ NotificationTriggerKindExamParticipant: Für Prüfungsteilnehmer
NotificationTriggerKindCorrector: Für Korrektoren NotificationTriggerKindCorrector: Für Korrektoren
NotificationTriggerKindLecturer: Für Dozenten NotificationTriggerKindLecturer: Für Dozenten
NotificationTriggerKindAdmin: Für Administratoren NotificationTriggerKindAdmin: Für Administratoren
NotificationTriggerKindExamOffice: Für das Prüfungsamt
NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
CorrCreate: Abgaben erstellen CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@ -1491,17 +1494,18 @@ PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein
UserPasswordHeadingFor: Passwort ändern für UserPasswordHeadingFor: Passwort ändern für
PasswordChangedSuccess: Passwort erfolgreich geändert PasswordChangedSuccess: Passwort erfolgreich geändert
LecturerInviteSchool: Institut FunctionaryInviteFunction: Funktion
LecturerInviteField: Einzuladende EMail Addressen FunctionaryInviteSchool: Institut
LecturerInviteHeading: Dozenten hinzufügen FunctionaryInviteField: Einzuladende EMail Addressen
FunctionaryInviteHeading: Institut-Funktionäre hinzufügen
LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen FunctionariesInvited n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} per EMail eingeladen
LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen FunctionariesAdded n@Int: #{n} #{pluralDE n "Funktionär" "Funktionäre"} eingetragen
MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“ MailSubjectSchoolFunctionInvitation school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung für „#{school}“
MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“ MailSchoolFunctionInviteHeading school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung 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. 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.
SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{renderedFunction}-Einladung zum Dozent für „#{school}“ angenommen
AllocationActive: Aktiv AllocationActive: Aktiv
AllocationName: Name AllocationName: Name
@ -1573,4 +1577,9 @@ SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst
SchoolTitle ssh@SchoolId: Institut „#{ssh}“ SchoolTitle ssh@SchoolId: Institut „#{ssh}“
TitleSchoolNew: Neues Institut anlegen TitleSchoolNew: Neues Institut anlegen
SchoolCreated ssh@SchoolId: #{ssh} erfolgreich angelegt 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
models/schools
View File

@ -6,4 +6,8 @@ School json
UniqueSchool name UniqueSchool name
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } 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
View File

@ -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 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 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 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 UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
user UserId user UserId
school SchoolId school SchoolId
UniqueUserAdmin user school -- combination of user+school must be unique, i.e. no duplicate rows function SchoolFunction
UserLecturer -- Each row in this table grants school-specific lecturer-rights to a specific user UniqueUserFunction user school function
user UserId UserExamOffice
school SchoolId user UserId
UniqueSchoolLecturer user school -- combination of user+school must be unique, i.e. no duplicate rows 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 StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login
user UserId user UserId
degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc.

7
routes
View File

@ -49,8 +49,8 @@
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash /users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash
!/users/lecturer-invite/new AdminNewLecturerInviteR GET POST !/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST
!/users/lecturer-invite AdminLecturerInviteR GET POST !/users/functionary-invite AdminFunctionaryInviteR GET POST
/admin AdminR GET /admin AdminR GET
/admin/features AdminFeaturesR GET POST /admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST /admin/test AdminTestR GET POST
@ -80,7 +80,8 @@
/school SchoolListR GET /school SchoolListR GET
!/school/new SchoolNewR GET POST !/school/new SchoolNewR GET POST
/school/#SchoolId SchoolShowR GET POST /school/#SchoolId SchoolR:
/ SchoolShowR GET POST
/allocation/ AllocationListR GET !free /allocation/ AllocationListR GET !free
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:

10
src/Auth/LDAP.hs
View File

@ -2,14 +2,14 @@ module Auth.LDAP
( apLdap ( apLdap
, campusLogin , campusLogin
, CampusUserException(..) , CampusUserException(..)
, campusUser , campusUser, campusUser'
, CampusMessage(..) , CampusMessage(..)
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
) where ) where
import Import.NoFoundation hiding (userEmail, userDisplayName) import Import.NoFoundation
import Network.Connection import Network.Connection
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
@ -80,6 +80,8 @@ data CampusUserException = CampusUserLdapError LdapPoolError
instance Exception CampusUserException instance Exception CampusUserException
makePrisms ''CampusUserException
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) 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 campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
Ldap.bind ldap ldapDn ldapPassword 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 , 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 campusForm :: ( RenderMessage site FormMessage
, RenderMessage site CampusMessage , RenderMessage site CampusMessage

39
src/Foundation.hs
View File

@ -310,6 +310,7 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr
embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''UploadModeDescr id
embedRenderMessage ''UniWorX ''SecretJSONFieldException id embedRenderMessage ''UniWorX ''SecretJSONFieldException id
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
embedRenderMessage ''UniWorX ''SchoolFunction id
embedRenderMessage ''UniWorX ''AuthenticationMode 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 CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId 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.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh 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 AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserAdminSchool E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId 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.^. AllocationTerm E.==. E.val tid
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
return Authorized 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 routes: access to any admin is granted here
_other -> $cachedHereBinary mAuthId . exceptT return return $ do _other -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
return Authorized return Authorized
tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ 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 AdminHijackUserR cID -> exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
uid <- decrypt cID uid <- decrypt cID
otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] otherSchoolsFunctions <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] mySchools <- lift $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] [] guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthNoEscalation r r -> $unsupportedAuthPredicate AuthNoEscalation r
tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
@ -680,7 +688,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
-- lecturer for any school will do -- lecturer for any school will do
_ -> $cachedHereBinary mAuthId . exceptT return return $ do _ -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
return Authorized return Authorized
tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@ -1725,7 +1733,7 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb AdminErrMsgR = return ("Test" , Just AdminR) breadcrumb AdminErrMsgR = return ("Test" , Just AdminR)
breadcrumb SchoolListR = return ("Institute" , 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 SchoolNewR = return ("Neu" , Just SchoolListR)
breadcrumb InfoR = return ("Information" , Nothing) breadcrumb InfoR = return ("Information" , Nothing)
@ -2055,7 +2063,7 @@ pageActions (UsersR) =
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuLecturerInvite , menuItemLabel = MsgMenuLecturerInvite
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminNewLecturerInviteR , menuItemRoute = SomeRoute AdminNewFunctionaryInviteR
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
@ -2883,13 +2891,6 @@ pageHeading (TermSchoolCourseListR tid ssh)
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgTermSchoolCourseListHeading tid school 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) pageHeading (CourseListR)
= Just $ i18nHeading $ MsgCourseListTitle = Just $ i18nHeading $ MsgCourseListTitle
pageHeading CourseNewR pageHeading CourseNewR

4
src/Handler/Course/Application/Edit.hs
View File

@ -19,8 +19,8 @@ postCAEditR tid ssh csh cID = do
mAlloc <- traverse getEntity404 $ courseApplicationAllocation app mAlloc <- traverse getEntity404 $ courseApplicationAllocation app
appUser <- get404 $ courseApplicationUser app appUser <- get404 $ courseApplicationUser app
isAdmin <- case mAlloc of isAdmin <- case mAlloc of
Just alloc -> exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool] Just alloc -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. alloc ^. _entityVal . _allocationSchool, UserFunctionFunction ==. SchoolAdmin]
Nothing -> exists [UserAdminUser ==. uid, UserAdminSchool ==. course ^. _entityVal . _courseSchool] Nothing -> exists [UserFunctionUser ==. uid, UserFunctionSchool ==. course ^. _entityVal . _courseSchool, UserFunctionFunction ==. SchoolAdmin]
return (mAlloc, course, app, isAdmin, appUser) return (mAlloc, course, app, isAdmin, appUser)
afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR

25
src/Handler/Course/Edit.hs
View File

@ -105,10 +105,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
uid <- liftHandlerT requireAuthId uid <- liftHandlerT requireAuthId
(lecSchools, admSchools) <- liftHandlerT . runDB $ (,) userSchools <- liftHandlerT . runDB $ map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] []
<$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
<*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] )
let userSchools = lecSchools ++ admSchools
termsField <- case template of termsField <- case template of
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin -- 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) _ -> (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 validateCourse CourseForm{..} = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId 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 MsgRenderer mr <- getMsgRenderer
allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust
@ -291,7 +288,7 @@ validateCourse CourseForm{..} = do
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if
| is _Just userAdmin | userAdmin
-> return Nothing -> return Nothing
| NTop allocationStaffRegisterTo <= NTop (Just now) | NTop allocationStaffRegisterTo <= NTop (Just now)
-> Just . courseCapacity <$> getJust cid -> Just . courseCapacity <$> getJust cid
@ -309,7 +306,7 @@ validateCourse CourseForm{..} = do
( NTop cfRegFrom <= NTop cfDeRegUntil ( NTop cfRegFrom <= NTop cfDeRegUntil
, MsgCourseDeregistrationEndMustBeAfterStart , MsgCourseDeregistrationEndMustBeAfterStart
) )
, ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin , ( bool (anyOf (traverse . _Right . _1) (== uid) cfLecturers) True userAdmin
, MsgCourseUserMustBeLecturer , MsgCourseUserMustBeLecturer
) )
, ( is _Nothing cfAllocation || is _Just cfCapacity , ( is _Nothing cfAllocation || is _Just cfCapacity
@ -357,8 +354,9 @@ getCourseNewR = do
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
let lecturersSchool = let lecturersSchool =
E.exists $ E.from $ \user -> E.exists $ E.from $ \user ->
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid E.where_ $ user E.^. UserFunctionUser E.==. E.val uid
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool
E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer
let courseCreated c = let courseCreated c =
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
@ -527,17 +525,16 @@ courseEditHandler miButtonAction mbCourseForm = do
, formEncoding = formEnctype , 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 upsertAllocationCourse cid cfAllocation = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId
Course{..} <- getJust cid Course{..} <- getJust cid
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse 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 doEdit <- if
| is _Just userAdmin | userAdmin
-> return True -> return True
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation | Just Allocation{allocationStaffRegisterTo} <- prevAllocation
, NTop allocationStaffRegisterTo <= NTop (Just now) , NTop allocationStaffRegisterTo <= NTop (Just now)

2
src/Handler/Course/LecturerInvite.hs
View File

@ -61,7 +61,7 @@ lecturerInvitationConfig = InvitationConfig{..}
getKeyBy404 $ TermSchoolCourseShort tid csh ssh getKeyBy404 $ TermSchoolCourseShort tid csh ssh
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

2
src/Handler/Course/ParticipantInvite.hs
View File

@ -74,7 +74,7 @@ participantInvitationConfig = InvitationConfig{..}
getKeyBy404 $ TermSchoolCourseShort tid csh ssh getKeyBy404 $ TermSchoolCourseShort tid csh ssh
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

2
src/Handler/Exam/CorrectorInvite.hs
View File

@ -61,7 +61,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 examCourse Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

2
src/Handler/Exam/RegistrationInvite.hs
View File

@ -69,7 +69,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
Course{..} <- get404 examCourse Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline let itExpiresAt = Just $ Just invDBExamRegistrationDeadline

59
src/Handler/Profile.hs
View File

@ -28,12 +28,27 @@ data SettingsForm = SettingsForm
, stgNotificationSettings :: NotificationSettings , stgNotificationSettings :: NotificationSettings
} }
data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKExamParticipant | NTKCorrector | NTKLecturer | NTKAdmin data NotificationTriggerKind
deriving (Eq, Ord, Enum, Bounded, Generic, Typeable) = NTKAll
instance Universe NotificationTriggerKind | NTKCourseParticipant
instance Finite NotificationTriggerKind | 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 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
@ -99,13 +114,10 @@ notificationForm template = wFormToAForm $ do
| isAdmin | isAdmin
= return False = return False
| Just uid <- mbUid | Just uid <- mbUid
, NTKAdmin <- nt , NTKFunctionary f <- nt
= fmap not . E.selectExists . E.from $ \userAdmin -> = fmap not . E.selectExists . E.from $ \userFunction ->
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
| Just uid <- mbUid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
, NTKLecturer <- nt
= fmap not . E.selectExists . E.from $ \userLecturer ->
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
| Just uid <- mbUid | Just uid <- mbUid
, NTKCorrector <- nt , NTKCorrector <- nt
= fmap not . E.selectExists . E.from $ \sheetCorrector -> = fmap not . E.selectExists . E.from $ \sheetCorrector ->
@ -141,9 +153,9 @@ notificationForm template = wFormToAForm $ do
NTSubmissionRated -> Just NTKCourseParticipant NTSubmissionRated -> Just NTKCourseParticipant
NTSheetActive -> Just NTKCourseParticipant NTSheetActive -> Just NTKCourseParticipant
NTSheetSoonInactive -> Just NTKCourseParticipant NTSheetSoonInactive -> Just NTKCourseParticipant
NTSheetInactive -> Just NTKLecturer NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer
NTCorrectionsAssigned -> Just NTKCorrector NTCorrectionsAssigned -> Just NTKCorrector
NTCorrectionsNotDistributed -> Just NTKLecturer NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer
NTUserRightsUpdate -> Just NTKAll NTUserRightsUpdate -> Just NTKAll
NTUserAuthModeUpdate -> Just NTKAll NTUserAuthModeUpdate -> Just NTKAll
NTExamResult -> Just NTKExamParticipant NTExamResult -> Just NTKExamParticipant
@ -255,14 +267,7 @@ getProfileDataR = do
makeProfileData :: Entity User -> DB Widget makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do makeProfileData (Entity uid User{..}) = do
-- MsgRenderer mr <- getMsgRenderer -- MsgRenderer mr <- getMsgRenderer
admin_rights <- E.select $ E.from $ \(adright `E.InnerJoin` school) -> do functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
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)
lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do 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.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
@ -314,7 +319,7 @@ mkOwnedCoursesTable =
return $ indicatorCell -- return True if one cell is produced here return $ indicatorCell -- return True if one cell is produced here
`mappend` termCell tid `mappend` termCell tid
, sortable (Just "school") (i18nCell MsgCourseSchool) $ , sortable (Just "school") (i18nCell MsgCourseSchool) $
schoolCell <$> view (_dbrOutput . _1 . re _Just) schoolCell <$> view (_dbrOutput . _1)
<*> view (_dbrOutput . _2 ) <*> view (_dbrOutput . _2 )
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view _dbrOutput courseCellCL <$> view _dbrOutput
@ -362,8 +367,8 @@ mkEnrolledCoursesTable =
, sortable (Just "term") (i18nCell MsgTerm) $ , sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view ( _courseTerm . re _Just) schoolCell <$> view _courseTerm
<*> view _courseSchool <*> view _courseSchool
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCell <$> view (_dbrOutput . _1 . _entityVal) courseCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "time") (i18nCell MsgRegistered) $ do , sortable (Just "time") (i18nCell MsgRegistered) $ do
@ -430,7 +435,7 @@ mkSubmissionTable =
, sortable (Just "term") (i18nCell MsgTerm) $ , sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1) termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just) schoolCell <$> view _1
<*> view _2 <*> view _2
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)
@ -512,7 +517,7 @@ mkSubmissionGroupTable =
, sortable (Just "term") (i18nCell MsgTerm) $ , sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1) termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view ( _1. re _Just) schoolCell <$> view _1
<*> view _2 <*> view _2
, sortable (Just "course") (i18nCell MsgCourse) $ , sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1) courseCellCL <$> view (_dbrOutput . _1)

18
src/Handler/School.hs
View File

@ -10,7 +10,7 @@ getSchoolListR :: Handler Html
getSchoolListR = do getSchoolListR = do
let let
schoolLink :: SchoolId -> SomeRoute UniWorX schoolLink :: SchoolId -> SomeRoute UniWorX
schoolLink ssh = SomeRoute $ SchoolShowR ssh schoolLink ssh = SomeRoute $ SchoolR ssh SchoolShowR
dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _ dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
dbtSQLQuery = return dbtSQLQuery = return
@ -84,11 +84,11 @@ postSchoolShowR ssh = do
runDB $ do runDB $ do
update ssh [ SchoolName =. sfName ] update ssh [ SchoolName =. sfName ]
addMessageI Success $ MsgSchoolUpdated ssh addMessageI Success $ MsgSchoolUpdated ssh
redirect $ SchoolShowR ssh redirect $ SchoolR ssh SchoolShowR
let sfView' = wrapForm sfView FormSettings let sfView' = wrapForm sfView FormSettings
{ formMethod = POST { formMethod = POST
, formAction = Just . SomeRoute $ SchoolShowR ssh , formAction = Just . SomeRoute $ SchoolR ssh SchoolShowR
, formEncoding = sfEnctype , formEncoding = sfEnctype
, formAttrs = [] , formAttrs = []
, formSubmit = FormSubmit , formSubmit = FormSubmit
@ -102,20 +102,28 @@ postSchoolShowR ssh = do
getSchoolNewR, postSchoolNewR :: Handler Html getSchoolNewR, postSchoolNewR :: Handler Html
getSchoolNewR = postSchoolNewR getSchoolNewR = postSchoolNewR
postSchoolNewR = do postSchoolNewR = do
uid <- requireAuthId
((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing ((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing
formResult sfResult $ \SchoolForm{..} -> do formResult sfResult $ \SchoolForm{..} -> do
let ssh = SchoolKey sfShorthand let ssh = SchoolKey sfShorthand
insertOkay <- runDB $ do insertOkay <- runDB $ do
fmap (is _Just) $ insertUnique School didInsert <- fmap (is _Just) $ insertUnique School
{ schoolShorthand = sfShorthand { schoolShorthand = sfShorthand
, schoolName = sfName , schoolName = sfName
} }
when didInsert $
insert_ UserFunction
{ userFunctionUser = uid
, userFunctionSchool = ssh
, userFunctionFunction = SchoolAdmin
}
return didInsert
if if
| insertOkay -> do | insertOkay -> do
addMessageI Success $ MsgSchoolCreated ssh addMessageI Success $ MsgSchoolCreated ssh
redirect $ SchoolShowR ssh redirect $ SchoolR ssh SchoolShowR
| otherwise | otherwise
-> addMessageI Error $ MsgSchoolExists ssh -> addMessageI Error $ MsgSchoolExists ssh

2
src/Handler/Sheet.hs
View File

@ -902,7 +902,7 @@ correctorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

2
src/Handler/Submission.hs
View File

@ -100,7 +100,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Submission{..}) _ = do invitationHeading (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet Sheet{..} <- getJust submissionSheet
return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
invitationTokenConfig (Entity _ Submission{..}) _ = do invitationTokenConfig (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse Course{..} <- getJust sheetCourse

2
src/Handler/Tutorial.hs
View File

@ -258,7 +258,7 @@ tutorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 tutorialCourse Course{..} <- get404 tutorialCourse
return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
invitationTokenConfig _ _ = do invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing

274
src/Handler/Users.hs
View File

@ -58,30 +58,20 @@ getUsersR = do
-- (AdminUserR <$> encrypt uid) -- (AdminUserR <$> encrypt uid)
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication , 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 , flip foldMap universeF $ \function ->
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
E.orderBy [E.asc $ school E.^. SchoolShorthand] E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
return $ school E.^. SchoolShorthand E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
return [whamlet| E.orderBy [E.asc $ school E.^. SchoolShorthand]
$newline never return $ school E.^. SchoolShorthand
<ul .list--inline .list--comma-separated> return [whamlet|
$forall (E.Value sh) <- schools $newline never
<li>#{sh} <ul .list--inline .list--comma-separated>
|] $forall (E.Value sh) <- schools
, sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do <li>#{sh}
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}
|]
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
cID <- encrypt uid cID <- encrypt uid
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
@ -142,14 +132,8 @@ getUsersR = do
, ( "school", FilterColumn $ \user criterion -> if , ( "school", FilterColumn $ \user criterion -> if
| Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> let schools = E.valList (Set.toList criterion) in | otherwise -> let schools = E.valList (Set.toList criterion) in
E.exists ( E.from $ \ulectr -> do E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
E.where_ $ ulectr E.^. UserLecturerUser E.==. user E.^. UserId E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
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
)
) )
] ]
, dbtFilterUI = \mPrev -> mconcat , dbtFilterUI = \mPrev -> mconcat
@ -199,56 +183,57 @@ getAdminUserR = postAdminUserR
postAdminUserR uuid = do postAdminUserR uuid = do
adminId <- requireAuthId adminId <- requireAuthId
uid <- decrypt uuid uid <- decrypt uuid
let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal) (user@User{..}, adminSchools, functions, schools) <- runDB $ do
let unValueRights (school, E.Value isAdmin, E.Value isLecturer) = (school,isAdmin,isLecturer) user <- get404 uid
(user@User{..}, fromSchoolList -> adminSchools, fmap unValueRights -> userRights) <- runDB $ (,,)
<$> get404 uid schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do
<*> selectList [UserAdminUser ==. adminId] [] E.on $ userFunction E.?. UserFunctionSchool E.==. E.just (school E.^. SchoolId)
<*> E.select ( E.from $ \school -> do E.&&. userFunction E.?. UserFunctionUser E.==. E.just (E.val uid)
E.orderBy [E.asc $ school E.^. SchoolName] let isAdmin = E.exists . E.from $ \adminFunction ->
let schAdmin = E.exists $ E.from $ \userAdmin -> do E.where_ $ adminFunction E.^. UserFunctionUser E.==. E.val adminId
E.where_ $ userAdmin E.^. UserAdminSchool E.==. school E.^. SchoolId E.&&. adminFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
let schLecturer = E.exists $ E.from $ \userLecturer -> do return (school, userFunction E.?. UserFunctionFunction, isAdmin)
E.where_ $ userLecturer E.^. UserLecturerSchool E.==. school E.^. SchoolId
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid return ( user
return (school,schAdmin,schLecturer) , 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 -- 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 userRightsForm = identifyForm FIDuserRights $ \csrf -> do
boxRights <- forM userRights $ \(school@(Entity sid _), isAdmin, isLecturer) -> boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if
if Set.member sid adminSchools | sid `Set.member` adminSchools
then do -> mpopt checkBoxField "" . Just $ (function, sid) `Set.member` functions
cbAdmin <- mreq checkBoxField "" (Just isAdmin) | otherwise
cbLecturer <- mreq checkBoxField "" (Just isLecturer) -> mforced checkBoxField "" $ (function, sid) `Set.member` functions
return (school, cbAdmin, cbLecturer) let result = Map.keysSet . Map.filter id <$> mapM (view _1) boxRights
else do return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
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"))
userAuthenticationForm :: Form ButtonAuthMode userAuthenticationForm :: Form ButtonAuthMode
userAuthenticationForm = buttonForm' $ if userAuthenticationForm = buttonForm' $ if
| userAuthentication == AuthLDAP -> [BtnAuthPWHash] | userAuthentication == AuthLDAP -> [BtnAuthPWHash]
| otherwise -> [BtnAuthLDAP, BtnPasswordReset] | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
let userRightsAction changes = do let userRightsAction changes = do
runDBJobs $ do let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes)
forM_ changes $ \(sid, userAdmin, userLecturer) -> updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff
if Set.notMember sid adminSchools if
then return () | not $ Set.null updates -> runDBJobs $ do
else do $logInfoS "user-rights-update" $ tshow updates
if userAdmin forM_ updates $ \(function, sid) -> do
then void . insertUnique $ UserAdmin uid sid $logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|]
else deleteBy $ UniqueUserAdmin uid sid if
if userLecturer | (function, sid) `Set.member` changes
then void . insertUnique $ UserLecturer uid sid -> void . insertUnique $ UserFunction uid sid function
else deleteBy $ UniqueSchoolLecturer uid sid | otherwise
-- Note: deleteWhere would not work well here since we filter by adminSchools -> deleteBy $ UniqueUserFunction uid sid function
queueDBJob . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference queueDBJob . JobQueueNotification . NotificationUserRightsUpdate uid $ Set.mapMonotonic (over _2 unSchoolKey) functions -- original rights to check for difference
addMessageI Info MsgAccessRightsSaved addMessageI Success MsgAccessRightsSaved
| otherwise
-> addMessageI Info MsgAccessRightsNotChanged
redirect $ AdminUserR uuid redirect $ AdminUserR uuid
userAuthenticationAction = \case userAuthenticationAction = \case
@ -435,54 +420,76 @@ postUserPasswordR cID = do
} }
instance IsInvitableJunction UserLecturer where instance IsInvitableJunction UserFunction where
type InvitationFor UserLecturer = School type InvitationFor UserFunction = School
data InvitableJunction UserLecturer = JunctionUserLecturer data InvitableJunction UserFunction = JunctionUserFunction
{ jFunction :: SchoolFunction
}
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData UserLecturer = InvDBDataUserLecturer data InvitationDBData UserFunction = InvDBDataUserFunction
{ invDBUserFunctionDeadline :: UTCTime
}
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData UserLecturer = InvTokenDataUserLecturer data InvitationTokenData UserFunction = InvTokenDataUserFunction
{ invTokenUserLecturerSchool :: SchoolShorthand { invTokenUserFunctionSchool :: SchoolShorthand
, invTokenUserFunctionFunction :: SchoolFunction
} }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso _InvitableJunction = iso
(\UserLecturer{..} -> (userLecturerUser, userLecturerSchool, JunctionUserLecturer)) (\UserFunction{..} -> (userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction))
(\(userLecturerUser, userLecturerSchool, JunctionUserLecturer) -> UserLecturer{..}) (\(userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction) -> UserFunction{..})
instance ToJSON (InvitableJunction UserLecturer) where instance ToJSON (InvitableJunction UserFunction) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 } , fieldLabelModifier = camelToPathPiece' 1
instance FromJSON (InvitableJunction UserLecturer) where }
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = 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 instance ToJSON (InvitationDBData UserFunction) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData UserLecturer) where instance FromJSON (InvitationDBData UserFunction) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance ToJSON (InvitationTokenData UserLecturer) where instance ToJSON (InvitationTokenData UserFunction) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData UserLecturer) where instance FromJSON (InvitationTokenData UserFunction) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
lecturerInvitationConfig :: InvitationConfig UserLecturer functionInvitationConfig :: InvitationConfig UserFunction
lecturerInvitationConfig = InvitationConfig{..} functionInvitationConfig = InvitationConfig{..}
where where
invitationRoute _ _ = return AdminLecturerInviteR invitationRoute _ _ = return AdminFunctionaryInviteR
invitationResolveFor InvTokenDataUserLecturer{..} = return $ SchoolKey invTokenUserLecturerSchool invitationResolveFor InvTokenDataUserFunction{..} = return $ SchoolKey invTokenUserFunctionSchool
invitationSubject (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSubjectSchoolLecturerInvitation schoolName invitationSubject (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
invitationHeading (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSchoolLecturerInviteHeading schoolName MsgRenderer mr <- getMsgRenderer
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSchoolLecturerInviteExplanation}|] return . SomeMessage . MsgMailSubjectSchoolFunctionInvitation schoolName $ mr invTokenUserFunctionFunction
invitationTokenConfig _ _ = do 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 itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing let itExpiresAt = Just $ Just invDBUserFunctionDeadline
itAddAuth = Nothing
itStartsAt = Nothing
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure $ (JunctionUserLecturer, ()) invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
invitationInsertHook _ _ _ _ = id 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 invitationUltDest (Entity ssh _) _ = do
currentTerm <- E.select . E.from $ \term -> do currentTerm <- E.select . E.from $ \term -> do
E.where_ $ term E.^. TermActive E.where_ $ term E.^. TermActive
@ -494,39 +501,50 @@ lecturerInvitationConfig = InvitationConfig{..}
_other -> CourseListR _other -> CourseListR
getAdminNewLecturerInviteR, postAdminNewLecturerInviteR :: Handler Html getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html
getAdminNewLecturerInviteR = postAdminNewLecturerInviteR getAdminNewFunctionaryInviteR = postAdminNewFunctionaryInviteR
postAdminNewLecturerInviteR = do postAdminNewFunctionaryInviteR = do
uid <- requireAuthId uid <- requireAuthId
userSchools <- runDB . E.select . E.from $ \userAdmin -> do userSchools <- runDB . E.select . E.from $ \userAdmin -> do
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val uid
return $ userAdmin E.^. UserAdminSchool E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
return $ userAdmin E.^. UserFunctionSchool
((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do ((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do
school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgLecturerInviteSchool) Nothing now <- liftIO getCurrentTime
users <- wreq (multiUserField False Nothing) (fslI MsgLecturerInviteField & setTooltip MsgMultiEmailFieldTip) Nothing let
return $ (,) <$> school <*> users 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 let (emails, uids) = partitionEithers $ Set.toList users
lift . runDBJobs $ do lift . runDBJobs $ do
forM_ uids $ \lecId -> 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) $ unless (null emails) $
tell . pure <=< messageI Success . MsgLecturersInvited $ length emails tell . pure <=< messageI Success . MsgFunctionariesInvited $ length emails
unless (null uids) $ unless (null uids) $
tell . pure <=< messageI Success . MsgLecturersAdded $ length uids tell . pure <=< messageI Success . MsgFunctionariesAdded $ length uids
siteLayoutMsg MsgLecturerInviteHeading $ do siteLayoutMsg MsgFunctionaryInviteHeading $ do
setTitleI MsgLecturerInviteHeading setTitleI MsgFunctionaryInviteHeading
wrapForm invitesWgt def wrapForm invitesWgt def
{ formEncoding = invitesEncoding { formEncoding = invitesEncoding
, formAction = Just $ SomeRoute AdminNewLecturerInviteR , formAction = Just $ SomeRoute AdminNewFunctionaryInviteR
} }
getAdminLecturerInviteR, postAdminLecturerInviteR :: Handler Html getAdminFunctionaryInviteR, postAdminFunctionaryInviteR :: Handler Html
getAdminLecturerInviteR = postAdminLecturerInviteR getAdminFunctionaryInviteR = postAdminFunctionaryInviteR
postAdminLecturerInviteR = invitationR lecturerInvitationConfig postAdminFunctionaryInviteR = invitationR functionInvitationConfig

6
src/Handler/Utils/Invitations.hs
View File

@ -122,7 +122,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
-- ^ Subject of the e-mail which sends the token to the user -- ^ Subject of the e-mail which sends the token to the user
, invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX) , invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
-- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR` -- ^ 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`) -- ^ 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 , invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig
-- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently) -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
@ -222,7 +222,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
jwt <- encodeToken token jwt <- encodeToken token
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat 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{..} queueDBJob JobInvitation{..}
@ -308,7 +308,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
ur <- getUrlRenderParams ur <- getUrlRenderParams
heading <- invitationHeading fEnt iData 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 fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
Nothing -> do Nothing -> do

10
src/Handler/Utils/Table/Cells.hs
View File

@ -234,18 +234,14 @@ termCell tid = anchorCell link name
termCellCL :: IsDBTable m a => CourseLink -> DBCell m a termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
termCellCL (tid,_,_) = termCell tid termCellCL (tid,_,_) = termCell tid
schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a schoolCell :: IsDBTable m a => TermId -> SchoolId -> DBCell m a
schoolCell (Just tid) ssh = anchorCell link name schoolCell tid ssh = anchorCell link name
where where
link = TermSchoolCourseListR tid ssh link = TermSchoolCourseListR tid ssh
name = toWgt 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 :: 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 :: IsDBTable m a => CourseLink -> DBCell m a
courseCellCL (tid,ssh,csh) = anchorCell link name courseCellCL (tid,ssh,csh) = anchorCell link name

19
src/Jobs/Handler/QueueNotification.hs
View File

@ -2,9 +2,9 @@ module Jobs.Handler.QueueNotification
( dispatchJobQueueNotification ( dispatchJobQueueNotification
) where ) where
import Import hiding ((\\)) import Import
import Data.List (nub, (\\)) import Data.List (nub)
import Jobs.Types import Jobs.Types
@ -12,6 +12,8 @@ import qualified Database.Esqueleto as E
import Utils.Sql import Utils.Sql
import Jobs.Queue import Jobs.Queue
import qualified Data.Set as Set
dispatchJobQueueNotification :: Notification -> Handler () dispatchJobQueueNotification :: Notification -> Handler ()
dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
@ -59,14 +61,15 @@ determineNotificationCandidates NotificationUserRightsUpdate{..} = do
-- always send to affected user -- always send to affected user
affectedUser <- selectList [UserId ==. nUser] [] affectedUser <- selectList [UserId ==. nUser] []
-- send to same-school admins only if there was an update -- send to same-school admins only if there was an update
currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] [] currentAdminSchools <- setOf (folded . _entityVal . _userFunctionSchool) <$> selectList [UserFunctionUser ==. nUser, UserFunctionFunction ==. SchoolAdmin] []
let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- nOriginalRights ] let oldAdminSchools = setOf (folded . filtered ((== SchoolAdmin) . view _1) . _2 . from _SchoolId) nOriginalRights
newAdminSchools = currentAdminSchools \\ oldAdminSchools newAdminSchools = currentAdminSchools `Set.difference` oldAdminSchools
affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do
E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId E.on $ admin E.^. UserFunctionUser E.==. user E.^. UserId
E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools E.where_ $ admin E.^. UserFunctionSchool `E.in_` E.valList (Set.toList newAdminSchools)
E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
return user return user
return $ nub $ affectedUser <> affectedAdmins return . nub $ affectedUser <> affectedAdmins
determineNotificationCandidates NotificationUserAuthModeUpdate{..} determineNotificationCandidates NotificationUserAuthModeUpdate{..}
= selectList [UserId ==. nUser] [] = selectList [UserId ==. nUser] []
determineNotificationCandidates notif@NotificationExamResult{..} = do determineNotificationCandidates notif@NotificationExamResult{..} = do

17
src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
View File

@ -6,24 +6,25 @@ module Jobs.Handler.SendNotification.UserRightsUpdate
import Import import Import
import Handler.Utils.Database
import Handler.Utils.Mail import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils import Jobs.Handler.SendNotification.Utils
import qualified Data.Map as Map
import qualified Data.Set as Set
import Text.Hamlet import Text.Hamlet
-- import qualified Data.CaseInsensitive as CI -- 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 dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMailT jRecipient $ do
(User{..}, adminSchools, lecturerSchools) <- liftHandlerT . runDB $ do (User{..}, functions) <- liftHandlerT . runDB $ do
user <-getJust nUser user <- getJust nUser
adminSchools <- getSchoolsOf nUser UserAdminSchool UserAdminUser functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. nUser] []
lecturerSchools <- getSchoolsOf nUser UserLecturerSchool UserLecturerUser return (user, functions)
return (user,adminSchools,lecturerSchools)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
-- MsgRenderer mr <- getMailMsgRenderer -- MsgRenderer mr <- getMailMsgRenderer
editNotifications <- mkEditNotifications jRecipient editNotifications <- mkEditNotifications jRecipient
addAlternatives $ addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))

4
src/Jobs/Handler/SendNotification/Utils.hs
View File

@ -1,5 +1,6 @@
module Jobs.Handler.SendNotification.Utils module Jobs.Handler.SendNotification.Utils
( mkEditNotifications ( mkEditNotifications
, ihamletSomeMessage
) where ) where
import Import import Import
@ -9,6 +10,9 @@ import Text.Hamlet
import qualified Data.HashSet as HashSet 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 :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandlerT $ do mkEditNotifications uid = liftHandlerT $ do
cID <- encrypt uid cID <- encrypt uid

2
src/Jobs/Types.hs
View File

@ -57,7 +57,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetInactive { nSheet :: SheetId } | NotificationSheetInactive { nSheet :: SheetId }
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId } | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
| NotificationCorrectionsNotDistributed { 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 } | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
| NotificationExamResult { nExam :: ExamId } | NotificationExamResult { nExam :: ExamId }
deriving (Eq, Ord, Show, Read, Generic, Typeable) deriving (Eq, Ord, Show, Read, Generic, Typeable)

31
src/Model/Migration.hs
View File

@ -454,6 +454,37 @@ customMigrations = Map.fromListWith (>>)
whenM (tableExists "allocation_deregister") $ do whenM (tableExists "allocation_deregister") $ do
[executeQQ|ALTER TABLE allocation_deregister DROP COLUMN IF EXISTS allocation;|] [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"';
|]
)
] ]

1
src/Model/Types.hs
View File

@ -12,3 +12,4 @@ import Model.Types.Security as Types
import Model.Types.Sheet as Types import Model.Types.Sheet as Types
import Model.Types.Submission as Types import Model.Types.Submission as Types
import Model.Types.Misc as Types import Model.Types.Misc as Types
import Model.Types.School as Types

19
src/Model/Types/School.hs Normal file
View 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
View 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|]) []
]
]
]

3
src/Utils.hs
View File

@ -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 :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
setMapMaybe f = Set.fromList . mapMaybe f . Set.toList 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 -- -- Maps --
---------- ----------

2
src/Utils/Lens.hs
View File

@ -169,6 +169,8 @@ makeLenses_ ''File
makeLenses_ ''School makeLenses_ ''School
makeLenses_ ''UserFunction
-- makeClassy_ ''Load -- makeClassy_ ''Load

28
templates/mail/userRightsUpdate.hamlet
View File

@ -11,25 +11,21 @@ $newline never
} }
<body> <body>
<h1> <h1>
_{MsgMailUserRightsIntro userDisplayName userEmail} _{SomeMessage $ MsgMailUserRightsIntro userDisplayName userEmail}
$with numSchools <- length adminSchools <dl>
$if numSchools > 0 $forall (function, schools) <- Map.toList functions
<p> <dt>_{SomeMessage $ function}
<h2>_{MsgAdminFor} _{MsgForSchools numSchools} <dd>
<ul> <ul>
$forall sn <- adminSchools $forall sn <- schools
<li>#{sn} <li>
$with numSchools <- length lecturerSchools #{sn}
$with numSchools <- maybe 0 Set.size $ Map.lookup SchoolLecturer functions
$if numSchools > 0 $if numSchools > 0
<p>
<h2>_{MsgLecturerFor} _{MsgForSchools numSchools}
<ul>
$forall sn <- lecturerSchools
<li>#{sn}
<p> <p>
<a href=@{CourseNewR}> <a href=@{CourseNewR}>
_{MsgMailLecturerRights numSchools} _{SomeMessage $ MsgMailLecturerRights numSchools}
$else $else
<p>_{MsgMailNoLecturerRights} <p>_{SomeMessage $ MsgMailNoLecturerRights}
^{editNotifications} ^{ihamletSomeMessage editNotifications}

17
templates/profileData.hamlet
View File

@ -16,22 +16,13 @@
#{llogin} #{llogin}
$nothing $nothing
_{MsgNever} _{MsgNever}
$if not $ null admin_rights $forall (function, schools) <- Map.toList functions
<dt .deflist__dt>_{MsgAdminFor} <dt .deflist__dt>_{function}
<dd .deflist__dd> <dd .deflist__dd>
<ul .list-ul> <ul .list-ul>
$forall (E.Value institute) <- admin_rights $forall ssh <- schools
<li .list-ul__item> <li .list-ul__item>
<a href=@{SchoolShowR $ SchoolKey institute}> #{ssh}
#{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}
$if not $ null lecture_corrector $if not $ null lecture_corrector
<dt .deflist__dt> Korrektor <dt .deflist__dt> Korrektor
<dd .deflist__dd> <dd .deflist__dd>

19
templates/widgets/user-rights-form/user-rights-form.hamlet
View File

@ -5,10 +5,15 @@ $newline never
<tr .table__row .table__row--head> <tr .table__row .table__row--head>
<th> <th>
$# empty cell $# empty cell
<th .table__th>_{MsgAdminFor} $forall function <- allFunctions
<th .table__th>_{MsgLecturerFor} <th .table__th>
$forall (Entity _ (School name _), (_,cbAdmin), (_,cbLecturer)) <- boxRights _{function}
<tr .table__row> $forall school <- schools
<th .table__th>#{name} $with Entity sid School{schoolName} <- school
<td .table__td>^{fvInput cbAdmin} <tr .table__row>
<td .table__td>^{fvInput cbLecturer} <th .table__th>
#{schoolName}
$forall function <- allFunctions
<td .table__td>
$maybe (_, boxView) <- Map.lookup (function, sid) boxRights
^{fvInput boxView}