feat(exam-correct): single runDB in POST handler; more response handling

frontend/src/utils/exam-correct/exam-correct.js

@@ -99,8 +99,6 @@ export class ExamCorrect {
     // abort send if there are no results (after validation)
     if (Object.keys(results).length <= 0) return;
 
-    console.log('input validated, proceeding', participant, results);
-
     // TODO create and use template for this
     const correctionRow = document.createElement('TR');
     correctionRow.classList.add('table__row');
@@ -145,8 +143,6 @@ export class ExamCorrect {
       op: true,
     };
 
-    console.log('body', body);
-
     this._app.httpClient.post({
       url: url,
       headers: headers,
@@ -170,19 +166,35 @@ export class ExamCorrect {
         if (participantIdent === participant) {
           let faIcon, ecClass;
           switch (response.status) {
+            // TODO fetch update time from response and replace
             case 'success':
-              // TODO replace loading spinner class with fontawesome tick mark icon
-              // TODO replace participant identifier with participant from response
               faIcon = 'fa-check';
               ecClass = 'exam-correct--success';
+              if (response.user) {
+                participantElem.setAttribute(EXAM_CORRECT_PARTICIPANT_ATTR, response.user.id);
+                participantElem.innerHTML = '';
+                formatUser(participantElem, response.user);
+              }
+              // TODO replace results with results from response
+              // TODO set edit button visibility
               break;
-            case 'error':
+            case 'ambiguous':
-              // TODO replace loading spinner class with fontawesome error icon
+              // TODO show tooltip with error message
-              // TODO show tooltip with error message?
+              // TODO set edit button visibility
+              faIcon = 'fa-times';
+              ecClass = 'exam-correct--error';
+              // TODO show users
+              if (response.users) {
+                showUsers(participantElem, response.users);
+              }
+              break;
+            case 'failure':
               faIcon = 'fa-times';
               ecClass = 'exam-correct--error';
               break;
             default:
+              // TODO show tooltip with 'invalid response'
+              // TODO set edit button visibility
               console.error('Invalid response');
               faIcon = 'fa-times';
               ecClass = 'exam-correct--error';
@@ -212,3 +224,24 @@ export class ExamCorrect {
 function clearInput(inputElement) {
   inputElement.value = null;
 }
+
+function formatUser(elem, user) {
+  if (user && user['display-name'] && user['surname']) {
+    elem.innerHTML += user['display-name'].replace(new RegExp(user['surname']), `<strong>${user['surname']}</strong>`) + (user['mat-nr'] ? ` (${user['mat-nr']})` : '');
+  } else {
+    console.error('Unable to format invalid user response');
+  }
+}
+
+// TODO better name
+function showUsers(elem, users) {
+  elem.innerHTML = '';
+  if (users) {
+    for (const user of users) {
+      formatUser(elem, user);
+      elem.innerHTML += '<br/>';
+    }
+  } else {
+    console.error('Unable to show users from invalid response');
+  }
+}

src/Handler/Exam/Correct.hs

@@ -29,6 +29,7 @@ data CorrectInterfaceResponse
   = CorrectInterfaceResponseSuccess
     { cirsUser       :: CorrectInterfaceUser
     , cirsResults    :: Map ExamPartNumber (Maybe Points)
+    , cirsTime       :: UTCTime
     }
   | CorrectInterfaceResponseAmbiguous
     { ciraUsers      :: Set CorrectInterfaceUser
@@ -85,77 +86,98 @@ getECorrectR tid ssh csh examn = do
     $(widgetFile "exam-correct")
 
 
-postECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Value
+postECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Void
 postECorrectR tid ssh csh examn = do
   MsgRenderer mr <- getMsgRenderer
 
   CorrectInterfaceRequest{ciqName,ciqResults,ciqOp} <- requireCheckJsonBody
 
-  participantMatches <- runDB $ do
+  response <- runDB $ do
     Entity eId _ <- fetchExam tid ssh csh examn
-    E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do
+
+    participantMatches <- E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do
       E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
       E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
-        E.&&. ( user E.^. UserMatrikelnummer E.==. E.val (Just ciqName)
+      E.where_ $ user E.^. UserMatrikelnummer E.==. E.val (Just ciqName)
-          E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val (Just ciqName)
+           E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val (Just ciqName)
-          E.||. user E.^. UserSurname E.==. E.val ciqName
+           E.||. user E.^. UserSurname E.==. E.val ciqName
-          E.||. user E.^. UserSurname `E.hasInfix` E.val ciqName
+           E.||. user E.^. UserSurname `E.hasInfix` E.val ciqName
-          E.||. user E.^. UserFirstName E.==. E.val ciqName
+           E.||. user E.^. UserFirstName E.==. E.val ciqName
-          E.||. user E.^. UserFirstName `E.hasInfix` E.val ciqName
+           E.||. user E.^. UserFirstName `E.hasInfix` E.val ciqName
-          E.||. user E.^. UserDisplayName E.==. E.val ciqName
+           E.||. user E.^. UserDisplayName E.==. E.val ciqName
-          E.||. user E.^. UserDisplayName `E.hasInfix` E.val ciqName )
+           E.||. user E.^. UserDisplayName `E.hasInfix` E.val ciqName
       return user
 
+    let
+      userToResponse (Entity uid User{..}) = do
+        uuid <- encrypt uid
+        return CorrectInterfaceUser
+          { ciuSurname     = userSurname
+          , ciuDisplayName = userDisplayName
+          , ciuMatNr       = userMatrikelnummer
+          , ciuId          = uuid
+          }
+
+    if
+      -- on no-op request, answer with 200 and a set of all participant matches
+      | not ciqOp -> 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 -> do
+        now <- liftIO getCurrentTime
+        newExamPartResults <- iforM ciqResults $ \partNumber mPartResult -> do
+            examPartId <- getKeyBy404 $ UniqueExamPartNumber eId partNumber
+            mOldResult <- getBy $ UniqueExamPartResult examPartId uid
+            if
+              | Just (Entity oldId _) <- mOldResult, is _Nothing mPartResult -> do
+                delete oldId
+                audit $ TransactionExamPartResultDeleted examPartId uid
+                return Nothing
+              | Just partResult <- mPartResult
+              , fmap (examPartResultResult . entityVal) mOldResult /= fmap ExamAttended mPartResult -> do
+                newExamPartResult <- upsert ExamPartResult
+                  { examPartResultExamPart    = examPartId
+                  , examPartResultUser        = uid
+                  , examPartResultResult      = ExamAttended partResult
+                  , examPartResultLastChanged = now
+                  }
+                  [ ExamPartResultResult      =. ExamAttended partResult
+                  , ExamPartResultLastChanged =. now
+                  ]
+                audit $ TransactionExamPartResultEdit examPartId uid
+                return $ newExamPartResult ^? _entityVal . _examPartResultResult . _ExamAttended
+              | otherwise -> return Nothing
+        user <- userToResponse match
+        return CorrectInterfaceResponseSuccess
+          { cirsUser    = user
+          , cirsResults = newExamPartResults
+          , cirsTime    = now
+          }
+
+      -- on match with no exam participant, answer with 400
+      | [] <- participantMatches -> return CorrectInterfaceResponseFailure
+        { cirfMessage   = mr MsgExamCorrectErrorNoMatchingParticipants
+        }
+
+      -- on match with multiple exam participants, answer with 400 and a set of all matches
+      | otherwise -> do
+        users <- traverse userToResponse participantMatches
+        return CorrectInterfaceResponseAmbiguous
+          { ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants
+          , ciraUsers   = Set.fromList users
+          }
+  
   let
-    userToResponse (Entity uid User{..}) = do
+    responseStatus = case response of
-      uuid <- encrypt uid
+      CorrectInterfaceResponseSuccess{} -> ok200
-      return CorrectInterfaceUser
+      CorrectInterfaceResponseNoOp{}    -> ok200
-        { ciuSurname     = userSurname
+      _                                 -> badRequest400
-        , ciuDisplayName = userDisplayName
-        , ciuMatNr       = userMatrikelnummer
-        , ciuId          = uuid
-        }
 
-  if
+  whenM acceptsJson $
-    | not ciqOp -> do
+    sendResponseStatus responseStatus $ toJSON response
-      users <- traverse userToResponse participantMatches
+  
-      returnJson $ CorrectInterfaceResponseNoOp
+  redirect $ CExamR tid ssh csh examn EShowR
-        { cirnUsers     = Set.fromList users
-        }
-    | [match@(Entity uid _)] <- participantMatches -> do
-      runDB $ do
-        Entity eId _ <- fetchExam tid ssh csh examn
-        iforM_ ciqResults $ \partNumber mPartResult -> do
-          examPartId <- getKeyBy404 $ UniqueExamPartNumber eId partNumber
-          mOldResult <- getBy $ UniqueExamPartResult examPartId uid
-          unless (fmap (examPartResultResult . entityVal) mOldResult /= mPartResult) $ do
-            let partResult = maybe 0.00 (\p -> ExamPartResultResult p) mPartResult
-            now <- liftIO getCurrentTime
-            upsert ExamPartResult
-              { examPartResultExamPart    = examPartId
-              , examPartResultUser        = uid
-              , examPartResultResult      = partResult
-              , examPartResultLastChanged = now
-              }
-              [ ExamPartResultResult =. partResult
-              ]
-            audit $ TransactionExamPartResultEdit examPartId uid
-      user <- userToResponse match
-      returnJson $ CorrectInterfaceResponseSuccess
-        { cirsUser      = user
-        , cirsResults   = ciqResults
-        }
-    | [] <- participantMatches -> returnJson $ CorrectInterfaceResponseFailure
-      { cirfMessage     = mr MsgExamCorrectErrorNoMatchingParticipants
-      }
-    | otherwise -> do
-      users <- traverse userToResponse participantMatches
-      returnJson $ CorrectInterfaceResponseAmbiguous
-        { ciraMessage     = mr MsgExamCorrectErrorMultipleMatchingParticipants
-        , ciraUsers       = Set.fromList users
-        }
-
-    -- TODO if the request is a noop, respond with a 200
-    -- TODO if there is exactly one match, respond with a 200
-    -- TODO if there are multiple matches, respond with a 400
-    -- TODO if there are no matches, respond with a 400