From df66c9b58dd1ea6119d428470d2d089edd70e2d0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 10 Oct 2019 10:34:16 +0200 Subject: [PATCH] feat(correction-interface): wire up ECorrectR --- messages/uniworx/de.msg | 1 + routes | 1 + src/Foundation.hs | 23 +++++++++++++++++++++ src/Handler/Exam.hs | 1 + src/Handler/Exam/Correct.hs | 40 +++++++++++++++++++++++++++++++++++++ src/Handler/Exam/Form.hs | 2 +- 6 files changed, 67 insertions(+), 1 deletion(-) create mode 100644 src/Handler/Exam/Correct.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 514420c38..3802a2b29 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/routes b/routes index 00a90b6e8..1a23f7cf3 100644 --- a/routes +++ b/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: diff --git a/src/Foundation.hs b/src/Foundation.hs index 3cf3ae881..38daf44af 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 6580c90f4..c48854461 100644 --- a/src/Handler/Exam.hs +++ b/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 diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs new file mode 100644 index 000000000..e9a7bd692 --- /dev/null +++ b/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 diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 1604a4207..24c8000a2 100644 --- a/src/Handler/Exam/Form.hs +++ b/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