fix(day): fix #2347 by adding repeated examiner check to day consistency check for day exam occurrences

messages/uniworx/categories/courses/exam/exam/de-de-formal.msg

@@ -73,6 +73,7 @@ ExamCorrectorEmail: E-Mail
 ExamCorrectors: Prüfer:innen
 ExamCorrectorsTip: Hier eingetragene Prüfer:innen können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer:innen im System hinterlegen.
 ExamCorrectorAlreadyAdded: Ein Prüfer:innen mit dieser E-Mail ist bereits für diese Prüfung eingetragen
+ExamParticipant: Prüfungsteilnehmer:in
 ExamRoom: Raum
 ExamRoomManual': Keine automatische bzw. selbstständige Zuteilung
 ExamRoomSurname': Nach Nachname
@@ -226,6 +227,8 @@ ExamOccurrencesEdited num@Int del@Int: #{pluralENsN num "Prüfungstermin"} geän
 ExamOccurrenceCopyNoStartDate: Dieser Kurs hat noch keine eigene Termine um Prüfungstermine zeitlich damit zu assoziieren
 ExamOccurrenceCopyFail: Keine passenden Prüfungstermine zum Kopieren gefunden
 ExaminerReocurrence examiner@Text: Mehrfache Prüfung durch #{examiner}!
+ExamProblemReoccurrence: Prüfungen mit wiederholt gleichem Prüfer
+ExamNoProblemReoccurrence: Heute keine Prüfungen mit wiederholtem Prüfer.
 GradingFrom: Ab
 ExamNoShow: Nicht erschienen
 ExamVoided: Entwertet

messages/uniworx/categories/courses/exam/exam/en-eu.msg

@@ -73,6 +73,7 @@ ExamCorrectorEmail: Email
 ExamCorrectors: Examiner
 ExamCorrectorsTip: Examiners configured here may, after the start of the exam and until "Results visible from", enter exam part results for all exam parts and participants.
 ExamCorrectorAlreadyAdded: An examiner with this email address already exists
+ExamParticipant: Examinee
 ExamRoom: Room
 ExamRoomManual': No automatic or autonomous assignment
 ExamRoomSurname': By surname
@@ -226,6 +227,8 @@ ExamOccurrencesEdited num del: #{pluralENsN num "exam occurrence"} edited #{guar
 ExamOccurrenceCopyNoStartDate: This course needs its own occurrence to copy associated exam occurrences.
 ExamOccurrenceCopyFail: No suitable exam occurrences found to copy from.
 ExaminerReocurrence examiner: Multiple examinations by #{examiner}!
+ExamProblemReoccurrence: Exams with reoccurring examiner
+ExamNoProblemReoccurrence: Today there are no exams with a reoccurring examiner.
 GradingFrom: From
 
 #templates widgets/bonus-rule

src/Handler/Course/Users.hs

@@ -10,7 +10,7 @@ module Handler.Course.Users
   , postCUsersR, getCUsersR
   , colUserSex'
   , colUserQualifications, colUserQualificationBlocked
-  , colUserExams, colUserExamOccurrences, colUserExamOccurrencesCheck, colUserExamOccurrencesCheckDB
+  , colUserExams, colUserExamOccurrences, colUserExamOccurrencesCheck
   , _userQualifications
   ) where
 
@@ -24,7 +24,7 @@ import Handler.Utils.Company
 import qualified Database.Esqueleto.Legacy      as E
 import qualified Database.Esqueleto.Utils       as E
 import qualified Database.Esqueleto.PostgreSQL  as E
-import qualified Database.Esqueleto.Experimental as X (from,on,table,innerJoin,leftJoin)
+import qualified Database.Esqueleto.Experimental as X (from,on,table,leftJoin)
 import           Database.Esqueleto.Experimental ((:&)(..))
 
 import Database.Esqueleto.Utils.TH
@@ -190,6 +190,7 @@ colUserExamOccurrencesCheck _tid _ssh _csh = sortable (Just "exam-occurrences")
             in  wgtCell warnExaminer <> examOccurrenceCell exOcc
           )
 
+{-
 colUserExamOccurrencesCheckDB :: (IsDBTable (MForm Handler) c, MonadHandler (DBCell (MForm Handler)), HandlerSite (DBCell (MForm Handler)) ~ UniWorX) -- this type seems to be unusable+
                               => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell (MForm Handler) c)
 colUserExamOccurrencesCheckDB  _tid _ssh _csh = sortable (Just "exam-occurrences") (i18nCell MsgCourseUserExamOccurrences)
@@ -214,6 +215,7 @@ colUserExamOccurrencesCheckDB  _tid _ssh _csh = sortable (Just "exam-occurrences
                                 (Just exname) -> messageTooltip <$> messageI Warning (MsgExaminerReocurrence exname)
               [whamlet|^{warnExaminer}#{examOccurrenceName}:^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}|]
           )
+-}
 
 colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
 colUserSex' = colUserSex $ hasUser . _userSex

src/Handler/Profile.hs

@@ -46,7 +46,17 @@ import           Database.Esqueleto.Utils.TH
 import qualified Data.Text as Text
 import Data.List (inits)
 
-import qualified Data.CaseInsensitive as CI
+import qualified Data.CaseInsensitive as CI-- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget}
+-- a poor man's record subsitute
+
+{-
+type TableHasData = (Bool, Widget)
+tableHasRows :: TableHasData -> Bool
+tableHasRows = fst
+tableWidget :: TableHasData -> Widget
+tableWidget  = snd
+-}
+
 
 import Jobs
 
@@ -601,41 +611,6 @@ getForProfileDataR cID = do
     setTitleI $ MsgHeadingForProfileData $ userDisplayName user
     dataWidget
 
--- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget}
--- a poor man's record subsitute
-
-{-
-type TableHasData = (Bool, Widget)
-tableHasRows :: TableHasData -> Bool
-tableHasRows = fst
-tableWidget :: TableHasData -> Widget
-tableWidget  = snd
--}
-
--- | Given a header message, a bool and widget; display widget and header only if the boolean is true
-maybeTable :: (RenderMessage UniWorX a)
-           => a -> (Bool, Widget) -> Widget
-maybeTable m = maybeTable' m Nothing Nothing
-
-maybeTable' :: (RenderMessage UniWorX a)
-           => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
-maybeTable' _   Nothing       _ (False, _ ) = mempty
-maybeTable' _   (Just nodata) _ (False, _ ) =
-  [whamlet|
-    <div .container>
-      _{nodata}
-  |]
-maybeTable' hdr _ mbRemark      (True ,tbl) =
-  [whamlet|
-    <div .container>
-      <h2> _{hdr}
-      <div .container>
-        ^{tbl}
-        $maybe remark <- mbRemark
-          <em>_{MsgProfileRemark}
-          \ ^{remark}
-  |]
-
 
 makeProfileData :: Entity User -> DB Widget
 makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do

src/Handler/School/DayTasks.hs

@@ -353,7 +353,7 @@ colParkingField = colParkingField' _dailyFormParkingToken
 
 colParkingField' :: ASetter' a Bool -> Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
 colParkingField' l dday = sortable (Just "parking") (i18nCell $ MsgTableUserParkingToken dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell
-  id -- TODO: this should not be id! Refactor to simplify the thrid argument below
+  id -- TODO: this should not be id! Refactor to simplify the third argument below
   (views (resultParticipant . _entityKey) return)
   (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
     over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
@@ -709,7 +709,7 @@ getSchoolDayCheckR ssh nd = do
   let nowaday = utctDay now
   dday <- formatTime SelFormatDate nd
 
-  (tuts, parts_avs) <- runDB $ do
+  (tuts, parts_avs, examProblemsTbl) <- runDB $ do
     tuts <- getDayTutorials ssh (nd,nd)
     parts_avs :: [ParticipantCheckData] <- $(unValueNIs 5 [2..5]) <<$>> E.select (do
         (tpa :& usr :& avs :& cmp) <- E.from $  E.table @TutorialParticipant
@@ -725,7 +725,9 @@ getSchoolDayCheckR ssh nd = do
       )
     -- additionally queue proper AVS synchs for all users, unless there were already done today
     void $ queueAvsUpdateByUID (foldMap (^. _1 . _entityVal . _tutorialParticipantUser . to Set.singleton) parts_avs) (Just nowaday)
-    return (tuts, parts_avs)
+    -- check for double examiners
+    examProblemsTbl <- mkExamProblemsTable ssh nd
+    return (tuts, parts_avs, examProblemsTbl)
   let getApi :: ParticipantCheckData -> Set AvsPersonId
       getApi = foldMap Set.singleton . view _4
   avsStats :: Map AvsPersonId AvsDataPerson <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap getApi parts_avs -- query AVS, but does not affect DB (no update)
@@ -772,16 +774,104 @@ getSchoolDayCheckR ssh nd = do
                     $forall ((_udn,pid),pcd) <- Map.toList badis
                       <li>
                         ^{mkBaddieWgt pid pcd}
-        <p>
+        <section>
-          ^{linkButton mempty (i18n MsgBtnCloseReload) [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))}
+          <p>
+            <h4 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
+              _{MsgPossibleCheckResults}
+            <p>
+              <ul>
+                $forall msg <- dcrMessages
+                  <li>_{msg}
+            <p>
+              _{MsgAvsUpdateDayCheck}
       <section>
-        <p>
+        ^{maybeTable' MsgExamProblemReoccurrence (Just MsgExamNoProblemReoccurrence) Nothing examProblemsTbl}
-          <h4 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
+      <section>
-            _{MsgPossibleCheckResults}
+        ^{linkButton mempty (i18n MsgBtnCloseReload) [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))}
-          <p>
+    |]
-            <ul>
+
-              $forall msg <- dcrMessages
+
-                <li>_{msg}
+type TblExamPrbsExpr = (                E.SqlExpr (Entity Course)
-          <p>
+                      `E.InnerJoin`     E.SqlExpr (Entity Exam)
-            _{MsgAvsUpdateDayCheck}
+                      `E.InnerJoin`     E.SqlExpr (Entity ExamRegistration)
-    |]
+                      `E.InnerJoin`     E.SqlExpr (Entity ExamOccurrence)
+                      `E.InnerJoin`     E.SqlExpr (Entity User)
+                      `E.InnerJoin`     E.SqlExpr (Entity User)
+                    )
+type TblExamPrbsData = DBRow (Entity Course, Entity Exam, Entity ExamRegistration, Entity ExamOccurrence, Entity User, Entity User)
+
+-- | Table listing double examiner problems for a given school and day
+mkExamProblemsTable :: SchoolId -> Day -> DB (Bool, Widget)
+mkExamProblemsTable =
+  let dbtIdent = "exams-user" :: Text
+      dbtStyle = def
+      dbtSQLQuery' exOccs (crs `E.InnerJoin` exm `E.InnerJoin` reg `E.InnerJoin` occ `E.InnerJoin` usr `E.InnerJoin` xmr) = do
+        EL.on $ xmr E.^. UserId                     E.=?. occ E.^. ExamOccurrenceExaminer
+        EL.on $ usr E.^. UserId                     E.==. reg E.^. ExamRegistrationUser
+        EL.on $ occ E.^. ExamOccurrenceId           E.=?. reg E.^. ExamRegistrationOccurrence
+        EL.on $ exm E.^. ExamId                     E.==. reg E.^. ExamRegistrationExam
+        EL.on $ exm E.^. ExamCourse                 E.==. crs E.^. CourseId
+        E.where_ $ occ E.^. ExamOccurrenceId `E.in_` E.vals exOccs
+            E.&&.  E.exists (do
+                altReg :& altOcc <- E.from $ E.table @ExamRegistration `E.innerJoin` E.table @ExamOccurrence
+                                    `E.on` (\(altReg :& altOcc) -> altReg E.^. ExamRegistrationOccurrence E.?=. altOcc E.^. ExamOccurrenceId)
+                E.where_ $ altReg E.^. ExamRegistrationUser   E.==. reg E.^. ExamRegistrationUser
+                    E.&&.  altReg E.^. ExamRegistrationId     E.!=. reg E.^. ExamRegistrationId
+                    E.&&.  altOcc E.^. ExamOccurrenceExaminer E.==. occ E.^. ExamOccurrenceExaminer
+                    E.&&.  altOcc E.^. ExamOccurrenceId       E.!=. occ E.^. ExamOccurrenceId
+              )
+        return (crs,exm,reg,occ,usr,xmr)
+      queryExmCourse    :: TblExamPrbsExpr -> E.SqlExpr (Entity Course)
+      queryExmCourse    = $(sqlIJproj 6 1)
+      queryExam         :: TblExamPrbsExpr -> E.SqlExpr (Entity Exam)
+      queryExam         = $(sqlIJproj 6 2)
+      queryRegistration :: TblExamPrbsExpr -> E.SqlExpr (Entity ExamRegistration)
+      queryRegistration = $(sqlIJproj 6 3)
+      queryOccurrence   :: TblExamPrbsExpr -> E.SqlExpr (Entity ExamOccurrence)
+      queryOccurrence   = $(sqlIJproj 6 4)
+      queryTestee       :: TblExamPrbsExpr -> E.SqlExpr (Entity User)
+      queryTestee       = $(sqlIJproj 6 5)
+      queryExaminer     :: TblExamPrbsExpr -> E.SqlExpr (Entity User)
+      queryExaminer     = $(sqlIJproj 6 6)
+      resultExmCourse     :: Lens' TblExamPrbsData (Entity Course)
+      resultExmCourse     = _dbrOutput . _1
+      resultExam          :: Lens' TblExamPrbsData (Entity Exam)
+      resultExam          = _dbrOutput . _2
+      resultRegistration  :: Lens' TblExamPrbsData (Entity ExamRegistration)
+      resultRegistration  = _dbrOutput . _3
+      resultOccurrence    :: Lens' TblExamPrbsData (Entity ExamOccurrence)
+      resultOccurrence    = _dbrOutput . _4
+      resultTestee        :: Lens' TblExamPrbsData (Entity User)
+      resultTestee        = _dbrOutput . _5
+      resultExaminer      :: Lens' TblExamPrbsData (Entity User)
+      resultExaminer      = _dbrOutput . _6
+      dbtRowKey = queryRegistration >>> (E.^. ExamRegistrationId)
+      dbtProj   = dbtProjId
+      dbtColonnade = mconcat
+          [ sortable (Just "course")      (i18nCell MsgTableCourse)               $ fmap addIndicatorCell courseCell <$> view (resultExmCourse . _entityVal)
+          , sortable (Just "exam")        (i18nCell MsgCourseExam)                $ \row -> examCell (row ^. resultExmCourse . _entityVal) (row ^. resultExam . _entityVal)
+          , sortable (Just "registration")(i18nCell MsgCourseExamRegistrationTime)$ dateCell . view (resultRegistration . _entityVal . _examRegistrationTime)
+          , sortable (Just "occurrence")  (i18nCell MsgTableExamOccurrence)       $ examOccurrenceCell              . view  resultOccurrence
+          , sortable (Just "testee")      (i18nCell MsgExamParticipant)           $ cellHasUserLink ForProfileDataR . view  resultTestee
+          , sortable (Just "examiner")    (i18nCell MsgExamCorrectors)            $ cellHasUser                     . view  resultExaminer
+          ]
+      validator = def & defaultSorting [SortAscBy "course", SortAscBy "exam", SortAscBy "testee"] -- [SortDescBy "registration"]
+      dbtSorting  = Map.fromList
+          [ ( "course"      , SortColumn $ queryExmCourse     >>> (E.^. CourseName))
+          , ( "exam"        , SortColumn $ queryExam          >>> (E.^. ExamName))
+          , ( "registration", SortColumn $ queryRegistration  >>> (E.^. ExamRegistrationTime))
+          , ( "occurrence"  , SortColumn $ queryOccurrence    >>> (E.^. ExamOccurrenceName))
+          , ( "testee"      , SortColumn $ queryTestee        >>> (E.^. UserDisplayName))
+          , ( "examiner"    , SortColumn $ queryExaminer      >>> (E.^. UserDisplayName))
+          ]
+      dbtFilter   = mempty
+      dbtFilterUI = mempty
+      dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
+      dbtExtraReps = []
+  in \ssh nd -> do
+    exOccs <- getDayExamOccurrences False ssh Nothing (nd,nd)
+    let dbtSQLQuery = dbtSQLQuery' $ Map.keys exOccs
+    (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
+

src/Handler/Utils/Table.hs

@@ -6,6 +6,33 @@ module Handler.Utils.Table
   ( module Handler.Utils.Table
   ) where
 
+import Import hiding (link)
+
 import Handler.Utils.Table.Pagination as Handler.Utils.Table
 import Handler.Utils.Table.Columns as Handler.Utils.Table
 import Handler.Utils.Table.Cells as Handler.Utils.Table
+
+
+-- | Given a header message, a bool and widget; display widget and header only if the boolean is true
+maybeTable :: (RenderMessage UniWorX a)
+           => a -> (Bool, Widget) -> Widget
+maybeTable m = maybeTable' m Nothing Nothing
+
+maybeTable' :: (RenderMessage UniWorX a)
+           => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
+maybeTable' _   Nothing       _ (False, _ ) = mempty
+maybeTable' _   (Just nodata) _ (False, _ ) =
+  [whamlet|
+    <div .container>
+      _{nodata}
+  |]
+maybeTable' hdr _ mbRemark      (True ,tbl) =
+  [whamlet|
+    <div .container>
+      <h2> _{hdr}
+      <div .container>
+        ^{tbl}
+        $maybe remark <- mbRemark
+          <em>_{MsgProfileRemark}
+          \ ^{remark}
+  |]