diff --git a/frontend/src/utils/exam-correct/exam-correct.js b/frontend/src/utils/exam-correct/exam-correct.js index edee3bc47..cf23c911d 100644 --- a/frontend/src/utils/exam-correct/exam-correct.js +++ b/frontend/src/utils/exam-correct/exam-correct.js @@ -19,6 +19,7 @@ const EXAM_CORRECT_SEND_BTN_ID = 'exam-correct__send-btn'; const EXAM_CORRECT_USER_INPUT_ID = 'exam-correct__user'; const EXAM_CORRECT_USER_INPUT_STATUS_ID = 'exam-correct__user-status'; const EXAM_CORRECT_USER_INPUT_CANDIDATES_ID = 'exam-correct__user-candidates'; +const EXAM_CORRECT_USER_INPUT_CANDIDATES_MORE_ID = 'exam-correct__user-candidates-more'; const EXAM_CORRECT_INPUT_BODY_ID = 'exam-correct__new'; const EXAM_CORRECT_USER_ATTR = 'exam-correct--user-id'; const EXAM_CORRECT_USER_DNAME_ATTR = 'exam-correct--user-dname'; @@ -45,6 +46,7 @@ export class ExamCorrect { _userInput; _userInputStatus; _userInputCandidates; + _userInputCandidatesMore; _partInputs; _resultSelect; _resultGradeSelect; @@ -77,6 +79,7 @@ export class ExamCorrect { this._userInput = document.getElementById(EXAM_CORRECT_USER_INPUT_ID); this._userInputStatus = document.getElementById(EXAM_CORRECT_USER_INPUT_STATUS_ID); this._userInputCandidates = document.getElementById(EXAM_CORRECT_USER_INPUT_CANDIDATES_ID); + this._userInputCandidatesMore = document.getElementById(EXAM_CORRECT_USER_INPUT_CANDIDATES_MORE_ID); this._partInputs = [...this._element.querySelectorAll(`input[${EXAM_CORRECT_PART_INPUT_ATTR}]`)]; const resultCell = document.getElementById('uw-exam-correct__result'); this._resultSelect = resultCell && resultCell.querySelector('select'); @@ -109,6 +112,10 @@ export class ExamCorrect { throw new Error('ExamCorrect utility could not detect user input candidate list!'); } + if (!this._userInputCandidatesMore) { + throw new Error('ExamCorrect utility could not detect user input candidate more element'); + } + // TODO get date format by post request this._dateFormat = 'DD.MM.YYYY HH:mm:ss'; @@ -178,6 +185,7 @@ export class ExamCorrect { // do nothing in case of empty or invalid input if (!this._userInput.value || this._userInput.reportValidity && !this._userInput.reportValidity()) { removeAllChildren(this._userInputCandidates); + this._userInputCandidatesMore.hidden = true; setStatus(this._userInputStatus, STATUS.NONE); return; } @@ -212,6 +220,7 @@ export class ExamCorrect { // TODO avoid code duplication if (this._userInput.reportValidity && !this._userInput.reportValidity()) { removeAllChildren(this._userInputCandidates); + this._userInputCandidatesMore.hidden = true; setStatus(this._userInput, STATUS.NONE); return; } @@ -305,6 +314,7 @@ export class ExamCorrect { if (response.users) { // delete candidate list entries from previous requests removeAllChildren(this._userInputCandidates); + this._userInputCandidatesMore.hidden = true; // show error if there are no matches for this input if (response.users.length === 0) { @@ -335,6 +345,7 @@ export class ExamCorrect { // remove all candidates on accept removeAllChildren(this._userInputCandidates); + this._userInputCandidatesMore.hidden = true; setStatus(this._userInputStatus, STATUS.SUCCESS); @@ -344,6 +355,7 @@ export class ExamCorrect { this._userInputCandidates.appendChild(candidateItem); }); + this._userInputCandidatesMore.hidden = response['has-more'] !== true; } else { // TODO what to do in this case? setStatus(this._userInputStatus, STATUS.FAILURE); @@ -388,6 +400,7 @@ export class ExamCorrect { // TODO set edit button visibility status = STATUS.AMBIGUOUS; newEntry.users = response.users; + newEntry.hasMore = response['has-more'] === true; newEntry.message = response.message || null; break; case 'failure': @@ -426,7 +439,7 @@ export class ExamCorrect { userElem.innerHTML = userToHTML(user); userElem.setAttribute(EXAM_CORRECT_USER_ATTR, user.id || user); } else if (userElem && newEntry.users) { - row.replaceChild(userElem, this._showUserList(row, newEntry.users, { partResults: request.results, result: request.grade } )); + row.replaceChild(userElem, this._showUserList(row, newEntry.users, { partResults: request.results, result: request.grade }, newEntry.hasMore === true)); } for (let [k, v] of Object.entries(newEntry.results)) { @@ -477,7 +490,7 @@ export class ExamCorrect { } // TODO better name - _showUserList(row, users, results) { + _showUserList(row, users, results, hasMore) { let userElem = row.cells.item(this._cIndices.get('user')); if (!userElem) { userElem = document.createElement('TD'); @@ -499,6 +512,12 @@ export class ExamCorrect { list.appendChild(listItem); } userElem.appendChild(list); + if (hasMore === true) { + const moreElem = this._userInputCandidatesMore.cloneNode(true); + moreElem.removeAttribute('id'); + moreElem.hidden = false; + userElem.appendChild(moreElem); + } } else { console.error('Unable to show users from invalid response'); } @@ -598,6 +617,7 @@ export class ExamCorrect { _clearUserInput() { removeAllChildren(this._userInputCandidates); + this._userInputCandidatesMore.hidden = true; clearInput(this._userInput); this._userInput.removeAttribute(EXAM_CORRECT_USER_ATTR); this._userInput.removeAttribute(EXAM_CORRECT_USER_DNAME_ATTR); diff --git a/frontend/src/utils/hide-columns/hide-columns.js b/frontend/src/utils/hide-columns/hide-columns.js index 0c214ee38..7661ac92b 100644 --- a/frontend/src/utils/hide-columns/hide-columns.js +++ b/frontend/src/utils/hide-columns/hide-columns.js @@ -376,7 +376,9 @@ function isEmptyElement(element) { } function isTableHider(element) { - return element.classList.contains(TABLE_HIDER_CLASS) + return element && element.classList && ( + element.classList.contains(TABLE_HIDER_CLASS) || element.classList.contains(TABLE_HIDER_VISIBLE_CLASS) - || element.classList.contains(TABLE_PILL_CLASS); + || element.classList.contains(TABLE_PILL_CLASS) + ); } diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index c189e8b5f..8f8f5ccfd 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1346,6 +1346,7 @@ MenuExternalExamUsers: Teilnehmer MenuExternalExamEdit: Bearbeiten MenuExternalExamNew: Neue externe Prüfung MenuExternalExamList: Externe Prüfungen +MenuExternalExamCorrect: Prüfungsleistungen eintragen MenuParticipantsList: Kursteilnehmerlisten MenuParticipantsIntersect: Überschneidung von Kursteilnehmern MenuAllocationUsers: Bewerber @@ -1417,6 +1418,7 @@ BreadcrumbExternalExamEdit: Editieren BreadcrumbExternalExamUsers: Teilnehmer BreadcrumbExternalExamGrades: Prüfungsleistungen BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer +BreadcrumbExternalExamCorrect: Prüfungsleistungen eintragen BreadcrumbParticipantsList: Kursteilnehmerlisten BreadcrumbParticipants: Kursteilnehmerliste BreadcrumbExamAutoOccurrence: Automatische Termin-/Raumverteilung @@ -1433,6 +1435,7 @@ BreadcrumbAdminCrontab: Crontab ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} +ExternalExamCorrectHeading coursen@CourseName examn@ExamName: Prüfungsleistungen für #{coursen}, #{examn} eintragen ExternalExamUsers coursen@CourseName examn@ExamName: Teilnehmer: #{coursen}, #{examn} TitleMetrics: Metriken @@ -1574,6 +1577,7 @@ ExamRegistrationInviteExplanation: Sie wurden eingeladen, Prüfungsteilnehmer zu ExamCorrectHeading examname@Text: Prüfungsergebnisse für #{examname} eintragen ExamCorrectExamResultDelete: Prüfungsergebnis löschen ExamCorrectExamResultNone: Keine Änderung +ExamCorrectUserCandidatesMore: und weitere ExamCorrectHeadDate: Zeit ExamCorrectHeadParticipant: Teilnehmer @@ -1589,6 +1593,9 @@ ExamCorrectErrorNoMatchingParticipants: Dem Identifikator konnte kein Prüfungst ExamCorrectErrorPartResultOutOfBounds examPartNumber@ExamPartNumber: Prüfungsergebnis für Teil #{examPartNumber} ist nicht größer Null. ExamCorrectErrorPartResultOutOfBoundsMax examPartNumber@ExamPartNumber maxPoints@Points: Prüfungsergebnis für Teil #{examPartNumber} liegt nicht zwischen 0 und #{maxPoints}. +ExternalExamCorrectErrorMultipleMatchingUsers: Dem Identifikator konnten mehrere Studierende zugeordnet werden. +ExternalExamCorrectErrorNoMatchingUsers: Dem Identifikator konnte kein Studierender 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} @@ -2042,6 +2049,7 @@ ExamBonusNone: Keine Bonuspunkte ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht ExamUserCsvExceptionNoMatchingUser: Benutzer konnte nicht eindeutig identifiziert werden. Alle Identifikatoren des Benutzers (Vorname(n), Nachname, Voller Name, Matrikelnummer, ...) müssen exakt übereinstimmen. Sie können versuchen für diese Zeile manche der Identifikatoren zu entfernen (also z.B. nur eine Matrikelnummer angeben) um dem System zu erlauben nur Anhand der verbleibenden Identifikatoren zu suchen. Sie sollten dann natürlich besonders kontrollieren, dass das System den fraglichen Benutzer korrekt identifiziert hat. +ExamUserCsvExceptionMultipleMatchingUsers: Benutzer konnte nicht eindeutig identifiziert werden. Es wurden mehrere Benutzer gefunden, welche mit den gegebenen Identifikatoren übereinstimmen. Sie können versuchen, für diese Zeile weitere Identifikatoren anzugeben damit nur noch der gewünschte Benutzer mit diesen identifiziert werden kann. ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Studienfach des Benutzers zugeordnet werden. Sie können versuchen für diese Zeile die Studiengangsdaten zu entfernen um das System automatisch ein Studienfach wählen zu lassen. ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden. Überprüfen Sie, dass diese Zeile nur interne Raumbezeichnungen enthält, wie sie auch für die Prüfung konfiguriert wurden. ExamUserCsvExceptionMismatchedGradingMode expectedGradingMode@ExamGradingMode actualGradingMode@ExamGradingMode: Es wurde versucht eine Prüfungsleistung einzutragen, die zwar vom System interpretiert werden konnte, aber nicht dem für diese Prüfung erwarteten Modus entspricht. Der erwartete Bewertungsmodus kann unter "Prüfung bearbeiten" angepasst werden ("Bestanden/Nicht Bestanden", "Numerische Noten" oder "Gemischt"). diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 0c443642b..bb7d7e9ce 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1346,6 +1346,7 @@ MenuExternalExamUsers: Participants MenuExternalExamEdit: Edit MenuExternalExamNew: New external exam MenuExternalExamList: External exams +MenuExternalExamCorrect: Enter exam results MenuParticipantsList: Lists of course participants MenuParticipantsIntersect: Common course participants MenuAllocationUsers: Applicants @@ -1417,6 +1418,7 @@ BreadcrumbExternalExamEdit: Edit BreadcrumbExternalExamUsers: Participants BreadcrumbExternalExamGrades: Exam results BreadcrumbExternalExamStaffInvite: Invitation +BreadcrumbExternalExamCorrect: Enter exam results BreadcrumbParticipantsList: Lists of course participants BreadcrumbParticipants: Course participants BreadcrumbExamAutoOccurrence: Automatic occurrence/room distribution @@ -1433,6 +1435,7 @@ BreadcrumbAdminCrontab: Crontab ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn} ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn} +ExternalExamCorrectHeading coursen examn: Enter exam results for #{coursen}, #{examn} ExternalExamUsers coursen examn: Exam participants: #{coursen}, #{examn} TitleMetrics: Metrics @@ -1585,8 +1588,12 @@ ExamCorrectErrorNoMatchingParticipants: This identifier does not match on any ex ExamCorrectErrorPartResultOutOfBounds examPartNumber: Exam part result for #{examPartNumber} ist not greater zero. ExamCorrectErrorPartResultOutOfBoundsMax examPartNumber maxPoints: Exam part result for #{examPartNumber} is not between 0 and #{maxPoints}. +ExternalExamCorrectErrorMultipleMatchingUsers: This identifier matches on multiple students. +ExternalExamCorrectErrorNoMatchingUsers: This identifier does not match any student. + ExamCorrectExamResultDelete: Delete exam result ExamCorrectExamResultNone: No change +ExamCorrectUserCandidatesMore: and more SubmissionUserInvitationAccepted shn: You now participate in a submission for #{shn} SubmissionUserInvitationDeclined shn: You have declined the invitation to participate in a submission for #{shn} @@ -2041,6 +2048,7 @@ ExamBonusNone: No bonus points ExamUserCsvCourseNoteDeleted: Course note will be deleted ExamUserCsvExceptionNoMatchingUser: Course participant could not be identified uniquely. All identifiers (given name(s), surname, display name, matriculation, ..) must match exactly. You can try to remove some of the identifiers for the given line (i.e. all but matriculation). Uni2work will then search for users using only the remaining identifiers. In this case special care should be taken that Uni2work correctly identifies the intended user. +ExamUserCsvExceptionMultipleMatchingUsers: Course participant could not be identified uniquely. There are multiple users that match the given identifiers. You can try to add more identifiers for the given line to ensure that only the intended user can be identified with them. ExamUserCsvExceptionNoMatchingStudyFeatures: The specified field did not match with any of the participant's fields of study. You can try to remove the field of study for the given line. Uni2work will then automatically choose a field of study. ExamUserCsvExceptionNoMatchingOccurrence: Occurrence/room could not be identified uniquely. Please ensure that the given line only contains internal room identifiers exactly as they have been configured for this exam. ExamUserCsvExceptionMismatchedGradingMode expectedGradingMode actualGradingMode: The imported data contained an exam achievement which does not match the grading mode for this exam. The expected grading mode can be changed at "Edit exam" ("Passed/Failed", "Numeric grades", or "Mixed"). diff --git a/routes b/routes index 0b790ae36..1bb1c3f9a 100644 --- a/routes +++ b/routes @@ -92,6 +92,7 @@ /users EEUsersR GET POST /grades EEGradesR GET POST !exam-office /staff-invite EEStaffInviteR GET POST + /correct EECorrectR GET POST /term TermShowR GET !free diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 21099306f..8884fba25 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -72,6 +72,7 @@ decCryptoIDs [ ''SubmissionId , ''CourseNewsId , ''CourseEventId , ''TutorialId + , ''ExternalExamId ] decCryptoIDKeySize diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b1a242f0a..f1e8281c1 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -329,6 +329,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR + EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR data NavQuickView @@ -2128,9 +2129,66 @@ pageActions (EExamR tid ssh coursen examn EEShowR) = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamCorrect + , navRoute = EExamR tid ssh coursen examn EECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions (EExamR tid ssh coursen examn EEGradesR) = return [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamCorrect + , navRoute = EExamR tid ssh coursen examn EECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamUsers + , navRoute = EExamR tid ssh coursen examn EEUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamEdit + , navRoute = EExamR tid ssh coursen examn EEEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (EExamR tid ssh coursen examn EECorrectR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamGrades + , navRoute = EExamR tid ssh coursen examn EEGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamUsers , navRoute = EExamR tid ssh coursen examn EEUsersR @@ -2165,6 +2223,17 @@ pageActions (EExamR tid ssh coursen examn EEUsersR) = return } , navChildren = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamCorrect + , navRoute = EExamR tid ssh coursen examn EECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuExternalExamEdit diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs index 2f66d8903..cc373b0bd 100644 --- a/src/Handler/Exam/Correct.hs +++ b/src/Handler/Exam/Correct.hs @@ -6,7 +6,6 @@ import Import import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI -import qualified Data.Aeson as JSON import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -15,63 +14,16 @@ import Database.Persist.Sql (transactionUndo) import Handler.Utils import Handler.Utils.Exam (fetchExam) -import qualified Data.HashMap.Strict as HashMap +import Utils.Exam.Correct -data CorrectInterfaceUser - = CorrectInterfaceUser - { ciuSurname :: Text - , ciuDisplayName :: Text - , ciuMatNr :: Maybe UserMatriculation - , ciuId :: CryptoUUIDUser - } deriving (Eq,Ord) -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''CorrectInterfaceUser +-- | Minimum length of a participant identifier. Identifiers that are shorter would result in too many query results and are therefor rejected. +minNeedleLength :: Int +minNeedleLength = 3 -data CorrectInterfaceResponse - = CorrectInterfaceResponseSuccess - { cirsUser :: CorrectInterfaceUser - , cirsResults :: Map ExamPartNumber (Maybe ExamResultPoints) - , cirsGrade :: Maybe (Maybe ExamResultPassedGrade) - , cirsTime :: UTCTime - } - | CorrectInterfaceResponseAmbiguous - { ciraUsers :: Set CorrectInterfaceUser - , ciraMessage :: Text - } - | CorrectInterfaceResponseFailure - { cirfUser :: Maybe CorrectInterfaceUser - , cirfMessage :: Text - } - | CorrectInterfaceResponseNoOp - { cirnUsers :: Set CorrectInterfaceUser - } -deriveToJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 3 - , fieldLabelModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "status" "results" - , omitNothingFields = True - } ''CorrectInterfaceResponse - -data CorrectInterfaceRequest - = CorrectInterfaceRequest - { ciqUser :: Either Text (CryptoID UUID (Key User)) - , ciqResults :: Maybe (NonNull (Map ExamPartNumber (Maybe Points))) - , ciqGrade :: Maybe (Maybe ExamResultPassedGrade) - } - -instance FromJSON CorrectInterfaceRequest where - parseJSON = JSON.withObject "CorrectInterfaceRequest" $ \o -> do - 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 <- if - | "grade" `HashMap.member` o - -> Just <$> o JSON..: "grade" - | otherwise - -> pure Nothing - return CorrectInterfaceRequest{..} +-- | Maximum number of participant matches to show. Also serves as an upper limit to the number of query results from participant lookups. +maxCountUserMatches :: Integral a => a +maxCountUserMatches = 10 getECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html @@ -116,10 +68,9 @@ postECorrectR tid ssh csh examn = do Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn euid <- traverse decrypt ciqUser - guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $ + guardMExceptT (maybe True ((>= minNeedleLength) . length) $ euid ^? _Left) $ CorrectInterfaceResponseFailure Nothing <$> (getMessageRender <*> pure MsgExamCorrectErrorNeedleTooShort) - participantMatches <- lift . 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 @@ -138,24 +89,16 @@ postECorrectR tid ssh csh examn = do E.||. user E.^. UserMatrikelnummer E.==. E.val mUserIdent E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val mUserIdent Nothing -> E.val False) + E.limit $ succ maxCountUserMatches 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 | is _Nothing ciqResults, is _Nothing ciqGrade -> do - users <- traverse userToResponse participantMatches + users <- traverse userToResponse $ take maxCountUserMatches participantMatches return CorrectInterfaceResponseNoOp - { cirnUsers = Set.fromList users + { cirnUsers = Set.fromList users + , cirnHasMore = length participantMatches > maxCountUserMatches } -- on match with exactly one exam participant, insert results and/or grade and answer with 200 @@ -247,19 +190,14 @@ postECorrectR tid ssh csh examn = do -- on match with multiple exam participants, answer with 400 and a set of all matches | otherwise -> do - users <- traverse userToResponse participantMatches + users <- traverse userToResponse $ take maxCountUserMatches participantMatches return CorrectInterfaceResponseAmbiguous { ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants + , ciraHasMore = length participantMatches > maxCountUserMatches , ciraUsers = Set.fromList users } - - let - responseStatus = case response of - CorrectInterfaceResponseSuccess{} -> ok200 - CorrectInterfaceResponseNoOp{} -> ok200 - _ -> badRequest400 - + whenM acceptsJson $ - sendResponseStatus responseStatus $ toJSON response - + sendResponseStatus (ciResponseStatus response) $ toJSON response + redirect $ CExamR tid ssh csh examn EShowR diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 55545bbff..9fcf76c04 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -389,6 +389,7 @@ deriveJSON defaultOptions data ExamUserCsvException = ExamUserCsvExceptionNoMatchingUser + | ExamUserCsvExceptionMultipleMatchingUsers | ExamUserCsvExceptionNoMatchingStudyFeatures | ExamUserCsvExceptionNoMatchingOccurrence | ExamUserCsvExceptionMismatchedGradingMode ExamGradingMode ExamGradingMode @@ -972,13 +973,14 @@ postEUsersR tid ssh csh examn = do guessUser' :: ExamUserTableCsv -> DB (Bool, UserId) guessUser' ExamUserTableCsv{..} = do - let criteria = Set.fromList $ catMaybes + let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes [ GuessUserMatrikelnummer <$> csvEUserMatriculation , GuessUserDisplayName <$> csvEUserName , GuessUserSurname <$> csvEUserSurname , GuessUserFirstName <$> csvEUserFirstName ] - pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria + guess <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria (Just 2) -- we're only interested in at most one match, but want to throw an error on multiple matches + pid <- either (const $ throwM ExamUserCsvExceptionMultipleMatchingUsers) (return . entityKey) guess (,) <$> exists [CourseParticipantCourse ==. examCourse, CourseParticipantUser ==. pid, CourseParticipantState ==. CourseParticipantActive] <*> pure pid lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId) diff --git a/src/Handler/ExternalExam.hs b/src/Handler/ExternalExam.hs index ac53b0246..fe4c662f3 100644 --- a/src/Handler/ExternalExam.hs +++ b/src/Handler/ExternalExam.hs @@ -8,3 +8,4 @@ import Handler.ExternalExam.Show as Handler.ExternalExam import Handler.ExternalExam.Edit as Handler.ExternalExam import Handler.ExternalExam.Users as Handler.ExternalExam import Handler.ExternalExam.StaffInvite as Handler.ExternalExam +import Handler.ExternalExam.Correct as Handler.ExternalExam diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs new file mode 100644 index 000000000..8e4987be4 --- /dev/null +++ b/src/Handler/ExternalExam/Correct.hs @@ -0,0 +1,149 @@ +module Handler.ExternalExam.Correct + ( getEECorrectR, postEECorrectR + ) where + +import Import + +import qualified Data.Set as Set +import qualified Data.List.NonEmpty as NonEmpty (toList) + +import qualified Database.Esqueleto as E +--import qualified Database.Esqueleto.Utils as E +import Database.Persist.Sql (transactionUndo) + +import Handler.Utils +import Handler.Utils.ExternalExam +import Handler.Utils.Users + +import Utils.Exam.Correct + + +-- | Minimum length of a participant identifier. Identifiers that are shorter would result in too many query results and are therefor rejected. +minNeedleLength :: Int +minNeedleLength = 3 -- TODO rethink + +-- | Maximum number of user matches to show. Also serves as an upper limit to the number of query results from user and/or ldap lookups. +maxCountUserMatches :: Integral a => a +maxCountUserMatches = 10 + + +getEECorrectR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html +getEECorrectR tid ssh coursen examn = do + MsgRenderer mr <- getMsgRenderer + + Entity eeId ExternalExam{..} <- runDB $ fetchExternalExam tid ssh coursen examn + + mayEditResults <- hasWriteAccessTo $ EExamR tid ssh coursen examn EEUsersR + + let + heading = mr $ MsgExternalExamCorrectHeading coursen examn + + ptsInput :: ExamPartNumber -> Widget + ptsInput = const mempty + + examParts :: [ExamPart] + examParts = [] + + examGrades :: [ExamGrade] + examGrades = universeF + + examGradingMode = externalExamGradingMode + + examCorrectIdent <- encrypt eeId :: Handler CryptoUUIDExternalExam + + siteLayoutMsg heading $ do + setTitleI heading + let examCorrectExplanation = $(i18nWidgetFile "external-exam-correct-explanation") + $(widgetFile "exam-correct") + + +postEECorrectR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Void +postEECorrectR tid ssh coursen examn = do + MsgRenderer mr <- getMsgRenderer + + CorrectInterfaceRequest{..} <- requireCheckJsonBody + + mayEditResults <- hasWriteAccessTo $ EExamR tid ssh coursen examn EEUsersR + + response <- runDB . exceptT (<$ transactionUndo) return $ do + Entity eeId ExternalExam{..} <- lift $ fetchExternalExam tid ssh coursen examn + euid <- traverse decrypt ciqUser + + guardMExceptT (maybe True ((>= minNeedleLength) . length) $ euid ^? _Left) $ + CorrectInterfaceResponseFailure Nothing <$> (getMessageRender <*> pure MsgExamCorrectErrorNeedleTooShort) + + matches <- case euid of + Right uid -> lift . E.select . E.from $ \user -> E.where_ (user E.^. UserId E.==. E.val uid) >> return user + Left ident -> + let pdnf = PredDNF . Set.fromList $ impureNonNull . Set.fromList . pure . PLVariable <$> + [ GuessUserMatrikelnummer (ident :: UserMatriculation) + , GuessUserDisplayName (ident :: UserDisplayName) + , GuessUserSurname (ident :: UserSurname) + , GuessUserFirstName (ident :: UserFirstName) + ] + in maybe [] (either NonEmpty.toList pure) <$> lift (guessUser pdnf $ Just $ maxCountUserMatches+1) + + if + | is _Nothing ciqResults, is _Nothing ciqGrade -> do + users <- traverse userToResponse $ take maxCountUserMatches matches + return CorrectInterfaceResponseNoOp + { cirnUsers = Set.fromList users + , cirnHasMore = length matches > maxCountUserMatches + } + | [match@(Entity uid _)] <- matches -> do + now <- liftIO getCurrentTime + newExamResult <- for ciqGrade $ \ciqGrade' -> lift $ do + unless mayEditResults $ + permissionDeniedI MsgUnauthorizedExamCorrectorGrade + mOldResult <- getBy $ UniqueExternalExamResult eeId uid + if + | Just (Entity oldId _) <- mOldResult, is _Nothing ciqGrade' -> do + delete oldId + audit $ TransactionExternalExamResultDelete eeId uid + return Nothing + | Just resultGrade <- ciqGrade' -> let + mOld = externalExamResultResult . entityVal <$> mOldResult + in if + | ciqGrade' /= mOld -> do + let resultTime = fromMaybe now externalExamDefaultTime + newResult <- upsert ExternalExamResult + { externalExamResultExam = eeId + , externalExamResultUser = uid + , externalExamResultResult = resultGrade + , externalExamResultTime = resultTime + , externalExamResultLastChanged = now + } + [ ExternalExamResultResult =. resultGrade + , ExternalExamResultTime =. resultTime + , ExternalExamResultLastChanged =. now + ] + audit $ TransactionExternalExamResultEdit eeId uid + return $ newResult ^? _entityVal . _externalExamResultResult + | otherwise -> return $ mOldResult ^? _Just . _entityVal . _externalExamResultResult + | otherwise -> return Nothing + + user <- userToResponse match + return CorrectInterfaceResponseSuccess + { cirsUser = user + , cirsResults = mempty + , cirsGrade = newExamResult + , cirsTime = now + } + + | [] <- matches -> return CorrectInterfaceResponseFailure + { cirfUser = Nothing + , cirfMessage = mr MsgExternalExamCorrectErrorNoMatchingUsers + } + + | otherwise -> do + users <- traverse userToResponse $ take maxCountUserMatches matches + return CorrectInterfaceResponseAmbiguous + { ciraUsers = Set.fromList users + , ciraHasMore = length matches > maxCountUserMatches + , ciraMessage = mr MsgExternalExamCorrectErrorMultipleMatchingUsers + } + + whenM acceptsJson $ + sendResponseStatus (ciResponseStatus response) $ toJSON response + + redirect $ EExamR tid ssh coursen examn EEShowR diff --git a/src/Handler/Utils/ExternalExam.hs b/src/Handler/Utils/ExternalExam.hs new file mode 100644 index 000000000..1d411e960 --- /dev/null +++ b/src/Handler/Utils/ExternalExam.hs @@ -0,0 +1,15 @@ +module Handler.Utils.ExternalExam + ( fetchExternalExam + ) where + +import Import + + +fetchExternalExam :: MonadHandler m => TermId -> SchoolId -> CourseName -> ExamName -> ReaderT SqlBackend m (Entity ExternalExam) +fetchExternalExam tid ssh coursen examn = + let cachId = encodeUtf8 $ tshow (tid, ssh, coursen, examn) + in cachedBy cachId $ do + mExtEx <- getBy $ UniqueExternalExam tid ssh coursen examn + case mExtEx of + Just extEx -> return extEx + _ -> notFound diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 75d52b3ff..68d6a5875 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -10,6 +10,7 @@ import Handler.Utils.Users import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.List.NonEmpty as NonEmpty (head) import qualified Colonnade @@ -393,7 +394,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do dbtCsvDecode | mode == EEUMUsers = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do - pid <- lift $ guessUser' csv + guess <- lift $ guessUser' csv + let pid = either (entityKey . NonEmpty.head) entityKey guess fmap E.Value . MaybeT . getKeyBy $ UniqueExternalExamResult eeId pid , dbtCsvComputeActions = \case DBCsvDiffMissing{dbCsvOldKey} @@ -401,8 +403,10 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do DBCsvDiffNew{dbCsvNewKey = Just _} -> error "An UniqueExternalExamResult could be found, but the ExternalExamResultKey is not among the existing keys" DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do - pid <- lift $ guessUser' dbCsvNew - let ExternalExamUserTableCsv{..} = dbCsvNew + guess <- lift $ guessUser' dbCsvNew + let + pid = either (entityKey . NonEmpty.head) entityKey guess + ExternalExamUserTableCsv{..} = dbCsvNew occTime <- maybe (throwM ExamUserCsvExceptionNoOccurrenceTime) return $ fmap zonedTimeToUTC csvEUserOccurrenceStart <|> externalExamDefaultTime yield $ ExternalExamUserCsvRegisterData pid occTime csvEUserExamResult DBCsvDiffExisting{..} -> do @@ -485,16 +489,16 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname where Entity _ User{..} = view resultUser $ existing Map.! registration - - guessUser' :: ExternalExamUserTableCsv -> DB UserId + + guessUser' :: ExternalExamUserTableCsv -> DB (Either (NonEmpty (Entity User)) (Entity User)) guessUser' ExternalExamUserTableCsv{..} = do - let criteria = Set.fromList $ catMaybes + let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes [ GuessUserMatrikelnummer <$> csvEUserMatriculation , GuessUserDisplayName <$> csvEUserName , GuessUserSurname <$> csvEUserSurname , GuessUserFirstName <$> csvEUserFirstName ] - maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria + maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria (Just 1) -- we're only interested in at most one match externalExamUsersDBTableValidator = def & defaultSorting (bool id (SortAscBy "is-synced" :) (mode == EEUMGrades) [SortAscBy "user-name"]) & defaultPagesize PagesizeAll diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 5e35237e6..9e55182cf 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -15,6 +15,8 @@ import Foundation.Yesod.Auth (upsertCampusUser) import Crypto.Hash (hashlazy) import Data.ByteArray (constEq) +import Data.Maybe (fromJust) +import qualified Data.List.NonEmpty as NonEmpty (fromList) import qualified Data.Aeson as JSON @@ -68,15 +70,20 @@ matchesName (repack -> haystack) (repack -> needle) , singletonMap NameMatchPermutation $ ((==) `on` MultiSet.fromList) (asWords needle) (asWords haystack) ] -guessUser :: Set GuessUserInfo -> DB (Maybe UserId) -guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False + +guessUser :: PredDNF GuessUserInfo -- ^ guessing criteria + -> Maybe Int64 -- ^ Should the query be limited to a maximum number of results? + -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User))) -- ^ Just (Left _) in case of multiple results, + -- Just (Right _) in case of single result, and + -- Nothing in case of no result +guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) mQueryLimit = $cachedHereBinary criteria $ go False where asWords :: Text -> [Text] asWords = filter (not . Text.null) . Text.words . Text.strip containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y - - toSql user = \case + + toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname' @@ -84,39 +91,84 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False go didLdap = do let retrieveUsers = E.select . E.from $ \user -> do - E.where_ . E.and $ map (toSql user) criteria + E.where_ . E.or $ map (E.and . map (toSql user)) criteria + when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit return user users <- retrieveUsers let users' = sortBy (flip closeness) users matchesMatriculation :: Entity User -> Maybe Bool - matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> all ((== userMatr) . Just) $ criteria ^.. folded . _guessUserMatrikelnummer) + matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> + any (\p -> all ((== userMatr) . Just) (p ^.. folded . _PLVariable . _guessUserMatrikelnummer) + && all ((/= userMatr) . Just) (p ^.. folded . _PLNegated . _guessUserMatrikelnummer)) + $ criteria ^.. folded) closeness :: Entity User -> Entity User -> Ordering - closeness = mconcat $ concat - [ pure $ comparing (fmap Down . matchesMatriculation) - , (criteria ^.. folded . _guessUserSurname) <&> \surn -> comparing (view $ _entityVal . _userSurname . to (`matchesName` surn)) - , (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (view $ _entityVal . _userFirstName . to (`matchesName` firstn)) - , (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (view $ _entityVal . _userDisplayName . to (`matchesName` dispn)) - ] + closeness ul ur = maximum $ impureNonNull $ criteria <&> \term -> + let + matches userField name = _entityVal . userField . to (`matchesName` name) + comp True userField guess = (term ^.. folded . _PLVariable . guess) <&> \name -> + compare ( ul ^. userField `matches` name) + ( ur ^. userField `matches` name) + comp False userField guess = (term ^.. folded . _PLNegated . guess) <&> \name -> + compare (Down $ ul ^. userField `matches` name) + (Down $ ur ^. userField `matches` name) + in mconcat $ concat $ + [ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur) + ] <> + [ comp b userField guess + | (userField,guess) <- [(_userSurname , _guessUserSurname) + ,(_userFirstName , _guessUserFirstName) + ,(_userDisplayName, _guessUserDisplayName) + ] + , b <- [True,False] + ] + + -- Assuming the input list is sorted in descending order by closeness: + takeClosest [] = [] + takeClosest [x] = [x] + takeClosest (x:x':xs) + | EQ <- x `closeness` x' = x : takeClosest (x':xs) + | otherwise = [x] doLdap userMatr = do ldapPool' <- getsYesod $ view _appLdapPool - fmap (fmap entityKey . join) . for ldapPool' $ \ldapPool -> do + fmap join . for ldapPool' $ \ldapPool -> do ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr for ldapData $ upsertCampusUser UpsertCampusUser + let + getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation + getTermMatr = getTermMatrAux Nothing where + getTermMatrAux acc [] = acc + getTermMatrAux acc (PLVariable (GuessUserMatrikelnummer matr):xs) + | Just matr' <- acc, matr == matr' = getTermMatrAux acc xs + | Nothing <- acc = getTermMatrAux (Just matr) xs + | otherwise = Nothing + getTermMatrAux acc (PLNegated (GuessUserMatrikelnummer matr):xs) + | Just matr' <- acc, matr /= matr' = getTermMatrAux acc xs + | Nothing <- acc = getTermMatrAux acc xs + | otherwise = Nothing + getTermMatrAux acc (_:xs) = getTermMatrAux acc xs + + convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User)) + convertLdapResults [] = Nothing + convertLdapResults [x] = Just $ Right x + convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs + if - | [x@(Entity pid _)] <- users' + | [x] <- users' , Just True == matchesMatriculation x || didLdap - -> return $ Just pid - | x@(Entity pid _) : x' : _ <- users' + -> return $ Just $ Right x + | x : x' : _ <- users' , Just True == matchesMatriculation x || didLdap , GT <- x `closeness` x' - -> return $ Just pid + -> return $ Just $ Right x + | xs@(x:_:_) <- takeClosest users' + , Just True == matchesMatriculation x || didLdap + -> return $ Just $ Left $ NonEmpty.fromList xs | not didLdap - , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer - , all (== userMatr) userMatrs' - -> doLdap userMatr >>= maybe (go True) (return . Just) + , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria + -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes | otherwise -> return Nothing diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 5ab120c3a..8fa709687 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -132,6 +132,7 @@ data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } deriving anyclass (Hashable, Binary) makeLenses_ ''PredLiteral +makePrisms ''PredLiteral deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 diff --git a/src/Utils/Exam/Correct.hs b/src/Utils/Exam/Correct.hs new file mode 100644 index 000000000..eec2fc30a --- /dev/null +++ b/src/Utils/Exam/Correct.hs @@ -0,0 +1,87 @@ +module Utils.Exam.Correct + ( CorrectInterfaceRequest(..) + , CorrectInterfaceResponse(..), ciResponseStatus + , CorrectInterfaceUser(..), userToResponse + ) where + +import Import.NoFoundation + +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HashMap + + +data CorrectInterfaceUser + = CorrectInterfaceUser + { ciuSurname :: Text + , ciuDisplayName :: Text + , ciuMatNr :: Maybe UserMatriculation + , ciuId :: CryptoUUIDUser + } deriving (Eq,Ord) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''CorrectInterfaceUser + +userToResponse :: (MonadHandler m, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => Entity User -> m CorrectInterfaceUser +userToResponse (Entity uid User{..}) = do + uuid <- encrypt uid + return CorrectInterfaceUser + { ciuSurname = userSurname + , ciuDisplayName = userDisplayName + , ciuMatNr = userMatrikelnummer + , ciuId = uuid + } + + +data CorrectInterfaceResponse + = CorrectInterfaceResponseSuccess + { cirsUser :: CorrectInterfaceUser + , cirsResults :: Map ExamPartNumber (Maybe ExamResultPoints) + , cirsGrade :: Maybe (Maybe ExamResultPassedGrade) + , cirsTime :: UTCTime + } + | CorrectInterfaceResponseAmbiguous + { ciraUsers :: Set CorrectInterfaceUser + , ciraHasMore :: Bool + , ciraMessage :: Text + } + | CorrectInterfaceResponseFailure + { cirfUser :: Maybe CorrectInterfaceUser + , cirfMessage :: Text + } + | CorrectInterfaceResponseNoOp + { cirnUsers :: Set CorrectInterfaceUser + , cirnHasMore :: Bool + } + +deriveToJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "status" "results" + , omitNothingFields = True + } ''CorrectInterfaceResponse + +ciResponseStatus :: CorrectInterfaceResponse -> Status +ciResponseStatus CorrectInterfaceResponseSuccess{} = ok200 +ciResponseStatus CorrectInterfaceResponseNoOp{} = ok200 +ciResponseStatus _ = badRequest400 + + +data CorrectInterfaceRequest + = CorrectInterfaceRequest + { ciqUser :: Either Text (CryptoID UUID (Key User)) + , ciqResults :: Maybe (NonNull (Map ExamPartNumber (Maybe Points))) + , ciqGrade :: Maybe (Maybe ExamResultPassedGrade) + } + +instance FromJSON CorrectInterfaceRequest where + parseJSON = JSON.withObject "CorrectInterfaceRequest" $ \o -> do + 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 <- if + | "grade" `HashMap.member` o + -> Just <$> o JSON..: "grade" + | otherwise + -> pure Nothing + return CorrectInterfaceRequest{..} diff --git a/templates/exam-correct.hamlet b/templates/exam-correct.hamlet index 47ab48deb..f6200a403 100644 --- a/templates/exam-correct.hamlet +++ b/templates/exam-correct.hamlet @@ -23,9 +23,11 @@ $newline never - +