feat(correction-interface): wire up ECorrectR

messages/uniworx/de.msg

@@ -1428,6 +1428,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

@@ -175,6 +175,7 @@
     /users/invite               EInviteR       GET POST
     /register                   ERegisterR         POST        !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
     /grades                     EGradesR       GET POST        !exam-office
+    /correct                    ECorrectR      GET POST        !exam-correctorANDtime
   /apps                         CApplicationsR GET POST
   !/apps/files                  CAppsFilesR    GET
   /apps/#CryptoFileNameCourseApplication CourseApplicationR:

src/Foundation.hs

@@ -776,6 +776,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
@@ -834,6 +846,8 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
                                  && NTop (Just cTime) <= NTop examRegisterTo
         | otherwise      -> guard $ visible
                                  && NTop (Just cTime) <= NTop examDeregisterUntil
+      ECorrectR -> guard $ NTop (Just cTime) >= NTop examStart
+                        && NTop (Just cTime) <= NTop examFinished
       _          -> return ()
 
     return Authorized
@@ -1946,6 +1960,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
   breadcrumb (CExamR tid ssh csh examn EAddUserR) = return ("Prüfungsteilnehmer hinzufügen", Just $ CExamR tid ssh csh examn EUsersR)
   breadcrumb (CExamR tid ssh csh examn EGradesR) = return ("Prüfungsleistungen", Just $ CExamR tid ssh csh examn EShowR)
+  breadcrumb (CExamR tid ssh csh examn ECorrectR) = return ("Korrekturen eintragen", Just $ CExamR tid ssh csh examn EShowR)
 
   breadcrumb (CTutorialR tid ssh csh tutn TUsersR)   = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR)
   breadcrumb (CTutorialR tid ssh csh tutn TEditR)    = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
@@ -2793,6 +2808,14 @@ pageActions (CExamR tid ssh csh examn EShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamCorrect
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn ECorrectR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CExamR tid ssh csh examn EUsersR) =
   [ MenuItem

src/Handler/Exam.hs

@@ -11,3 +11,4 @@ import Handler.Exam.Edit               as Handler.Exam
 import Handler.Exam.Show               as Handler.Exam
 import Handler.Exam.Users              as Handler.Exam
 import Handler.Exam.AddUser            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