feat: add user-system-function

messages/uniworx/de-de-formal.msg

@@ -765,6 +765,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 +1017,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
@@ -2750,3 +2757,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

@@ -762,6 +762,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 +1017,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
@@ -2751,3 +2758,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,10 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation
     school   SchoolId
     function SchoolFunction
     UniqueUserFunction user school function
+UserSystemFunction
+    user     UserId
+    function SystemFunction
+    UniqueUserSystemFunction user function
 UserExamOffice
     user     UserId
     field    StudyTermsId

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/Handler/Users.hs

@@ -277,7 +277,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 +289,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] []
+      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 +315,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 +373,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 . insertUnique $ UserSystemFunction uid func
+                  | otherwise
+                    -> deleteBy $ UniqueUserSystemFunction uid func
+                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 +400,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/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/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}