feat(exam-correct): postECorrectR stub

messages/uniworx/de-de-formal.msg

@@ -1404,6 +1404,9 @@ ExamCorrectHeadStatus: Status
 
 ExamCorrectButtonSend: Senden
 
+ExamCorrectErrorMultipleMatchingParticipants: Dem Identifikator konnten mehrere Pruefungsteilnehmer zugeordnet werden.
+ExamCorrectErrorNoMatchingParticipants: Dem Identifikator konnte kein Pruefungsteilnehmer zugeordnet werden.
+
 SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen
 SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt
 SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn}

messages/uniworx/en-eu.msg

@@ -1402,6 +1402,9 @@ ExamCorrectHeadStatus: Status
 
 ExamCorrectButtonSend: Submit
 
+ExamCorrectErrorMultipleMatchingParticipants: This identifier matches on multiple exam participants.
+ExamCorrectErrorNoMatchingParticipants: This identifier does not match on any exam participant.
+
 SubmissionUserInvitationAccepted shn: You now participate in a submission for #{shn}
 SubmissionUserInvitationDeclined shn: You have declined the invitation to participate in a submission for #{shn}
 SubmissionUserInviteHeading shn: Invitation to participate in a submission for #{shn}

src/Handler/Exam/Correct.hs

@@ -4,38 +4,58 @@ module Handler.Exam.Correct
 
 import Import
 
+import qualified Data.Set as Set
 import qualified Data.CaseInsensitive as CI (original)
 
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
 import Handler.Utils
 import Handler.Utils.Exam (fetchExam)
 
 
-data CorrectInterfaceResponse
-  = CorrectInterfaceSuccess
-    { ciUserIdent :: CryptoUUIDUser
-    , ciUserDisplayName :: Text
-    , ciUserMatrikelnummer :: Maybe Text
-    , ciResults :: Map ExamPartNumber (Maybe Points)
-    }
-  | CorrectInterfaceFailure
-    { ciIcon :: Icon
-    , ciMessage :: Text
+data CorrectInterfaceUser
+  = CorrectInterfaceUser
+    { ciuSurname     :: Text
+    , ciuDisplayName :: Text
+    , ciuMatNr       :: Maybe UserMatriculation
+    , ciuId          :: CryptoUUIDUser
     }
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 2
-  , fieldLabelModifier = camelToPathPiece' 1
-  , sumEncoding = TaggedObject "status" "result"
-  } ''CorrectorInterfaceResponse
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''CorrectInterfaceUser
+
+data CorrectInterfaceResponse
+  = CorrectInterfaceResponseSuccess
+    { cirsUser       :: CorrectInterfaceUser
+    , cirsResults    :: Map ExamPartNumber (Maybe Points)
+    }
+  | CorrectInterfaceResponseAmbiguous
+    { ciraUsers      :: Set CorrectInterfaceUser
+    , ciraMessage    :: Text
+    }
+  | CorrectInterfaceResponseFailure
+    { cirfMessage    :: Text
+    }
+  | CorrectInterfaceResponseNoOp
+    { cirnUsers      :: Set CorrectInterfaceUser
+    }
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 3
+  , fieldLabelModifier     = camelToPathPiece' 1
+  , sumEncoding            = TaggedObject "status" "result"
+  } ''CorrectInterfaceResponse
 -- 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)
+    { ciqName        :: Text
+    , ciqResults     :: Map ExamPartNumber (Maybe Points)
+    , ciqNoOp        :: Bool
     }
 deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''CorrectorInterfaceRequest
+  { fieldLabelModifier     = camelToPathPiece' 1
+  } ''CorrectInterfaceRequest
 -- E.g.: { "name": "max", "results": { "1a": null, "2c3.5": 9001.2 }}
  
 
@@ -63,6 +83,69 @@ getECorrectR tid ssh csh examn = do
   siteLayoutMsg heading $ do
     setTitleI heading
     $(widgetFile "exam-correct")
-  
+
+
 postECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Value
-postECorrectR = error "ECorrectR not implemented" -- use returnJson & requireCheckJsonBody
+postECorrectR tid ssh csh examn = do
+  now <- liftIO getCurrentTime
+  mUid <- maybeAuthId
+  MsgRenderer mr <- getMsgRenderer
+
+  CorrectInterfaceRequest{ciqName,ciqResults,ciqNoOp} <- requireCheckJsonBody
+
+  participantMatches <- runDB $ do
+    Entity eId _ <- fetchExam tid ssh csh examn
+    E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do
+      E.on $ examRegistration E.^. ExamRegistrationUser E.==. user
+      E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
+        E.&&. ( user E.^. UserMatrikelnummer E.==. E.val ciqName
+          E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val ciqName
+          E.||. user E.^. UserSurname E.==. 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.hasInfix` E.val ciqName
+          E.||. user E.^. UserDisplayName E.==. E.val ciqName
+          E.||. user E.^. UserDisplayName `E.hasInfix` E.val ciqName )
+      return user
+
+  let
+    usersToResponse = traverse $ \user@(Entity uid User{..}) -> do
+      uuid <- encrypt uid
+      return CorrectInterfaceUser
+        { ciuSurname     = userSurname
+        , ciuDisplayName = userDisplayName
+        , ciuMatNr       = userMatrikelnummer
+        , ciuId          = uuid
+        }
+
+  if
+    | ciqNoOp -> do
+      users <- usersToResponse participantMatches
+      returnJson $ CorrectInterfaceResponseNoOp
+        { cirnUsers     = Set.fromList users
+        }
+    | [match] <- participantMatches -> do
+      -- TODO upsert results
+      -- TODO log to Transaction Log
+      [user] <- usersToResponse participantMatches
+      returnJson $ CorrectInterfaceResponseSuccess
+        { cirsUser      = user
+        , cirsResults   = ciqResults
+        }
+    | [] <- participantMatches -> returnJson $ CorrectInterfaceResponseFailure
+      { cirfMessage     = mr MsgExamCorrectErrorNoMatchingParticipants
+      }
+    | otherwise -> do
+      users <- usersToResponse participantMatches
+      returnJson $ CorrectInterfaceResponseAmbiguous
+        { ciraMessage     = mr MsgExamCorrectErrorMultipleMatchingParticipants
+        , ciraUsers       = Set.fromList users
+        }
+
+    -- TODO if the request is a noop, respond with a 200 and the matches
+    -- TODO if there is exactly one match, respond with a 200, a (Map ExamPartNumber ExamPartPoints) 
+    --      and a single (surname,displayName,matrikelnummer)
+
+    -- TODO if there are multiple matches, respond with a 400 and a set containing the matches (Ambiguous case)
+
+    -- TODO if there are no matches, respond with a 400 and an error message (no matches, Failure case)