feat(exam-correct): accept grades besides exam part results

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
+      -- on match with exactly one exam participant, insert results and/or grade and answer with 200
-      | [match@(Entity uid _)] <- participantMatches, Just results <- ciqResults -> do
+      | [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
           }