diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index a1a607b77..8f8f5ccfd 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2049,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 8fa777f0c..bb7d7e9ce 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2048,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/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 1a5c67420..b64f9bc32 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 $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes $ [ GuessUserMatrikelnummer <$> csvEUserMatriculation , GuessUserDisplayName <$> csvEUserName , GuessUserSurname <$> csvEUserSurname , GuessUserFirstName <$> csvEUserFirstName ] - pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria + guess <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria + 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/Correct.hs b/src/Handler/ExternalExam/Correct.hs index ac91e0445..05eba38b4 100644 --- a/src/Handler/ExternalExam/Correct.hs +++ b/src/Handler/ExternalExam/Correct.hs @@ -5,13 +5,15 @@ module Handler.ExternalExam.Correct 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 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 @@ -70,23 +72,34 @@ postEECorrectR tid ssh coursen examn = do guardMExceptT (maybe True ((>= minNeedleLength) . length) $ euid ^? _Left) $ CorrectInterfaceResponseFailure Nothing <$> (getMessageRender <*> pure MsgExamCorrectErrorNeedleTooShort) - -- TODO additionally call guessUser if this query produces too few results - matches <- lift . E.select . E.from $ \user -> do - let mUserIdent = euid ^? _Left - E.where_ $ either (const E.false) (\uid -> user E.^. UserId E.==. E.val uid) euid - E.||. (case mUserIdent of - Just userIdent -> - user E.^. UserSurname E.==. E.val userIdent - E.||. user E.^. UserSurname `E.hasInfix` E.val userIdent - E.||. user E.^. UserFirstName E.==. E.val userIdent - E.||. user E.^. UserFirstName `E.hasInfix` E.val userIdent - E.||. user E.^. UserDisplayName E.==. E.val userIdent - E.||. user E.^. UserDisplayName `E.hasInfix` E.val userIdent - E.||. user E.^. UserMatrikelnummer E.==. E.val mUserIdent - E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val mUserIdent - Nothing -> E.false) - E.limit $ maxCountUserMatches+1 - return user + 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 lift (guessUser pdnf) >>= return . maybe [] (either NonEmpty.toList pure) -- TODO add and use option to E.limit query in guessUser (see deprecated query below) + + -- TODO remove + --userMatches <- lift . E.select . E.from $ \user -> do + -- let mUserIdent = euid ^? _Left + -- E.where_ $ either (const E.false) (\uid -> user E.^. UserId E.==. E.val uid) euid + -- E.||. (case mUserIdent of + -- Just userIdent -> + -- user E.^. UserSurname E.==. E.val userIdent + -- E.||. user E.^. UserSurname `E.hasInfix` E.val userIdent + -- E.||. user E.^. UserFirstName E.==. E.val userIdent + -- E.||. user E.^. UserFirstName `E.hasInfix` E.val userIdent + -- E.||. user E.^. UserDisplayName E.==. E.val userIdent + -- E.||. user E.^. UserDisplayName `E.hasInfix` E.val userIdent + -- E.||. user E.^. UserMatrikelnummer E.==. E.val mUserIdent + -- E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val mUserIdent + -- Nothing -> E.false) + -- E.limit $ maxCountUserMatches+1 + -- return user if | is _Nothing ciqResults, is _Nothing ciqGrade -> do diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 3aaf8b7e2..7b0bdac49 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 @@ -486,9 +490,9 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do 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 $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes $ [ GuessUserMatrikelnummer <$> csvEUserMatriculation , GuessUserDisplayName <$> csvEUserName , GuessUserSurname <$> csvEUserSurname diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 251bce187..527535189 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -6,7 +6,6 @@ module Handler.Utils.Users , matchesName , GuessUserInfo(..) , guessUser - , guessUserTmp ) where import Import @@ -69,62 +68,9 @@ 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 - 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 - GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') - GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' - GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname' - GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' - - go didLdap = do - let retrieveUsers = E.select . E.from $ \user -> do - E.where_ . E.and $ map (toSql user) criteria - 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) - - 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)) - ] - - doLdap userMatr = do - ldapPool' <- getsYesod $ view _appLdapPool - fmap (fmap entityKey . join) . for ldapPool' $ \ldapPool -> do - ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr - for ldapData $ upsertCampusUser UpsertCampusUser - - if - | x@(Entity pid _) : [] <- users' - , fromMaybe False (matchesMatriculation x) || didLdap - -> return $ Just pid - | x@(Entity pid _) : x' : _ <- users' - , fromMaybe False (matchesMatriculation x) || didLdap - , GT <- x `closeness` x' - -> return $ Just pid - | not didLdap - , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer - , all (== userMatr) userMatrs' - -> doLdap userMatr >>= maybe (go True) (return . Just) - | otherwise - -> return Nothing - - -guessUserTmp :: PredDNF GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User))) -guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) = $cachedHereBinary criteria $ go False +guessUser :: PredDNF GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User))) +guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) = $cachedHereBinary criteria $ go False where asWords :: Text -> [Text] asWords = filter (not . Text.null) . Text.words . Text.strip