feat(correction-interface): wire up ECorrectR

messages/uniworx/de-de-formal.msg

@@ -1613,6 +1613,7 @@ ExamFormCorrection: Korrektur
 ExamFormParts: Teile
 
 ExamCorrectors: Korrektoren
+ExamCorrectorsTip: Hier eingetragene Korrektoren können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer im System hinterlegen.
 ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen
 
 ExamParts: Teilprüfungen/Aufgaben

routes

@@ -189,6 +189,7 @@
     /register/#ExamOccurrenceName ERegisterOccR    POST        !exam-occurrence-registrationANDtimeANDcapacityANDcourse-registeredAND¬exam-occurrence-registered !exam-occurrence-registrationANDtimeANDexam-occurrence-registeredAND¬exam-result
     /grades                     EGradesR       GET POST        !exam-office
     /assign-occurrences         EAutoOccurrenceR   POST
+    /correct                    ECorrectR      GET POST        !exam-correctorANDtime
   /apps                         CApplicationsR GET POST
   !/apps/files                  CAppsFilesR    GET
   /apps/#CryptoFileNameCourseApplication CourseApplicationR:

src/Foundation.hs

@@ -531,6 +531,18 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
     _ -> do
       guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
       return Authorized
+tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of
+  CExamR tid ssh csh examn _ -> exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isCorrector <- $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
+      E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
+       E.&&. examCorrector E.^. ExamCorrectorUser E.==. E.val authId
+      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
+      E.where_ $ course E.^. CourseTerm E.==. E.val tid
+           E.&&. course E.^. CourseSchool E.==. E.val ssh
+           E.&&. course E.^. CourseShorthand E.==. E.val csh
+           E.&&. exam E.^. ExamName E.==. E.val examn
+  r -> $unsupportedAuthPredicate AuthExamCorrector r
 tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do
   authId <- maybeExceptT AuthenticationRequired $ return mAuthId
   resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
@@ -608,6 +620,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
             -> guard $ visible
                     && NTop examRegisterFrom <= NTop (Just cTime)
                     && NTop (Just cTime) <= NTop examRegisterTo
+      ECorrectR -> guard $ NTop (Just cTime) >= NTop examStart
+                        && NTop (Just cTime) <= NTop examFinished
       _          -> return ()
 
     return Authorized
@@ -2072,6 +2086,7 @@ instance YesodBreadcrumbs UniWorX where
     ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
     ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR
     EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR
+    ECorrectR  -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR
 
   breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
     TUsersR  -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
@@ -3290,6 +3305,17 @@ pageActions (CExamR tid ssh csh examn EShowR) = do
         }
       , navChildren = []
       }
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuExamCorrect
+        , navRoute       = CExamR tid ssh csh examn ECorrectR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
+      }
     ]
 pageActions (CExamR tid ssh csh examn EUsersR) = return
   [ NavPageActionPrimary

src/Handler/Exam.hs

@@ -12,3 +12,4 @@ import Handler.Exam.Show               as Handler.Exam
 import Handler.Exam.Users              as Handler.Exam
 import Handler.Exam.AddUser            as Handler.Exam
 import Handler.Exam.AutoOccurrence     as Handler.Exam
+import Handler.Exam.Correct            as Handler.Exam

src/Handler/Exam/Correct.hs

@@ -0,0 +1,40 @@
+module Handler.Exam.Correct
+  ( getECorrectR, postECorrectR
+  ) where
+
+import Import
+
+data CorrectInterfaceResponse
+  = CorrectInterfaceSuccess
+    { ciUserIdent :: CryptoUUIDUser
+    , ciUserDisplayName :: Text
+    , ciUserMatrikelnummer :: Maybe Text
+    , ciResults :: Map ExamPartNumber (Maybe Points)
+    }
+  | CorrectInterfaceFailure
+    { ciIcon :: Icon
+    , ciMessage :: Text
+    }
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 1
+  , sumEncoding = TaggedObject "status" "result"
+  } ''CorrectorInterfaceResponse
+-- E.g.: { "status": "success", "user-ident": "Max Musterstudent", "user-matrikelnummer": "123", "results": { "1a": null, "2a": 7, "2c3.5": 12 } }
+
+data CorrectInterfaceRequest
+  = CorrectInterfaceRequest
+    { cirName :: Text
+    , cirResults :: Map ExamPartNumber (Maybe Points)
+    }
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''CorrectorInterfaceRequest
+-- E.g.: { "name": "max", "results": { "1a": null, "2c3.5": 9001.2 }}
+ 
+
+getECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getECorrectR = error "ECorrectR not implemented"
+  
+postECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Value
+postECorrectR = error "ECorrectR not implemented" -- use returnJson & requireCheckJsonBody

src/Handler/Exam/Form.hs

@@ -147,7 +147,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
     miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
     miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")
 
-  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev)
+  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip (UniWorXMessages [MsgExamCorrectorsTip, MsgMassInputTip]) False (Set.toList <$> mPrev)
 
 examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
 examOccurrenceForm prev = wFormToAForm $ do