feat(exam-office): subscription management for users & fields

messages/uniworx/de.msg

@@ -364,6 +364,7 @@ UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausg
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
+UnauthorizedExamOffice: Sie sind nicht Teil eines Prüfungsamts.
 UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
 UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
 UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen.
@@ -1045,6 +1046,9 @@ MenuExamNew: Neue Prüfung anlegen
 MenuExamEdit: Bearbeiten
 MenuExamUsers: Teilnehmer
 MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
+MenuExamOfficeExams: Prüfungen
+MenuExamOfficeFields: Fächer
+MenuExamOfficeUsers: Benutzer
 MenuLecturerInvite: Dozenten hinzufügen
 MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
 MenuCourseApplicationsFiles: Dateien aller Bewerbungen
@@ -1056,6 +1060,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate
 AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
 AuthTagFree: Seite ist universell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
+AuthTagExamOffice: Nutzer ist Teil eines Prüfungsamts
 AuthTagToken: Nutzer präsentiert Authorisierungs-Token
 AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
 AuthTagDeprecated: Seite ist nicht überholt
@@ -1628,4 +1633,21 @@ MailAllocationUnratedApplications: Für die unten aufgeführten Kurse liegen Bew
 
 MailSubjectAllocationOutdatedRatings allocation@AllocationName: Bereits bewertete Bewerbungen für ihre Kurse in der Zentralanmeldung „#{allocation}“ haben sich geändert
 MailAllocationOutdatedRatings: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der Zentralanmeldung an den jeweiligen Kurs gestellt wurden, die sich verändert haben, seit sie zuletzt bewertet wurden.
-MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet.
+MailAllocationOutdatedRatingsWarning: Bewerbungen deren Bewertung veraltet ist (d.h. die Bewerbung wurde nach der Bewertung verändert) zählen als nicht bewertet.
+
+ExamOfficeSubscribedUsers: Benutzer
+ExamOfficeSubscribedUsersTip: Sie können mehrere Matrikelnummern mit Komma separieren
+
+ExamOfficeSubscribedUsersExplanation: Für hier angegebene Benutzer können Sie (ungeachtet der Fächer des Studierenden) stets sämtliche Prüfungsergebnisse einsehen.
+ExamOfficeSubscribedFieldsExplanation: Sie können für alle Benutzer, die mindestens eines der angegeben Studienfächer studieren, sämtliche Prüfungsergebnisse einsehen. Sie haben zusätzlich die Möglichkeit anzugeben, ob es den Benutzern gestattet sein soll, dieser Einsicht im Einzelfall (pro Kurs) zu widersprechen.
+
+UserMatriculationNotFound matriculation@Text: Es existiert kein Uni2work-Benutzer mit Matrikelnummer „#{matriculation}“
+UserMatriculationAmbiguous matriculation@Text: Matrikelnummer „#{matriculation}“ ist nicht eindeutig
+
+TransactionExamOfficeUsersUpdated nDeleted@Int nAdded@Int: #{nAdded} Benutzer hinzugefügt, #{nDeleted} Benutzer gelöscht
+
+TransactionExamOfficeFieldsUpdated nUpdates@Int: #{nUpdates} #{pluralDE nUpdates "Studienfach" "Studienfächer"} angepasst
+ExamOfficeFieldNotSubscribed: —
+ExamOfficeFieldSubscribed: Einsicht
+ExamOfficeFieldForced: Forcierte Einsicht
+InvalidExamOfficeFieldMode parseErr@Text: Konnte „#{parseErr}“ nicht interpretieren

models/exam-office

@@ -0,0 +1,14 @@
+ExamOfficeField
+    office  UserId
+    field   StudyTermsId
+    forced  Bool
+    UniqueExamOfficeField office field
+ExamOfficeUser
+    office  UserId
+    user    UserId
+    UniqueExamOfficeUser office user
+ExamOfficeResultSynced
+    office  UserId
+    result  ExamResult
+    time    UTCTime
+    UniqueExamOfficeResultSynced office result

models/schools

@@ -13,4 +13,5 @@ SchoolLdap
     UniqueOrgUnit orgUnit
 SchoolTerms
     school  SchoolId
-    terms   StudyTermsId
+    terms   StudyTermsId
+    UniqueSchoolTerms school terms

routes

@@ -71,6 +71,11 @@
 /user/profile              ProfileDataR        GET             !free
 /user/authpreds            AuthPredsR          GET POST        !free
 
+/exam-office               ExamOfficeR                         !exam-office:
+  /                        EOExamsR            GET
+  /fields                  EOFieldsR           GET POST
+  /users                   EOUsersR            GET POST
+
 /term                      TermShowR           GET             !free
 /term/current              TermCurrentR        GET             !free
 /term/edit                 TermEditR           GET POST
@@ -163,6 +168,8 @@
     /users/new                  EAddUserR      GET POST
     /users/invite               EInviteR       GET POST
     /register                   ERegisterR         POST        !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
+    /grades                     EGradesR       GET             !exam-office
+    /grades/read                EGradesReadR       POST        !exam-office
   /apps                         CApplicationsR GET POST
   !/apps/files                  CAppsFilesR    GET
   /apps/#CryptoFileNameCourseApplication CourseApplicationR:

src/Application.hs

@@ -109,6 +109,7 @@ import Handler.SystemMessage
 import Handler.Health
 import Handler.Exam
 import Handler.Allocation
+import Handler.ExamOffice
 
 
 -- This line actually creates our YesodDispatch instance. It is the second half

src/Audit/Types.hs

@@ -98,6 +98,23 @@ data Transaction
     { transactionFile :: FileId
     }
 
+  | TransactionExamOfficeUserAdd
+    { transactionOffice :: UserId
+    , transactionUser :: UserId
+    }
+  | TransactionExamOfficeUserDelete
+    { transactionOffice :: UserId
+    , transactionUser :: UserId
+    }
+  | TransactionExamOfficeFieldEdit
+    { transactionOffice :: UserId
+    , transactionField :: StudyTermsId
+    }
+  | TransactionExamOfficeFieldDelete
+    { transactionOffice :: UserId
+    , transactionField :: StudyTermsId
+    }
+
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions

src/Database/Esqueleto/Utils.hs

@@ -13,7 +13,7 @@ module Database.Esqueleto.Utils
   , anyFilter, allFilter
   , orderByList
   , orderByOrd, orderByEnum
-  , lower, ciEq
+  , strip, lower, ciEq
   , selectExists
   , SqlHashable
   , sha256
@@ -194,6 +194,9 @@ orderByEnum = orderByList $ List.sortOn fromEnum universeF
 
 lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
 lower = E.unsafeSqlFunction "LOWER"
+  
+strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
+strip = E.unsafeSqlFunction "TRIM"
 
 ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
 ciEq a b = lower a E.==. lower b

src/Foundation.hs

@@ -652,6 +652,11 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
+tagAccessPredicate AuthExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] []
+    guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedExamOffice)
+    return Authorized
 tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
   lift . validateToken mAuthId route isWrite =<< askTokenUnsafe
 tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
@@ -1762,6 +1767,10 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (SchoolR ssh SchoolEditR) = return (original (unSchoolKey ssh), Just SchoolListR)
   breadcrumb SchoolNewR       = return ("Neu"          , Just SchoolListR)
 
+  breadcrumb (ExamOfficeR EOExamsR)  = return ("Prüfungen", Nothing)
+  breadcrumb (ExamOfficeR EOFieldsR) = return ("Fächer"   , Just $ ExamOfficeR EOExamsR)
+  breadcrumb (ExamOfficeR EOUsersR)  = return ("Benutzer" , Just $ ExamOfficeR EOExamsR)
+
   breadcrumb InfoR            = return ("Information"  , Nothing)
   breadcrumb InfoLecturerR    = return ("Veranstalter" , Just InfoR)
   breadcrumb DataProtR        = return ("Datenschutz"  , Just InfoR)
@@ -1971,6 +1980,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , return MenuItem
+      { menuItemType  = NavbarAside
+      , menuItemLabel = MsgMenuExamOfficeExams
+      , menuItemIcon  = Just "poll-h"
+      , menuItemRoute = SomeRoute $ ExamOfficeR EOExamsR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   , return MenuItem
       { menuItemType  = NavbarAside
       , menuItemLabel = MsgMenuUsers
@@ -2074,6 +2091,24 @@ pageActions (AdminR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (ExamOfficeR EOExamsR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamOfficeFields
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ ExamOfficeR EOFieldsR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamOfficeUsers
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ ExamOfficeR EOUsersR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (SchoolListR) =
   [ MenuItem
       { menuItemType  = PageActionPrime

src/Handler/Course/Application/List.hs

@@ -268,7 +268,7 @@ postCApplicationsR tid ssh csh = do
         , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
         , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
         , colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
-        , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
+        , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
         , colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
         , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
         , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)

src/Handler/ExamOffice.hs

@@ -0,0 +1,8 @@
+module Handler.ExamOffice
+  ( module Handler.ExamOffice
+  ) where
+
+import Handler.ExamOffice.Exams as Handler.ExamOffice
+import Handler.ExamOffice.Fields as Handler.ExamOffice
+import Handler.ExamOffice.Users as Handler.ExamOffice
+import Handler.ExamOffice.Exam as Handler.ExamOffice

src/Handler/ExamOffice/Exam.hs

@@ -0,0 +1,14 @@
+module Handler.ExamOffice.Exam
+  ( getEGradesR
+  , postEGradesReadR
+  ) where
+
+import Import
+
+-- | View a list of all users' grades that the current user has access to
+getEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEGradesR = fail "not implemented"
+
+-- | Mark all users' grades that the current user has access to as "read"
+postEGradesReadR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+postEGradesReadR = fail "not implemented"

src/Handler/ExamOffice/Exams.hs

@@ -0,0 +1,10 @@
+module Handler.ExamOffice.Exams
+  ( getEOExamsR
+  ) where
+
+import Import
+
+-- | List of all exams where the current user may (in her function as
+--   exam-office) access users grades
+getEOExamsR :: Handler Html
+getEOExamsR = fail "not implemented"

src/Handler/ExamOffice/Fields.hs

@@ -0,0 +1,116 @@
+module Handler.ExamOffice.Fields
+  ( getEOFieldsR
+  , postEOFieldsR
+  ) where
+
+import Import
+import Utils.Form
+
+import qualified Database.Esqueleto as E
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+  
+data ExamOfficeFieldMode
+  = EOFNotSubscribed
+  | EOFSubscribed
+  | EOFForced
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+embedRenderMessage ''UniWorX ''ExamOfficeFieldMode $ concat . set (ix 0) "ExamOfficeField" . splitCamel
+instance Universe ExamOfficeFieldMode
+instance Finite ExamOfficeFieldMode
+nullaryPathPiece ''ExamOfficeFieldMode $ camelToPathPiece' 1
+instance Default ExamOfficeFieldMode where
+  def = EOFNotSubscribed
+
+eofModeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m ExamOfficeFieldMode
+-- ^ Always required
+eofModeField = Field{..}
+  where
+    fieldEnctype = UrlEncoded
+    fieldView = \theId name attrs val _isReq -> $(widgetFile "widgets/fields/examOfficeFieldMode")
+    fieldParse = \e _ -> return $ parser e
+
+    parser [] = Right Nothing
+    parser (x:_)
+      | Just mode <- fromPathPiece x
+      = Right $ Just mode
+    parser (x:_)
+      = Left . SomeMessage $ MsgInvalidExamOfficeFieldMode x
+
+    isChecked :: Eq a => a -> Either Text a -> Bool
+    isChecked opt = either (const False) (== opt)
+
+
+makeExamOfficeFieldsForm :: UserId -> Maybe (Map StudyTermsId Bool) -> Form (Map StudyTermsId Bool)
+makeExamOfficeFieldsForm uid template = renderWForm FormStandard $ do
+  availableFields <- liftHandlerT . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do
+    E.on $ terms E.^. StudyTermsId E.==. schoolTerms E.^. SchoolTermsTerms
+    E.where_ . E.exists . E.from $ \userFunction ->
+      E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
+           E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
+           E.&&. userFunction E.^. UserFunctionSchool E.==. schoolTerms E.^. SchoolTermsSchool
+    return terms
+  let available = imap (\k terms -> (terms, view forced $ template >>= Map.lookup k)) $ toMapOf (folded .> _entityVal) availableFields
+
+      forced :: Iso' (Maybe Bool) ExamOfficeFieldMode
+      forced = iso fromForced toForced
+        where
+          fromForced = maybe EOFNotSubscribed $ bool EOFSubscribed EOFForced
+          toForced = \case
+            EOFNotSubscribed -> Nothing
+            EOFSubscribed    -> Just False
+            EOFForced        -> Just True
+
+  fmap (fmap (Map.mapMaybe $ review forced) . sequence) . forM available $ \(StudyTerms{..}, template')
+    -> let label = fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand
+        in wpopt eofModeField (fsl label) $ Just template'
+
+-- | Manage the list of `StudyTerms` this user (in her function as exam-office)
+--   has an interest in, i.e. that authorize her to view an users grades, iff
+--   they study one of the selected fields
+getEOFieldsR, postEOFieldsR :: Handler Html
+getEOFieldsR = postEOFieldsR
+postEOFieldsR = do
+  uid <- requireAuthId
+
+  oldFields <- liftHandlerT . runDB $ do
+    fields <- E.select . E.from $ \examOfficeField -> do
+      E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
+      return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
+    return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
+
+  ((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields
+
+  formResult fieldsRes $ \newFields -> do
+    liftHandlerT . runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if
+      | Just forced <- Map.lookup fieldId newFields
+      , fieldId `Map.member` oldFields -> do
+          updateBy (UniqueExamOfficeField uid fieldId) [ ExamOfficeFieldForced =. forced ]
+          audit $ TransactionExamOfficeFieldEdit uid fieldId
+      | Just forced <- Map.lookup fieldId newFields -> do
+          insert_ $ ExamOfficeField uid fieldId forced
+          audit $ TransactionExamOfficeFieldEdit uid fieldId
+      | otherwise -> do
+          deleteBy $ UniqueExamOfficeField uid fieldId
+          audit $ TransactionExamOfficeFieldDelete uid fieldId
+    addMessageI Success $ MsgTransactionExamOfficeFieldsUpdated (Set.size . Set.map (view _1) $ (setSymmDiff `on` assocsSet) newFields oldFields)
+    redirect $ ExamOfficeR EOExamsR
+
+  let
+    fieldsView' = wrapForm fieldsView def
+      { formAction = Just . SomeRoute $ ExamOfficeR EOFieldsR
+      , formEncoding = fieldsEnc
+      }
+
+  siteLayoutMsg MsgMenuExamOfficeFields $ do
+    setTitleI MsgMenuExamOfficeFields
+
+    [whamlet|
+      $newline never
+      <p>
+        _{MsgExamOfficeSubscribedFieldsExplanation}
+      ^{fieldsView'}
+    |]
+

src/Handler/ExamOffice/Users.hs

@@ -0,0 +1,102 @@
+module Handler.ExamOffice.Users
+  ( getEOUsersR
+  , postEOUsersR
+  ) where
+
+import Import
+import Utils.Form
+import Handler.Utils
+
+import qualified Database.Esqueleto as E
+
+import qualified Data.Set as Set
+import Data.Map ((!))
+  
+
+makeExamOfficeUsersForm :: Maybe (Set UserId) -> Form (Set UserId)
+makeExamOfficeUsersForm template = renderWForm FormStandard $ do
+  Just cRoute <- getCurrentRoute
+  
+  let
+    sortProj = over _1 ((readMay :: Text -> Maybe Integer) =<<) . view _2
+    
+    miAdd' :: (Text -> Text)
+           -> FieldView UniWorX
+           -> Form ([(UserId, _)] -> FormResult [(UserId, _)])
+    miAdd' nudge submitView csrf = do
+      MsgRenderer mr <- getMsgRenderer
+      (addRes, addView) <- mpreq userMatriculationField ("" & addName (nudge "matr") & addPlaceholder (mr MsgUserMatriculation)) Nothing
+      let
+        res' :: FormResult ([(UserId, _)] -> FormResult [(UserId, _)])
+        res' = addRes <&> \newUsers oldUsers -> if
+          | null newUsers
+            -> pure oldUsers
+          | otherwise
+            -> pure . nubOn (view _1) . sortOn sortProj
+               $ oldUsers ++ [ (uid, (userMatrikelnummer, userSurname, userDisplayName)) | Entity uid User{..} <- newUsers ]
+      return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add"))
+    miCell' :: (UserId, (Maybe UserMatriculation, UserSurname, UserDisplayName)) -> Widget
+    miCell' (_, (userMatr, userSName, userDName)) = $(widgetFile "widgets/massinput/examOfficeUsers/cell")
+    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+    miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag
+    miLayout' :: MassInputLayout ListLength _ ()
+    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examOfficeUsers/layout")
+    miIdent' :: Text
+    miIdent' = "exam-office-users"
+    fSettings :: FieldSettings UniWorX
+    fSettings = fslI MsgExamOfficeSubscribedUsers
+              & setTooltip MsgExamOfficeSubscribedUsersTip
+    fRequired :: Bool
+    fRequired = False
+
+  template' <- for template $ \uids -> fmap (sortOn sortProj) . liftHandlerT . runDB $ do
+    users <- E.select . E.from $ \user -> do
+      E.where_ $ user E.^. UserId `E.in_` E.valList (Set.toList uids)
+      return (user E.^. UserId, user E.^. UserMatrikelnummer, user E.^. UserSurname, user E.^. UserDisplayName)
+    return $ users <&> \(E.Value uid, E.Value matr, E.Value sName, E.Value dName) -> (uid, (matr, sName, dName))
+
+  fmap (Set.fromList . keys) <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
+    
+
+-- | Manage the list of users this user (in her function as exam-office)
+--   has an interest in, i.e. that authorize her to view their grades
+getEOUsersR, postEOUsersR :: Handler Html
+getEOUsersR = postEOUsersR
+postEOUsersR = do
+  uid <- requireAuthId
+
+  oldUsers <- liftHandlerT . runDB $ do
+    users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> do
+      E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser
+       E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid
+      return $ user E.^. UserId
+    return $ setOf (folded . _Value) users
+
+  ((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers
+
+  formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do
+    liftHandlerT . runDB . forM_ changes $ \change -> if
+      | change `Set.member` oldUsers -> do
+          deleteBy $ UniqueExamOfficeUser uid change
+          audit $ TransactionExamOfficeUserDelete uid change
+      | otherwise -> do
+          insert_ $ ExamOfficeUser uid change
+          audit $ TransactionExamOfficeUserAdd uid change
+    addMessageI Success $ MsgTransactionExamOfficeUsersUpdated (Set.size $ changes `Set.intersection` oldUsers) (Set.size $ changes `Set.difference` oldUsers)
+    redirect $ ExamOfficeR EOExamsR
+
+  let
+    usersView' = wrapForm usersView def
+      { formAction = Just . SomeRoute $ ExamOfficeR EOUsersR
+      , formEncoding = usersEnc
+      }
+
+  siteLayoutMsg MsgMenuExamOfficeUsers $ do
+    setTitleI MsgMenuExamOfficeUsers
+
+    [whamlet|
+      $newline never
+      <p>
+        _{MsgExamOfficeSubscribedUsersExplanation}
+      ^{usersView'}
+    |]

src/Handler/Utils/Form.hs

@@ -932,10 +932,10 @@ boolField :: ( MonadHandler m
              )
           => Field m Bool
 boolField = Field
-      { fieldParse = \e _ -> return $ boolParser e
-      , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool")
-    , fieldEnctype = UrlEncoded
-    }
+  { fieldParse = \e _ -> return $ boolParser e
+  , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool")
+  , fieldEnctype = UrlEncoded
+  }
   where
     boolParser [] = Right Nothing
     boolParser (x:_) = case x of
@@ -1061,6 +1061,36 @@ formResultModal res finalDest handler = maybeT_ $ do
         forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
         redirect finalDest
 
+userMatriculationField :: forall m.
+                          ( MonadHandler m
+                          , HandlerSite m ~ UniWorX
+                          )
+                       => Field m [Entity User]
+userMatriculationField = Field{..}
+  where
+    fieldEnctype = UrlEncoded
+    fieldView theId name attrs val isReq = do
+      let val' = val <&> Text.intercalate ", " . mapMaybe (userMatrikelnummer . entityVal)
+      [whamlet|
+        $newline never
+        <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val'}">
+      |]
+    fieldParse (all Text.null -> True) _ = return $ Right Nothing
+    fieldParse ts _ = runExceptT . fmap Just $ do
+      let ts' = concatMap (Text.splitOn ",") ts
+      forM ts' $ \matr -> do
+        dbRes <- liftHandlerT . runDB . E.select . E.from $ \user -> do
+          E.where_ $ E.strip (user E.^. UserMatrikelnummer) `E.ciEq` E.just (E.val $ Text.strip matr)
+          return user
+        case dbRes of
+          [user]
+            -> return user
+          []
+            -> throwE . SomeMessage $ MsgUserMatriculationNotFound matr
+          _other
+            -> throwE . SomeMessage $ MsgUserMatriculationAmbiguous matr
+
+
 multiUserField :: forall m.
                   ( MonadHandler m
                   , HandlerSite m ~ UniWorX

src/Model/Types/Security.hs

@@ -43,6 +43,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthLecturer
   | AuthCorrector
   | AuthTutor
+  | AuthExamOffice
   | AuthAllocationRegistered
   | AuthCourseRegistered
   | AuthTutorialRegistered

src/Utils.hs

@@ -46,6 +46,7 @@ import qualified Data.Conduit.List as C
 
 import Control.Lens
 import Control.Lens as Utils (none)
+import Data.Set.Lens
 
 import Control.Arrow as Utils ((>>>))
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
@@ -425,6 +426,12 @@ invertMap = groupMap . map swap . Map.toList
 countMapElems :: (Ord v) => Map k v -> Map v Int
 countMapElems = Map.fromListWith (+) . map (\(_k,v)->(v,1)) . Map.toList
 
+mapSymmDiff :: (Ord k, Ord v) => Map k v -> Map k v -> Map k (Set v)
+mapSymmDiff a b = Map.fromListWith Set.union . map (over _2 Set.singleton) . Set.toList $ (setSymmDiff `on` assocsSet) a b
+
+assocsSet :: Ord (k, v) => Map k v -> Set (k, v)
+assocsSet = setOf folded . imap (,)
+
 
 
 ---------------

src/Utils/Icon.hs

@@ -75,7 +75,7 @@ iconText = \case
     IconCourse             -> "graduation-cap"
     IconEnrolTrue          -> "user-plus"
     IconEnrolFalse         -> "user-slash"
-    IconExam               -> "file-invoice"
+    IconExam               -> "poll-h"
     IconExamRegisterTrue   -> "calendar-check"
     IconExamRegisterFalse  -> "calendar-times"
     IconCommentTrue        -> "comment-alt"

src/Utils/Lens.hs

@@ -16,6 +16,7 @@ import Control.Lens as Utils.Lens
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens
 import Data.Set.Lens as Utils.Lens
+import Data.Map.Lens as Utils.Lens
 
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
@@ -76,7 +77,16 @@ makeClassyFor_ ''StudyDegree
 makeClassyFor_ ''StudyTerms
 
 
-makeLenses_ ''Entity
+_entityKey :: Getter (Entity record) (Key record)
+-- ^ Not a `Lens'` for safety
+_entityKey = to entityKey
+
+_entityVal :: IndexedLens (Key record) (Entity record) (Entity record) record record
+_entityVal = ilens ((,) <$> entityKey <*> entityVal) (\e v -> e { entityVal = v })
+
+_Entity :: PersistEntity record' => Iso (Entity record) (Entity record') (Key record, record) (Key record', record')
+_Entity = iso ((,) <$> entityKey <*> entityVal) (uncurry Entity)
+  
 
 instance HasStudyFeatures a => HasStudyFeatures (Entity a) where
   hasStudyFeatures = _entityVal . hasStudyFeatures

templates/default-layout.lucius

@@ -174,18 +174,20 @@ h4 {
   > .container {
     margin: 20px 0;
   }
+}
 
+.main__content, .modal__content {
   a {
     text-decoration: underline;
   }
 
-  p {
+  p, form {
     margin: 0.5rem 0;
 
     &:last-child {
       margin: 0.5rem 0 0;
 
-      &:first-of-type {
+      &:first-child {
         margin: 0;
       }
     }

templates/widgets/fields/examOfficeFieldMode.hamlet

@@ -0,0 +1,7 @@
+$newline never
+<div .radio-group>
+  $forall opt <- universeF
+    <div .radio>
+      $with inputId <- mconcat [theId, "-", toPathPiece opt]
+        <input id=#{inputId} *{attrs} type=radio name=#{name} value=#{toPathPiece opt} :isChecked opt val:checked>
+        <label for=#{inputId}>_{opt}

templates/widgets/massinput/examOfficeUsers/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput submitView}

templates/widgets/massinput/examOfficeUsers/cell.hamlet

@@ -0,0 +1,5 @@
+$newline never
+<td>
+  ^{nameWidget userDName userSName}
+  $maybe matrikel <- userMatr
+    \ (#{matrikel})

templates/widgets/massinput/examOfficeUsers/layout.hamlet

@@ -0,0 +1,11 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}