feat(guess-user): replace guessUser and usages
This commit is contained in:
Sarah Vaupel
parent
58ae9dddbc
commit
ca96518e0e
@ -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").
|
||||
|
||||
@ -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").
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user