diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs index d730ef647..21cd87457 100644 --- a/src/Handler/Exam/Correct.hs +++ b/src/Handler/Exam/Correct.hs @@ -29,7 +29,8 @@ deriveJSON defaultOptions data CorrectInterfaceResponse = CorrectInterfaceResponseSuccess { cirsUser :: CorrectInterfaceUser - , cirsResults :: Map ExamPartNumber (Maybe Points) + , cirsResults :: Map ExamPartNumber (Maybe ExamResultPoints) + , cirsGrade :: Maybe ExamResultPassedGrade , cirsTime :: UTCTime } | CorrectInterfaceResponseAmbiguous @@ -52,6 +53,7 @@ data CorrectInterfaceRequest = CorrectInterfaceRequest { ciqUser :: Either Text (CryptoID UUID (Key User)) , ciqResults :: Maybe (NonNull (Map ExamPartNumber (Maybe Points))) + , ciqGrade :: Maybe ExamResultPassedGrade } instance FromJSON CorrectInterfaceRequest where @@ -59,6 +61,7 @@ instance FromJSON CorrectInterfaceRequest where ciqUser <- Right <$> o JSON..: "user" <|> Left <$> o JSON..: "user" results <- o JSON..:? "results" ciqResults <- for results $ maybe (fail "Results may not be nullable") return . fromNullable + ciqGrade <- o JSON..:? "grade" return CorrectInterfaceRequest{..} @@ -92,10 +95,10 @@ postECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Vo postECorrectR tid ssh csh examn = do MsgRenderer mr <- getMsgRenderer - CorrectInterfaceRequest{ciqUser,ciqResults} <- requireCheckJsonBody + CorrectInterfaceRequest{..} <- requireCheckJsonBody response <- runDB $ do - Entity eId _ <- fetchExam tid ssh csh examn + Entity eId Exam{..} <- fetchExam tid ssh csh examn euid <- traverse decrypt ciqUser participantMatches <- E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do @@ -130,16 +133,17 @@ postECorrectR tid ssh csh examn = do if -- on no-op request, answer with 200 and a set of all participant matches - | is _Nothing ciqResults -> do + | is _Nothing ciqResults, is _Nothing ciqGrade -> do users <- traverse userToResponse participantMatches return CorrectInterfaceResponseNoOp { cirnUsers = Set.fromList users } - -- on match with exactly one exam participant, insert results and answer with 200 - | [match@(Entity uid _)] <- participantMatches, Just results <- ciqResults -> do + -- on match with exactly one exam participant, insert results and/or grade and answer with 200 + | [match@(Entity uid _)] <- participantMatches -> do now <- liftIO getCurrentTime - newExamPartResults <- iforM (toNullable results) $ \partNumber mPartResult -> do + newExamPartResults <- if + | Just results <- ciqResults -> iforM (toNullable results) $ \partNumber mPartResult -> do examPartId <- getKeyBy404 $ UniqueExamPartNumber eId partNumber mOldResult <- getBy $ UniqueExamPartResult examPartId uid if @@ -150,7 +154,7 @@ postECorrectR tid ssh csh examn = do | Just partResult <- mPartResult -> let mOld = (examPartResultResult . entityVal) <$> mOldResult mNew = ExamAttended <$> mPartResult - resultVal = _entityVal . _examPartResultResult . _ExamAttended + resultVal = _entityVal . _examPartResultResult in if | mOld /= mNew -> do newExamPartResult <- upsert ExamPartResult @@ -165,11 +169,42 @@ postECorrectR tid ssh csh examn = do audit $ TransactionExamPartResultEdit examPartId uid return $ newExamPartResult ^? resultVal | otherwise -> return $ mOldResult ^? _Just . resultVal - | otherwise -> return Nothing + | otherwise -> return Nothing + | otherwise -> return mempty + + newExamResult <- do + mOldResult <- getBy $ UniqueExamResult eId uid + if + | Just (Entity oldId _) <- mOldResult, is _Nothing ciqGrade -> do + delete oldId + audit $ TransactionExamResultDeleted eId uid + return Nothing + | Just result <- ciqGrade -> let + mOld = view passedGrade . examResultResult . entityVal <$> mOldResult + resultGrade = review passedGrade result + passedGrade :: Iso' ExamResultGrade ExamResultPassedGrade + passedGrade = iso (fmap $ bool (Left . view passingGrade) Right examShowGrades) (fmap $ either (review passingGrade) id) + in if + | ciqGrade /= mOld -> do + newResult <- upsert ExamResult + { examResultExam = eId + , examResultUser = uid + , examResultResult = resultGrade + , examResultLastChanged = now + } + [ ExamResultResult =. resultGrade + , ExamResultLastChanged =. now + ] + audit $ TransactionExamResultEdit eId uid + return $ newResult ^? _entityVal . _examResultResult . passedGrade + | otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult . passedGrade + | otherwise -> return Nothing + user <- userToResponse match return CorrectInterfaceResponseSuccess { cirsUser = user , cirsResults = newExamPartResults + , cirsGrade = newExamResult , cirsTime = now }