Merge branch '628-institut-ubergreifende-rollen' into 'master'

Resolve "Institut-übergreifende Rollen"

Closes #628

See merge request uni2work/uni2work!24

messages/uniworx/de-de-formal.msg

@@ -457,6 +457,7 @@ UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut e
 UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
 UnauthorizedExamOffice: Sie sind nicht mit Prüfungsverwaltung beauftragt.
 UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer, für die Sie mit der Prüfungsverwaltung beauftragt sind.
+UnauthorizedSystemExamOffice: Sie sind nicht mit systemweiter Prüfungsverwaltung beauftragt.
 UnauthorizedExternalExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer, für die Sie mit der Prüfungsverwaltung beauftragt sind.
 UnauthorizedEvaluation: Sie sind nicht mit der Kursumfragenverwaltung beauftragt.
 UnauthorizedAllocationAdmin: Sie sind nicht mit der Administration von Zentralanmeldungen beauftragt.
@@ -765,6 +766,9 @@ CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"}
 UserListTitle: Komprehensive Benutzerliste
 AccessRightsSaved: Berechtigungen erfolgreich verändert
 AccessRightsNotChanged: Berechtigungen wurden nicht verändert
+UserSystemFunctions: Systemweite Rollen
+UserSystemFunctionsSaved: Systemweite Rollen gespeichert
+UserSystemFunctionsNotChanged: Es wurden keine systemweiten Rollen angepasst
 
 LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"}
 
@@ -1014,6 +1018,10 @@ MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende U
 MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte.
 MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen.
 
+MailSubjectUserSystemFunctionsUpdate name@Text: Berechtigungen für #{name} aktualisiert
+MailUserSystemFunctionsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende Uni2work nicht-institutsbezogene Berechtigungen:
+MailUserSystemFunctionsNoFunctions: Keine
+
 MailSubjectUserAuthModeUpdate: Ihr Uni2work-Login
 UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Campus-Kennung in Uni2work einloggen
 UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer Uni2work-internen Kennung in Uni2work einloggen
@@ -1448,6 +1456,7 @@ AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespe
 AuthTagFree: Seite ist universell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
 AuthTagExamOffice: Nutzer ist mit Prüfungsverwaltung beauftragt
+AuthTagSystemExamOffice: Nutzer ist mit systemweiter Prüfungsverwaltung beauftragt
 AuthTagEvaluation: Nutzer ist mit Kursumfragenverwaltung beauftragt
 AuthTagAllocationAdmin: Nutzer ist mit der Administration von Zentralanmeldungen beauftragt
 AuthTagToken: Nutzer präsentiert Authorisierungs-Token
@@ -2750,3 +2759,6 @@ SheetPersonalisedFilesUsersList: Liste von Teilnehmern mit personalisierten Übu
 AdminCrontabNotGenerated: (Noch) keine Crontab generiert
 CronMatchAsap: ASAP
 CronMatchNone: Nie
+
+SystemExamOffice: Prüfungsverwaltung
+SystemFaculty: Fakultätsmitglied

messages/uniworx/en-eu.msg

@@ -457,6 +457,7 @@ UnauthorizedExamOffice: You are not part of an exam office.
 UnauthorizedEvaluation: You are not charged with course evaluation.
 UnauthorizedAllocationAdmin: You are not charged with the administration of central allocations.
 UnauthorizedExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam.
+UnauthorizedSystemExamOffice: You are not charged with system wide exam administration
 UnauthorizedExternalExamExamOffice: You are not part of the appropriate exam office for any of the participants of this exam.
 UnauthorizedSchoolLecturer: You are no lecturer for this department.
 UnauthorizedLecturer: You are no administrator for this course.
@@ -762,6 +763,9 @@ CorrectorsFor n: #{pluralEN n "Corrector" "Correctors"}
 UserListTitle: Comprehensive list of users
 AccessRightsSaved: Successfully updated permissions
 AccessRightsNotChanged: Permissions left unchanged
+UserSystemFunctions: System wide roles
+UserSystemFunctionsSaved: Successfully saved system wide roles
+UserSystemFunctionsNotChanged: No system wide roles were changed
 
 LecturersForN n: #{pluralEN n "Lecturer" "Lecturers"}
 
@@ -1014,6 +1018,10 @@ MailUserRightsIntro name email: #{name} <#{email}> now has the following permiss
 MailNoLecturerRights: You don't currently have lecturer permissions for any department.
 MailLecturerRights n: As a lecturer you may create new courses within your #{pluralEN n "department" "departments"}.
 
+MailSubjectUserSystemFunctionsUpdate name: Permissions for #{name} changed
+MailUserSystemFunctionsIntro name email: #{name} <#{email}> now has the following, not school restricted, permissions:
+MailUserSystemFunctionsNoFunctions: None
+
 MailSubjectUserAuthModeUpdate: Your Uni2work login
 UserAuthModePWHashChangedToLDAP: You can now log in to Uni2work using your Campus-account
 UserAuthModeLDAPChangedToPWHash: You can now log in to Uni2work using your Uni2work-internal account
@@ -1448,6 +1456,7 @@ AuthPredsActiveChanged: Authorisation settings saved for the current session
 AuthTagFree: Page is freely accessable
 AuthTagAdmin: User is administrator
 AuthTagExamOffice: User is part of an exam office
+AuthTagSystemExamOffice: User is charged with system wide exam administration
 AuthTagEvaluation: User is charged with course evaluation
 AuthTagAllocationAdmin: User is charged with administration of central allocations
 AuthTagToken: User is presenting an authorisation-token
@@ -2751,3 +2760,6 @@ SheetPersonalisedFilesUsersList: List of course participants who have personalis
 AdminCrontabNotGenerated: Crontab not (yet) generated
 CronMatchAsap: ASAP
 CronMatchNone: Never
+
+SystemExamOffice: Exam office
+SystemFaculty: Faculty member

models/users.model

@@ -42,6 +42,12 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation
     school   SchoolId
     function SchoolFunction
     UniqueUserFunction user school function
+UserSystemFunction
+    user     UserId
+    function SystemFunction
+    manual   Bool
+    isOptOut Bool
+    UniqueUserSystemFunction user function
 UserExamOffice
     user     UserId
     field    StudyTermsId

routes

@@ -79,10 +79,10 @@
 /user/storage-key          StorageKeyR             POST        !free
 
 /exam-office               ExamOfficeR                         !exam-office:
-  /                        EOExamsR            GET
+  /                        EOExamsR            GET             !system-exam-office
   /fields                  EOFieldsR           GET POST
-  /users                   EOUsersR            GET POST
-  /users/invite            EOUsersInviteR      GET POST
+  /users                   EOUsersR            GET POST        !system-exam-office
+  /users/invite            EOUsersInviteR      GET POST        !system-exam-office
 
 /external-exam             EExamListR          GET             !lecturer !¬empty
 /external-exam/new         EExamNewR           GET POST        !lecturer

src/Auth/LDAP.hs

@@ -10,6 +10,7 @@ module Auth.LDAP
   , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
   , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
   , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
+  , ldapAffiliation
   ) where
 
 import Import.NoFoundation
@@ -68,7 +69,7 @@ userSearchSettings LdapConf{..} = mconcat
   , Ldap.derefAliases Ldap.DerefAlways
   ]
 
-ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester :: Ldap.Attr
+ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester, ldapAffiliation :: Ldap.Attr
 ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
 ldapUserDisplayName       = Ldap.Attr "displayName"
 ldapUserMatriculation     = Ldap.Attr "LMU-Stud-Matrikelnummer"
@@ -80,6 +81,7 @@ ldapUserFieldName         = Ldap.Attr "LMU-Stg-Fach"
 ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
 ldapSex                   = Ldap.Attr "schacGender"
 ldapUserSubTermsSemester  = Ldap.Attr "LMU-Stg-FachundFS"
+ldapAffiliation           = Ldap.Attr "eduPersonAffiliation"
 
 ldapUserEmail :: NonEmpty Ldap.Attr
 ldapUserEmail = Ldap.Attr "mail" :|

src/Foundation/Authorization.hs

@@ -324,6 +324,11 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
+tagAccessPredicate AuthSystemExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
+  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+  isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
+  guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
+  return Authorized
 tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of
   CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId

src/Foundation/I18n.hs

@@ -219,6 +219,7 @@ embedRenderMessage ''UniWorX ''UploadModeDescr id
 embedRenderMessage ''UniWorX ''SecretJSONFieldException id
 embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
 embedRenderMessage ''UniWorX ''SchoolFunction id
+embedRenderMessage ''UniWorX ''SystemFunction id
 embedRenderMessage ''UniWorX ''CsvPreset id
 embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
 embedRenderMessage ''UniWorX ''FavouriteReason id

src/Foundation/Yesod/Auth.hs

@@ -14,6 +14,7 @@ import Foundation.I18n
 import Handler.Utils.Profile
 import Handler.Utils.StudyFeatures
 import Handler.Utils.SchoolLdap
+import Handler.Utils.LdapSystemFunctions
 
 import Yesod.Auth.Message
 import Auth.LDAP
@@ -22,6 +23,7 @@ import qualified Data.CaseInsensitive as CI
 import qualified Control.Monad.Catch as C (Handler(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Ldap.Client as Ldap
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.ByteString as ByteString
 import qualified Data.Set as Set
@@ -425,6 +427,19 @@ upsertCampusUser plugin ldapData = do
 
   forM_ ss $ void . insertUnique . SchoolLdap Nothing
 
+  let
+    userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
+    userSystemFunctions' = do
+      (k, v) <- ldapData
+      guard $ k == ldapAffiliation
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      assertM' (not . Text.null) $ Text.strip str
+
+  iforM_ userSystemFunctions $ \func preset -> if
+    | preset -> void $ upsert (UserSystemFunction userId func False False) []
+    | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
+
   return user
   where
     insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())

src/Handler/Users.hs

@@ -101,6 +101,9 @@ postUsersR = do
                 $forall (E.Value sh) <- schools
                   <li>#{sh}
               |]
+      , sortable Nothing (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
+          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
+           in listCell' getFunctions i18nCell
       , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
           { formCellAttrs    = []
           , formCellLens     = id
@@ -277,7 +280,7 @@ getAdminUserR = postAdminUserR
 postAdminUserR uuid = do
     adminId <- requireAuthId
     uid <- decrypt uuid
-    (user@User{..}, adminSchools, functions, schools) <- runDB $ do
+    (user@User{..}, adminSchools, functions, schools, systemFunctions) <- runDB $ do
       user <- get404 uid
 
       schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do
@@ -289,10 +292,14 @@ postAdminUserR uuid = do
                    E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
         return (school, userFunction E.?. UserFunctionFunction, isAdmin)
 
+      systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] []
+      let systemFunctions = (`Set.member` systemFunctionsF) 
+
       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
+             , systemFunctions
              )
     let allFunctions = Set.fromList universeF
         allSchools   = Set.mapMonotonic entityKey schools
@@ -311,6 +318,8 @@ postAdminUserR uuid = do
         userAuthenticationForm = buttonForm' $ if
           | userAuthentication == AuthLDAP -> [BtnAuthPWHash]
           | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
+        systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False
+          where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func
     let userRightsAction changes = do
           let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes)
               updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff
@@ -367,8 +376,24 @@ postAdminUserR uuid = do
             queueJob' $ JobSendPasswordReset uid
             addMessageI Success MsgPasswordResetQueued
             redirect $ AdminUserR uuid
+
+        userSystemFunctionsAction newFuncs = do
+          let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions
+          if
+            | not $ Set.null symmDiff -> runDBJobs $ do
+                forM_ symmDiff $ \func -> if
+                  | newFuncs func
+                    -> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ]
+                  | otherwise
+                    -> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ]
+                queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions
+                addMessageI Success MsgUserSystemFunctionsSaved
+            | otherwise
+              -> addMessageI Info MsgUserSystemFunctionsNotChanged
+          redirect $ AdminUserR uuid
     ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm
     ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm
+    ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
     let rightsForm = wrapForm rightsFormWidget def
           { formAction = Just . SomeRoute $ AdminUserR uuid
           , formEncoding = rightsFormEnctype
@@ -378,8 +403,13 @@ postAdminUserR uuid = do
           , formEncoding = authFormEnctype
           , formSubmit = FormNoSubmit
           }
+        systemFunctionsForm = wrapForm systemFunctionsWidget def
+          { formAction = Just . SomeRoute $ AdminUserR uuid
+          , formEncoding = systemFunctionsEnctype
+          }
     formResult rightsResult userRightsAction
     formResult authResult userAuthenticationAction
+    formResult systemFunctionsResult userSystemFunctionsAction
     let heading =
           [whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|]
     -- Delete Button needed in data-delete

src/Handler/Utils/LdapSystemFunctions.hs

@@ -0,0 +1,13 @@
+module Handler.Utils.LdapSystemFunctions
+  ( determineSystemFunctions
+  ) where
+
+import Import.NoFoundation
+
+import qualified Data.Set as Set
+
+
+determineSystemFunctions :: Set (CI Text) -> (SystemFunction -> Bool)
+determineSystemFunctions ldapFuncs = \case
+  SystemExamOffice -> False
+  SystemFaculty -> "faculty" `Set.member` ldapFuncs

src/Jobs/Handler/QueueNotification.hs

@@ -113,6 +113,8 @@ determineNotificationCandidates = awaitForever $ \notif -> do
                   E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
              return user
            withNotif . yieldMany . nub $ affectedUser <> affectedAdmins
+    NotificationUserSystemFunctionsUpdate{..}
+      -> withNotif $ selectSource [UserId ==. nUser] []
     NotificationUserAuthModeUpdate{..}
       -> withNotif $ selectSource [UserId ==. nUser] []
     NotificationExamRegistrationActive{..}
@@ -295,6 +297,7 @@ classifyNotification NotificationSheetInactive{}                  = return NTShe
 classifyNotification NotificationCorrectionsAssigned{}            = return NTCorrectionsAssigned
 classifyNotification NotificationCorrectionsNotDistributed{}      = return NTCorrectionsNotDistributed
 classifyNotification NotificationUserRightsUpdate{}               = return NTUserRightsUpdate
+classifyNotification NotificationUserSystemFunctionsUpdate{}      = return NTUserRightsUpdate
 classifyNotification NotificationUserAuthModeUpdate{}             = return NTUserAuthModeUpdate
 classifyNotification NotificationExamRegistrationActive{}         = return NTExamRegistrationActive
 classifyNotification NotificationExamRegistrationSoonInactive{}   = return NTExamRegistrationSoonInactive

src/Jobs/Handler/SendNotification/UserRightsUpdate.hs

@@ -2,6 +2,7 @@
 
 module Jobs.Handler.SendNotification.UserRightsUpdate
   ( dispatchNotificationUserRightsUpdate
+  , dispatchNotificationUserSystemFunctionsUpdate
   ) where
 
 import Import
@@ -27,3 +28,16 @@ dispatchNotificationUserRightsUpdate  nUser _originalRights jRecipient = userMai
     editNotifications <- mkEditNotifications jRecipient
     addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
 
+
+dispatchNotificationUserSystemFunctionsUpdate :: UserId -> Set SystemFunction -> UserId -> Handler ()
+dispatchNotificationUserSystemFunctionsUpdate  nUser _originalSystemFunctions jRecipient = userMailT jRecipient $ do
+    (User{..}, functions)  <-  liftHandler . runDB $ do
+      user <- getJust nUser
+      functions <- map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. nUser] []
+      return (user, Set.fromList functions)
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+    setSubjectI $ MsgMailSubjectUserSystemFunctionsUpdate userDisplayName
+    -- MsgRenderer mr <- getMailMsgRenderer
+    editNotifications <- mkEditNotifications jRecipient
+    addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userSystemFunctionsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
+

src/Jobs/Types.hs

@@ -99,6 +99,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
                   | NotificationCorrectionsNotDistributed { nSheet :: SheetId }
                   | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
+                  | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
                   | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
                   | NotificationExamRegistrationActive { nExam :: ExamId }
                   | NotificationExamRegistrationSoonInactive { nExam :: ExamId }

src/Model/Types.hs

@@ -16,3 +16,4 @@ import Model.Types.School as Types
 import Model.Types.Allocation as Types
 import Model.Types.Languages as Types
 import Model.Types.File as Types
+import Model.Types.User as Types

src/Model/Types/Security.hs

@@ -52,6 +52,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthTutor
   | AuthTutorControl
   | AuthExamOffice
+  | AuthSystemExamOffice
   | AuthEvaluation
   | AuthAllocationAdmin
   | AuthAllocationRegistered

src/Model/Types/User.hs

@@ -0,0 +1,16 @@
+module Model.Types.User where
+
+import Import.NoModel
+import Model.Types.TH.PathPiece
+
+
+data SystemFunction
+  = SystemExamOffice
+  | SystemFaculty
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite, Hashable, NFData)
+
+nullaryPathPiece ''SystemFunction $ camelToPathPiece' 1
+pathPieceJSON ''SystemFunction
+pathPieceJSONKey ''SystemFunction
+derivePersistFieldPathPiece ''SystemFunction

src/Utils.hs

@@ -483,6 +483,9 @@ setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList
 setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
 setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
 
+setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
+setFromFunc = Set.fromList . flip filter universeF
+
 ----------
 -- Maps --
 ----------

src/Utils/Form.hs

@@ -215,6 +215,7 @@ data FormIdentifier
   | FIDDelete
   | FIDCourseRegister
   | FIDuserRights
+  | FIDUserSystemFunctions
   | FIDcUserNote
   | FIDcRegField
   | FIDcRegButton

templates/adminUser.hamlet

@@ -4,6 +4,7 @@ $newline never
 <section>
   <h3>
     _{MsgAdminUserRightsHeading}
+  ^{systemFunctionsForm}
   ^{rightsForm}
 <section>
   <h3>

templates/mail/userSystemFunctionsUpdate.hamlet

@@ -0,0 +1,21 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{SomeMessage $ MsgMailUserSystemFunctionsIntro userDisplayName userEmail}
+    <ul>
+      $forall function <- Set.toList functions
+        <li>_{SomeMessage function}
+      $if onull functions
+        <li>_{SomeMessage MsgMailUserSystemFunctionsNoFunctions}
+
+    ^{ihamletSomeMessage editNotifications}