feat(exams): exam staff & additional schools

messages/uniworx/de-de-formal.msg

@@ -1832,6 +1832,11 @@ ExamRoomDescription: Beschreibung
 ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfungstermin/Raum
 ExamRoomAssigned: Zugeteilt
 ExamRoomRegistered: Anmeldung
+ExamStaff: Prüfer/Verantwortliche Hochschullehrer
+ExamStaffTip: Geben Sie bitte in jedem Fall einen Namen an, der den Prüfer/Veranstalter/Verantwortlichen Hochschullehrer eindeutig identifiziert! Sollte der Name des Prüfers allein womöglich nicht eindeutig sein, so geben Sie bitte eindeutig identifizierende Zusatzinfos, wie beispielsweise den Lehrstuhl bzw. die LFE o.Ä., an.
+ExamStaffRequired: „Prüfer/Verantwortilche Hochschullehrer” muss angegeben werden
+ExamExamOfficeSchools: Zusätzliche Institute
+ExamExamOfficeSchoolsTip: Prüfungsbeauftragte von Instituten, die Sie hier angeben, erhalten im System (zusätzlich zum primären Institut des zugehörigen Kurses) volle Einsicht in sämtliche für diese Prüfung hinterlegten Leistungen, unabhängig von den Studiendaten der Teilnehmer.
 
 ExamOccurrenceStart: Prüfungsbeginn
 
@@ -1841,6 +1846,7 @@ ExamFormAutomaticFunctions: Automatische Funktionen
 ExamFormCorrection: Korrektur
 ExamFormParts: Teile
 ExamFormMode: Ausgestaltung der Prüfung
+ExamFormGrades: Prüfungsleistungen
 
 ExamModeFormNone: Keine Angabe
 ExamModeFormCustom: Benutzerdefiniert

messages/uniworx/en-eu.msg

@@ -1831,6 +1831,11 @@ ExamRoomDescription: Description
 ExamTimeTip: Only for informational purposes. The actual times are set for each occurrence/room
 ExamRoomAssigned: Assigned
 ExamRoomRegistered: Registration
+ExamStaff: Examiner/Responsible university teacher
+ExamStaffTip: Please always specify a name that uniquely identifies the examiner/organiser/repsonsible university teacher! If there is a possibility that the name alone is ambiguous please also specify some additional information e.g. the professorial chair or the educational and research unit.
+ExamStaffRequired: “Examiner/Responsible university teacher” must be specified
+ExamExamOfficeSchools: Additional departments
+ExamExamOfficeSchoolsTip: Exam offices of departments you specify here will also have full access to all results for this exam disregarding the individual participants' features of study.
 
 ExamOccurrenceStart: Exam starts
 
@@ -1840,6 +1845,7 @@ ExamFormAutomaticFunctions: Automatic functions
 ExamFormCorrection: Correction
 ExamFormParts: Exam parts
 ExamFormMode: Exam design
+ExamFormGrades: Exam achievements
 
 ExamModeFormNone: Not specified
 ExamModeFormCustom: Custom
@@ -2838,4 +2844,4 @@ SystemExamOffice: Exam office
 SystemFaculty: Faculty member
 
 ChangelogItemFeature: Feature
-ChangelogItemBugfix: Bugfix
+ChangelogItemBugfix: Bugfix

models/exams.model

@@ -18,6 +18,7 @@ Exam
   gradingMode ExamGradingMode
   description Html Maybe
   examMode ExamMode
+  staff Text Maybe
   UniqueExam course name
 ExamPart
   exam ExamId
@@ -67,4 +68,8 @@ ExamCorrector
 ExamPartCorrector
   part ExamPartId
   corrector ExamCorrectorId
-  UniqueExamPartCorrector part corrector
+  UniqueExamPartCorrector part corrector
+ExamOfficeSchool
+  school SchoolId
+  exam ExamId
+  UniqueExamOfficeSchool exam school

src/Handler/Exam/Edit.hs

@@ -49,6 +49,7 @@ postEEditR tid ssh csh examn = do
         , examGradingMode      = efGradingMode
         , examDescription      = efDescription
         , examExamMode         = efExamMode
+        , examStaff            = efStaff
         }
 
       when (is _Nothing insertRes) $ do
@@ -80,7 +81,6 @@ postEEditR tid ssh csh examn = do
               , examOccurrenceDescription = eofDescription
               }
 
-
         pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
         deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
         forM_ (Set.toList efExamParts) $ \case
@@ -105,6 +105,8 @@ postEEditR tid ssh csh examn = do
               , examPartWeight = epfWeight
               }
 
+        deleteWhere [ ExamOfficeSchoolExam ==. eId ]
+        insertMany_ . map (flip ExamOfficeSchool eId) $ Set.toList efOfficeSchools
 
         let (invites, adds) = partitionEithers $ Set.toList efCorrectors
 

src/Handler/Exam/Form.hs

@@ -28,7 +28,6 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
 data ExamForm = ExamForm
   { efName :: ExamName
   , efDescription :: Maybe Html
-  , efGradingMode :: ExamGradingMode
   , efStart :: Maybe UTCTime
   , efEnd :: Maybe UTCTime
   , efVisibleFrom :: Maybe UTCTime
@@ -43,6 +42,9 @@ data ExamForm = ExamForm
   , efBonusRule :: Maybe ExamBonusRule
   , efOccurrenceRule :: ExamOccurrenceRule
   , efExamMode :: ExamMode
+  , efGradingMode :: ExamGradingMode
+  , efOfficeSchools :: Set SchoolId
+  , efStaff :: Maybe Text
   , efCorrectors :: Set (Either UserEmail UserId)
   , efExamParts :: Set ExamPartForm
   }
@@ -103,7 +105,6 @@ examForm template html = do
   flip (renderAForm FormStandard) html $ ExamForm
     <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
     <*> aopt htmlField (fslI MsgExamDescription) (efDescription <$> template)
-    <*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed)
     <*  aformSection MsgExamFormTimes
     <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
     <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
@@ -122,11 +123,39 @@ examForm template html = do
     <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
     <*  aformSection MsgExamFormMode
     <*> examModeForm (efExamMode <$> template)
+    <*  aformSection MsgExamFormGrades
+    <*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed)
+    <*> officeSchoolsForm (efOfficeSchools <$> template)
+    <*> apreq' (textField & cfStrip) (fslpI MsgExamStaff (mr MsgExamStaff) & setTooltip MsgExamStaffTip) (efStaff <$> template)
     <*  aformSection MsgExamFormCorrection
     <*> examCorrectorsForm (efCorrectors <$> template)
     <*  aformSection MsgExamFormParts
     <*> examPartsForm (efExamParts <$> template)
 
+officeSchoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
+officeSchoolsForm mPrev = wFormToAForm $ do
+  currentRoute <- fromMaybe (error "officeSchoolsForm called from 404-handler") <$> getCurrentRoute
+
+  let
+    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
+
+    miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([SchoolId] -> FormResult [SchoolId])
+    miAdd' nudge submitView csrf = do
+      (schoolRes, addView) <- mpopt schoolField ("" & addName (nudge "school")) Nothing
+      let schoolRes' = schoolRes <&> \newDat oldDat -> FormSuccess (guardOn (newDat `notElem` oldDat) newDat)
+      return (schoolRes', $(widgetFile "exam/schoolMassInput/add"))
+
+    miCell' :: SchoolId -> Widget
+    miCell' ssh = do
+      School{..} <- liftHandler . runDB $ getJust ssh
+      $(widgetFile "exam/schoolMassInput/cell")
+
+    miLayout' :: MassInputLayout ListLength SchoolId ()
+    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "exam/schoolMassInput/layout")
+
+  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("exam-schools" :: Text) (fslI MsgExamExamOfficeSchools & setTooltip MsgExamExamOfficeSchoolsTip) False (Set.toList <$> mPrev)
+
 examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
 examCorrectorsForm mPrev = wFormToAForm $ do
   MsgRenderer mr <- getMsgRenderer
@@ -261,6 +290,7 @@ examFormTemplate (Entity eId Exam{..}) = do
   occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
   correctors <- selectList [ ExamCorrectorExam ==. eId ] []
   invitations <- Map.keysSet <$> sourceInvitationsF @ExamCorrector eId
+  extraSchools <- selectList [ ExamOfficeSchoolExam ==. eId ] []
 
   examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
   occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
@@ -308,13 +338,15 @@ examFormTemplate (Entity eId Exam{..}) = do
           return examCorrectorUser
       ]
     , efExamMode         = examExamMode
+    , efOfficeSchools    = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools
+    , efStaff            = examStaff
     }
 
 examTemplate :: CourseId -> DB (Maybe ExamForm)
 examTemplate cid = runMaybeT $ do
   newCourse <- MaybeT $ get cid
 
-  [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
+  [(Entity _ oldCourse, Entity oldExamId oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
     E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
     E.where_ $ (       course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse)
                  E.||. course E.^. CourseName E.==. E.val (courseName newCourse)
@@ -327,6 +359,8 @@ examTemplate cid = runMaybeT $ do
     E.limit 1
     E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
     return (course, exam)
+  
+  extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] []
 
   oldTerm <- MaybeT . get $ courseTerm oldCourse
   newTerm <- MaybeT . get $ courseTerm newCourse
@@ -354,6 +388,8 @@ examTemplate cid = runMaybeT $ do
     , efExamParts        = Set.empty
     , efCorrectors       = Set.empty
     , efExamMode         = examExamMode oldExam
+    , efStaff            = examStaff oldExam
+    , efOfficeSchools    = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools
     }
 
 
@@ -431,3 +467,6 @@ validateExam cId oldExam = do
               ]
 
     warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode
+
+  unless (has (_Just . _examStaff . _Nothing) oldExam) $
+    guardValidation MsgExamStaffRequired $ isn't _Nothing efStaff

src/Handler/Exam/New.hs

@@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do
         , examPublicStatistics             = efPublicStatistics
         , examDescription                  = efDescription
         , examExamMode                     = efExamMode
+        , examStaff                        = efStaff
         }
       whenIsJust insertRes $ \examid -> do
         insertMany_
@@ -74,6 +75,8 @@ postCExamNewR tid ssh csh = do
                 examOccurrenceDescription = eofDescription
           ]
 
+        insertMany_ . map (flip ExamOfficeSchool examid) $ Set.toList efOfficeSchools
+
         let (invites, adds) = partitionEithers $ Set.toList efCorrectors
         insertMany_ [ ExamCorrector{..}
                     | let examCorrectorExam = examid

src/Handler/Exam/Show.hs

@@ -26,7 +26,7 @@ getEShowR tid ssh csh examn = do
   cTime <- liftIO getCurrentTime
   mUid <- maybeAuthId
 
-  (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do
+  (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools) <- runDB $ do
     exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
     school <- getJust examCourse >>= belongsToJust courseSchool
 
@@ -83,7 +83,14 @@ getEShowR tid ssh csh examn = do
 
     lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
 
-    return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown)
+    staffInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EGradesR
+
+    extraSchools <- E.select . E.from $ \(school' `E.InnerJoin` examOfficeSchool) -> do
+      E.on $ school' E.^. SchoolId E.==. examOfficeSchool E.^. ExamOfficeSchoolSchool
+      E.where_ $ examOfficeSchool E.^. ExamOfficeSchoolExam E.==. E.val eId
+      return school'
+
+    return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools)
 
   let occurrenceNamesShown = lecturerInfoShown
       partNumbersShown = lecturerInfoShown

src/Utils/Form.hs

@@ -1261,8 +1261,7 @@ mpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHa
 -- Otherwise acts exactly like `mopt`.
 mpreq f fs@FieldSettings{..} mx = do
   mr <- getMessageRender
-  (res, fv) <- mopt f fs (Just <$> mx)
-  let fv' = fv { fvRequired = True }
+  (res, fv') <- mpreq' f fs $ Just <$> mx
   return $ case res of
     FormSuccess (Just res')
       -> (FormSuccess res', fv')
@@ -1293,6 +1292,25 @@ wpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHa
 wpreq f fs mx = mFormToWForm $ mpreq f fs mx
 
 
+mpreq' :: (HandlerSite m ~ site, MonadHandler m)
+       => Field m a -> FieldSettings site -> Maybe (Maybe a) -> MForm m (FormResult (Maybe a), FieldView site)
+-- ^ Pseudo required
+--
+-- `FieldView` has `fvRequired` set to `True`.
+-- Otherwise acts exactly like `mopt`.
+mpreq' f fs mx = do
+  (res, fv) <- mopt f fs mx
+  return (res, fv { fvRequired = True })
+
+apreq' :: (HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe (Maybe a) -> AForm m (Maybe a)
+apreq' f fs mx = formToAForm $ over _2 pure <$> mpreq' f fs mx
+
+wpreq' :: (HandlerSite m ~ site, MonadHandler m)
+       => Field m a -> FieldSettings site -> Maybe (Maybe a) -> WForm m (FormResult (Maybe a))
+wpreq' f fs mx = mFormToWForm $ mpreq' f fs mx
+
+
 mpopt :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
 -- ^ Pseudo optional

templates/exam-show.hamlet

@@ -94,6 +94,16 @@ $maybe desc <- examDescription
       $maybe closed <- examClosed
         <dt .deflist__dt>_{MsgExamClosed} ^{isVisible False}
         <dd .deflist__dd>^{formatTimeW SelFormatDateTime closed}
+    $maybe staff <- examStaff
+      $if staffInfoShown
+        <dd .deflist__dt>_{MsgExamStaff} ^{isVisible False}
+        <dt .deflist__dd>#{staff}
+    $if staffInfoShown && not (onull extraSchools)
+      <dd .deflist__dt>_{MsgExamExamOfficeSchools} ^{isVisible False}
+      <dt .deflist__dd>
+        <ul>
+          $forall Entity _ School{schoolName} <- extraSchools
+            <li>#{schoolName}
     $if gradingShown
       $maybe gradingRule <- examGradingRule
         <dt .deflist__dt>

templates/exam/schoolMassInput/add.hamlet

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

templates/exam/schoolMassInput/cell.hamlet

@@ -0,0 +1,3 @@
+$newline never
+<td>
+  #{schoolName}

templates/exam/schoolMassInput/layout.hamlet

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

test/Database/Fill.hs

@@ -677,6 +677,7 @@ fillDb = do
       , examSynchronicity = Just $ ExamSynchronicityPreset ExamSynchronous
       , examRequiredEquipment = Just $ ExamRequiredEquipmentPreset ExamRequiredEquipmentNone
       }
+    , examStaff = Just "Hofmann"
     }
   void . insertMany $ map (\u -> ExamRegistration examFFP u Nothing now)
     [ fhamann