+
+ _{MsgExamCorrectUserCandidatesMore}
$forall ExamPart{examPartNumber} <- examParts
^{ptsInput examPartNumber}
From ee5a0052a1b1ae1842ce968818f6fae2b2bd1150 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Wed, 12 Aug 2020 17:21:13 +0200
Subject: [PATCH 13/31] fix(hide-columns): account for undefined element in
isTableHider
---
frontend/src/utils/hide-columns/hide-columns.js | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
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)
+ );
}
From 527fd8a5cabb4c7d80e5d72239970f4e75163e3a Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Wed, 12 Aug 2020 17:40:43 +0200
Subject: [PATCH 14/31] chore(exam-correct): remove TODOs
---
src/Handler/Exam/Correct.hs | 3 ---
src/Handler/ExternalExam/Correct.hs | 5 +----
2 files changed, 1 insertion(+), 7 deletions(-)
diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs
index a14a839b3..21baa4b8c 100644
--- a/src/Handler/Exam/Correct.hs
+++ b/src/Handler/Exam/Correct.hs
@@ -21,9 +21,6 @@ import Utils.Exam
minNeedleLength :: Int
minNeedleLength = 3
--- TODO use according to description
--- TODO maybe renders minNeedleLength unnecessary?
--- TODO maybe also perform user and ldap lookups if there are fewer results than this number? (TODO add user as exam participant if not already participant)
-- | 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
diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs
index 729265437..bb976baaa 100644
--- a/src/Handler/ExternalExam/Correct.hs
+++ b/src/Handler/ExternalExam/Correct.hs
@@ -20,8 +20,6 @@ import Utils.Exam
minNeedleLength :: Int
minNeedleLength = 3 -- TODO rethink
--- TODO use according to description
--- TODO maybe renders minNeedleLength unnecessary?
-- | 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
@@ -53,8 +51,7 @@ getEECorrectR tid ssh coursen examn = do
siteLayoutMsg heading $ do
setTitleI heading
- let
- examCorrectExplanation = $(i18nWidgetFile "external-exam-correct-explanation")
+ let examCorrectExplanation = $(i18nWidgetFile "external-exam-correct-explanation")
$(widgetFile "exam-correct")
From 3b4c7fed3658cf3abe731fe45f24fe9c18b52b54 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Wed, 12 Aug 2020 17:53:38 +0200
Subject: [PATCH 15/31] feat(eecorrectr): more appropriate error messages
---
messages/uniworx/de-de-formal.msg | 3 +++
messages/uniworx/en-eu.msg | 3 +++
src/Handler/ExternalExam/Correct.hs | 4 ++--
3 files changed, 8 insertions(+), 2 deletions(-)
diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 5886e9815..a1a607b77 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -1593,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}
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index 50475f573..8fa777f0c 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -1588,6 +1588,9 @@ 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
diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs
index bb976baaa..ac91e0445 100644
--- a/src/Handler/ExternalExam/Correct.hs
+++ b/src/Handler/ExternalExam/Correct.hs
@@ -137,7 +137,7 @@ postEECorrectR tid ssh coursen examn = do
| [] <- matches -> return CorrectInterfaceResponseFailure
{ cirfUser = Nothing
- , cirfMessage = mr MsgExamCorrectErrorNoMatchingParticipants -- TODO use new msg
+ , cirfMessage = mr MsgExternalExamCorrectErrorNoMatchingUsers
}
| otherwise -> do
@@ -145,7 +145,7 @@ postEECorrectR tid ssh coursen examn = do
return CorrectInterfaceResponseAmbiguous
{ ciraUsers = Set.fromList users
, ciraHasMore = length matches > maxCountUserMatches
- , ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants -- TODO use new msg
+ , ciraMessage = mr MsgExternalExamCorrectErrorMultipleMatchingUsers
}
whenM acceptsJson $
From 753e29dfff6277dacd86cde6db741387168a838e Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Thu, 13 Aug 2020 11:49:10 +0200
Subject: [PATCH 16/31] chore(guess-user): first stub with different return
type
---
src/Handler/Utils/Users.hs | 68 ++++++++++++++++++++++++++++++++++++++
1 file changed, 68 insertions(+)
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index be010ee94..9229e470b 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -6,6 +6,7 @@ module Handler.Utils.Users
, matchesName
, GuessUserInfo(..)
, guessUser
+ , guessUserTmp
) where
import Import
@@ -14,6 +15,7 @@ import Auth.LDAP (campusUserMatr')
import Crypto.Hash (hashlazy)
import Data.ByteArray (constEq)
+import qualified Data.List.NonEmpty as NonEmpty (fromList)
import qualified Data.Aeson as JSON
@@ -119,3 +121,69 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
-> doLdap userMatr >>= maybe (go True) (return . Just)
| otherwise
-> return Nothing
+
+
+-- TODO replace guessUser with guessUserTmp when finished
+-- TODO PredDNF GuessUserInfo instead of Set GuessUserInfo
+guessUserTmp :: Set GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))
+guessUserTmp (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 join . for ldapPool' $ \ldapPool -> do
+ ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
+ for ldapData $ upsertCampusUser UpsertCampusUser
+
+ let
+ aux [] = []
+ aux [x] = [x]
+ aux (x:x':xs)
+ | EQ <- x `closeness` x' = x : aux (x':xs)
+ | otherwise = [x]
+
+ if
+ | x : [] <- users'
+ , fromMaybe False (matchesMatriculation x) || didLdap
+ -> return $ Just $ Right x
+ | x : x' : _ <- users'
+ , fromMaybe False (matchesMatriculation x) || didLdap
+ , GT <- x `closeness` x'
+ -> return $ Just $ Right x
+ | xs@(x:_:_) <- aux users'
+ , fromMaybe False (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 . Right)
+ | otherwise
+ -> return Nothing
From e1a997777267a157c8c7c6be03ff832eeb8ec9de Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Thu, 13 Aug 2020 13:48:31 +0200
Subject: [PATCH 17/31] chore(guess-user): first stub with PredDNF
---
src/Handler/Utils/Users.hs | 23 ++++++++++++++---------
1 file changed, 14 insertions(+), 9 deletions(-)
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 9229e470b..a79e3b4fe 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -124,9 +124,9 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
-- TODO replace guessUser with guessUserTmp when finished
--- TODO PredDNF GuessUserInfo instead of Set GuessUserInfo
-guessUserTmp :: Set GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))
-guessUserTmp (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
+-- TODO PredDNF GuessUserInfo instead of Set GuessUserInfo (work in progress)
+guessUserTmp :: PredDNF GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))
+guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) = $cachedHereBinary criteria $ go False
where
asWords :: Text -> [Text]
asWords = filter (not . Text.null) . Text.words . Text.strip
@@ -139,22 +139,27 @@ guessUserTmp (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname'
GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName'
+ mNeg PLVariable{} = id
+ mNeg PLNegated{} = E.not_
+
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 (\c -> mNeg c $ toSql user $ plVar c)) criteria
return user
users <- retrieveUsers
let users' = sortBy (flip closeness) users
+ -- TODO account for PLNegated
matchesMatriculation :: Entity User -> Maybe Bool
- matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> all ((== userMatr) . Just) $ criteria ^.. folded . _guessUserMatrikelnummer)
+ matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> any ((== userMatr) . Just) $ criteria ^.. folded . folded . _plVar . _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))
+ -- TODO account for PLNegated below
+ , (criteria ^.. folded . folded . _plVar . _guessUserSurname) <&> \surn -> comparing (view $ _entityVal . _userSurname . to (`matchesName` surn))
+ , (criteria ^.. folded . folded . _plVar . _guessUserFirstName) <&> \firstn -> comparing (view $ _entityVal . _userFirstName . to (`matchesName` firstn))
+ , (criteria ^.. folded . folded . _plVar . _guessUserDisplayName) <&> \dispn -> comparing (view $ _entityVal . _userDisplayName . to (`matchesName` dispn))
]
doLdap userMatr = do
@@ -182,7 +187,7 @@ guessUserTmp (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
, fromMaybe False (matchesMatriculation x) || didLdap
-> return $ Just $ Left $ NonEmpty.fromList xs
| not didLdap
- , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer
+ , userMatr : userMatrs' <- criteria ^.. folded . folded . _plVar . _guessUserMatrikelnummer
, all (== userMatr) userMatrs'
-> doLdap userMatr >>= maybe (go True) (return . Just . Right)
| otherwise
From 58ae9dddbc994f17cc52cc0940d996dedf583ba5 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Fri, 14 Aug 2020 15:53:27 +0200
Subject: [PATCH 18/31] feat(guess-user): variant of guessUser
---
src/Handler/Utils/Users.hs | 57 +++++++++++++++++++++----------------
src/Model/Types/Security.hs | 1 +
2 files changed, 33 insertions(+), 25 deletions(-)
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index a79e3b4fe..251bce187 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -123,8 +123,6 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
-> return Nothing
--- TODO replace guessUser with guessUserTmp when finished
--- TODO PredDNF GuessUserInfo instead of Set GuessUserInfo (work in progress)
guessUserTmp :: PredDNF GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))
guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) = $cachedHereBinary criteria $ go False
where
@@ -133,34 +131,50 @@ guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteri
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'
GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName'
- mNeg PLVariable{} = id
- mNeg PLNegated{} = E.not_
-
go didLdap = do
let retrieveUsers = E.select . E.from $ \user -> do
- E.where_ . E.or $ map (E.and . map (\c -> mNeg c $ toSql user $ plVar c)) criteria
+ E.where_ . E.or $ map (E.and . map (toSql user)) criteria
return user
users <- retrieveUsers
let users' = sortBy (flip closeness) users
- -- TODO account for PLNegated
+ -- TODO enhance
matchesMatriculation :: Entity User -> Maybe Bool
- matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> any ((== userMatr) . Just) $ criteria ^.. folded . folded . _plVar . _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)
- -- TODO account for PLNegated below
- , (criteria ^.. folded . folded . _plVar . _guessUserSurname) <&> \surn -> comparing (view $ _entityVal . _userSurname . to (`matchesName` surn))
- , (criteria ^.. folded . folded . _plVar . _guessUserFirstName) <&> \firstn -> comparing (view $ _entityVal . _userFirstName . to (`matchesName` firstn))
- , (criteria ^.. folded . folded . _plVar . _guessUserDisplayName) <&> \dispn -> comparing (view $ _entityVal . _userDisplayName . to (`matchesName` dispn))
- ]
+ closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
+ let
+ comp True userField guess = (term ^.. folded . _PLVariable . guess) <&> \name ->
+ compare ( ul ^. _entityVal . userField . to (`matchesName` name))
+ ( ur ^. _entityVal . userField . to (`matchesName` name))
+ comp False userField guess = (term ^.. folded . _PLNegated . guess) <&> \name ->
+ compare (Down $ ul ^. _entityVal . userField . to (`matchesName` name))
+ (Down $ ur ^. _entityVal . userField . to (`matchesName` name))
+ in mconcat $ concat
+ [ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur)
+ , comp True _userSurname _guessUserSurname
+ , comp False _userSurname _guessUserSurname
+ , comp True _userFirstName _guessUserFirstName
+ , comp False _userFirstName _guessUserFirstName
+ , comp True _userDisplayName _guessUserDisplayName
+ , comp False _userDisplayName _guessUserDisplayName
+ ]
+
+ 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
@@ -168,13 +182,6 @@ guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteri
ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
for ldapData $ upsertCampusUser UpsertCampusUser
- let
- aux [] = []
- aux [x] = [x]
- aux (x:x':xs)
- | EQ <- x `closeness` x' = x : aux (x':xs)
- | otherwise = [x]
-
if
| x : [] <- users'
, fromMaybe False (matchesMatriculation x) || didLdap
@@ -183,11 +190,11 @@ guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteri
, fromMaybe False (matchesMatriculation x) || didLdap
, GT <- x `closeness` x'
-> return $ Just $ Right x
- | xs@(x:_:_) <- aux users'
+ | xs@(x:_:_) <- takeClosest users'
, fromMaybe False (matchesMatriculation x) || didLdap
-> return $ Just $ Left $ NonEmpty.fromList xs
| not didLdap
- , userMatr : userMatrs' <- criteria ^.. folded . folded . _plVar . _guessUserMatrikelnummer
+ , userMatr : userMatrs' <- criteria ^.. folded . folded . _PLVariable . _guessUserMatrikelnummer
, all (== userMatr) userMatrs'
-> doLdap userMatr >>= maybe (go True) (return . Just . Right)
| otherwise
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 00723ec41..202eff51b 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
From ca96518e0eb348b91964d21680b1e8e8d3600fa3 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Fri, 14 Aug 2020 18:16:05 +0200
Subject: [PATCH 19/31] feat(guess-user): replace guessUser and usages
---
messages/uniworx/de-de-formal.msg | 1 +
messages/uniworx/en-eu.msg | 1 +
src/Handler/Exam/Users.hs | 6 ++-
src/Handler/ExternalExam/Correct.hs | 49 +++++++++++++--------
src/Handler/Utils/ExternalExam/Users.hs | 14 +++---
src/Handler/Utils/Users.hs | 58 +------------------------
6 files changed, 48 insertions(+), 81 deletions(-)
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
From 4154a395f44edb059225caa090bd3ba95a1451c2 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Fri, 14 Aug 2020 19:03:57 +0200
Subject: [PATCH 20/31] feat(guess-user): add option to limit query
---
src/Handler/Exam/Users.hs | 2 +-
src/Handler/ExternalExam/Correct.hs | 20 +-------------------
src/Handler/Utils/ExternalExam/Users.hs | 2 +-
src/Handler/Utils/Users.hs | 10 ++++++++--
4 files changed, 11 insertions(+), 23 deletions(-)
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index b64f9bc32..dc0d891f1 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -979,7 +979,7 @@ postEUsersR tid ssh csh examn = do
, GuessUserSurname <$> csvEUserSurname
, GuessUserFirstName <$> csvEUserFirstName
]
- guess <- 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
diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs
index 05eba38b4..be769d3ab 100644
--- a/src/Handler/ExternalExam/Correct.hs
+++ b/src/Handler/ExternalExam/Correct.hs
@@ -81,25 +81,7 @@ postEECorrectR tid ssh coursen examn = do
, 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
+ in lift (guessUser pdnf $ Just $ maxCountUserMatches+1) >>= return . maybe [] (either NonEmpty.toList pure)
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 7b0bdac49..6df611fe7 100644
--- a/src/Handler/Utils/ExternalExam/Users.hs
+++ b/src/Handler/Utils/ExternalExam/Users.hs
@@ -498,7 +498,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
, 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 527535189..b17fc5f36 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -14,6 +14,7 @@ import Auth.LDAP (campusUserMatr')
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
@@ -69,8 +70,12 @@ matchesName (repack -> haystack) (repack -> needle)
]
-guessUser :: PredDNF GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))
-guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> 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
@@ -86,6 +91,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
go didLdap = do
let retrieveUsers = E.select . E.from $ \user -> do
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
From ad4ae713c8c87c13616582389fda05a6dba8d962 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Sat, 15 Aug 2020 16:37:13 +0200
Subject: [PATCH 21/31] fix(guess-user): fix ldap-lookup condition and refactor
---
src/Handler/Utils/Users.hs | 51 ++++++++++++++++++++++++++------------
1 file changed, 35 insertions(+), 16 deletions(-)
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index b17fc5f36..681b3099e 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -96,7 +96,6 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
users <- retrieveUsers
let users' = sortBy (flip closeness) users
- -- TODO enhance
matchesMatriculation :: Entity User -> Maybe Bool
matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr ->
any (\p -> all ((== userMatr) . Just) (p ^.. folded . _PLVariable . _guessUserMatrikelnummer)
@@ -106,21 +105,23 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
closeness :: Entity User -> Entity User -> Ordering
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 ^. _entityVal . userField . to (`matchesName` name))
- ( ur ^. _entityVal . userField . to (`matchesName` name))
+ compare ( ul ^. userField `matches` name)
+ ( ur ^. userField `matches` name)
comp False userField guess = (term ^.. folded . _PLNegated . guess) <&> \name ->
- compare (Down $ ul ^. _entityVal . userField . to (`matchesName` name))
- (Down $ ur ^. _entityVal . userField . to (`matchesName` name))
- in mconcat $ concat
+ compare (Down $ ul ^. userField `matches` name)
+ (Down $ ur ^. userField `matches` name)
+ in mconcat $ concat $
[ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur)
- , comp True _userSurname _guessUserSurname
- , comp False _userSurname _guessUserSurname
- , comp True _userFirstName _guessUserFirstName
- , comp False _userFirstName _guessUserFirstName
- , comp True _userDisplayName _guessUserDisplayName
- , comp False _userDisplayName _guessUserDisplayName
- ]
+ ] <>
+ [ comp b userField guess
+ | (userField,guess) <- [(_userSurname , _guessUserSurname)
+ ,(_userFirstName , _guessUserFirstName)
+ ,(_userDisplayName, _guessUserDisplayName)
+ ]
+ , b <- [True,False]
+ ]
takeClosest [] = []
takeClosest [x] = [x]
@@ -134,6 +135,25 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
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 : [] <- users'
, fromMaybe False (matchesMatriculation x) || didLdap
@@ -146,8 +166,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
, fromMaybe False (matchesMatriculation x) || didLdap
-> return $ Just $ Left $ NonEmpty.fromList xs
| not didLdap
- , userMatr : userMatrs' <- criteria ^.. folded . folded . _PLVariable . _guessUserMatrikelnummer
- , all (== userMatr) userMatrs'
- -> doLdap userMatr >>= maybe (go True) (return . Just . Right)
+ , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
+ -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
| otherwise
-> return Nothing
From a1b03e819fc41da7ca83be8d27955a29a4e73904 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Sat, 15 Aug 2020 18:20:52 +0200
Subject: [PATCH 22/31] fix: typo
---
src/Foundation/Navigation.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index d4b3a1030..f1e8281c1 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -2176,7 +2176,7 @@ pageActions (EExamR tid ssh coursen examn EEGradesR) = return
, navChildren = []
}
]
-pageActions (EExamR tis ssh coursen examn EECorrectR) = return
+pageActions (EExamR tid ssh coursen examn EECorrectR) = return
[ NavPageActionPrimary
{ navLink = NavLink
{ navLabel = MsgMenuExternalExamGrades
From 662943b256e013c02317181f9a30f6b2f7bd606a Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Sat, 15 Aug 2020 19:03:12 +0200
Subject: [PATCH 23/31] fix: hlint
---
src/Handler/ExternalExam/Correct.hs | 2 +-
src/Handler/Utils/ExternalExam/Users.hs | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs
index be769d3ab..b3ff402c8 100644
--- a/src/Handler/ExternalExam/Correct.hs
+++ b/src/Handler/ExternalExam/Correct.hs
@@ -105,7 +105,7 @@ postEECorrectR tid ssh coursen examn = do
mOld = externalExamResultResult . entityVal <$> mOldResult
in if
| ciqGrade' /= mOld -> do
- let resultTime = maybe now id externalExamDefaultTime -- TODO add option to override default?
+ let resultTime = fromMaybe now externalExamDefaultTime
newResult <- upsert ExternalExamResult
{ externalExamResultExam = eeId
, externalExamResultUser = uid
diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs
index 3c352130d..6c2243cf0 100644
--- a/src/Handler/Utils/ExternalExam/Users.hs
+++ b/src/Handler/Utils/ExternalExam/Users.hs
@@ -492,7 +492,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
guessUser' :: ExternalExamUserTableCsv -> DB (Either (NonEmpty (Entity User)) (Entity User))
guessUser' ExternalExamUserTableCsv{..} = do
- let criteria = PredDNF $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes $
+ let criteria = PredDNF $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
, GuessUserDisplayName <$> csvEUserName
, GuessUserSurname <$> csvEUserSurname
From 58c933c62466aae823b7c61a2e80f9150a41fae8 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Sat, 15 Aug 2020 19:16:14 +0200
Subject: [PATCH 24/31] fix: hlint
---
src/Handler/ExternalExam/Correct.hs | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs
index b3ff402c8..4febbc936 100644
--- a/src/Handler/ExternalExam/Correct.hs
+++ b/src/Handler/ExternalExam/Correct.hs
@@ -75,13 +75,13 @@ postEECorrectR tid ssh coursen examn = do
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) <$>
+ 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 $ Just $ maxCountUserMatches+1) >>= return . maybe [] (either NonEmpty.toList pure)
+ in (maybe [] (either NonEmpty.toList pure)) <$> lift (guessUser pdnf $ Just $ maxCountUserMatches+1)
if
| is _Nothing ciqResults, is _Nothing ciqGrade -> do
From 7e14fef5c57acf436669a7cbe637d0d019810031 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Mon, 17 Aug 2020 10:48:46 +0200
Subject: [PATCH 25/31] fix: hlint
---
src/Handler/Exam/Users.hs | 2 +-
src/Handler/ExternalExam/Correct.hs | 2 +-
src/Handler/Utils/Users.hs | 2 +-
3 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index f93cbc4e9..1912abbd0 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -973,7 +973,7 @@ postEUsersR tid ssh csh examn = do
guessUser' :: ExamUserTableCsv -> DB (Bool, UserId)
guessUser' ExamUserTableCsv{..} = do
- let criteria = PredDNF $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes $
+ let criteria = PredDNF $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
, GuessUserDisplayName <$> csvEUserName
, GuessUserSurname <$> csvEUserSurname
diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs
index 4febbc936..d91dd4590 100644
--- a/src/Handler/ExternalExam/Correct.hs
+++ b/src/Handler/ExternalExam/Correct.hs
@@ -81,7 +81,7 @@ postEECorrectR tid ssh coursen examn = do
, GuessUserSurname (ident :: UserSurname)
, GuessUserFirstName (ident :: UserFirstName)
]
- in (maybe [] (either NonEmpty.toList pure)) <$> lift (guessUser pdnf $ Just $ maxCountUserMatches+1)
+ in maybe [] (either NonEmpty.toList pure) <$> lift (guessUser pdnf $ Just $ maxCountUserMatches+1)
if
| is _Nothing ciqResults, is _Nothing ciqGrade -> do
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index a0fac546d..7d95a2e15 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -156,7 +156,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs
if
- | x : [] <- users'
+ | [x] <- users'
, Just True == matchesMatriculation x || didLdap
-> return $ Just $ Right x
| x : x' : _ <- users'
From df18a6bea3b65a0313db84f1f51fc43a4397dfbb Mon Sep 17 00:00:00 2001
From: Sarah Vaupel
Date: Mon, 17 Aug 2020 11:08:10 +0200
Subject: [PATCH 26/31] Apply 1 suggestion(s) to 1 file(s)
---
src/Handler/Exam/Correct.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs
index 2b915a76a..2a51d2e55 100644
--- a/src/Handler/Exam/Correct.hs
+++ b/src/Handler/Exam/Correct.hs
@@ -89,7 +89,7 @@ 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 $ maxCountUserMatches+1
+ E.limit $ succ maxCountUserMatches
return user
if
From 323d423fc6d2be0220f09e702eb9a9b4ccc5c3d5 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel
Date: Mon, 17 Aug 2020 11:08:24 +0200
Subject: [PATCH 27/31] Apply 1 suggestion(s) to 1 file(s)
---
src/Handler/Exam/Users.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index 1912abbd0..9fcf76c04 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -973,7 +973,7 @@ postEUsersR tid ssh csh examn = do
guessUser' :: ExamUserTableCsv -> DB (Bool, UserId)
guessUser' ExamUserTableCsv{..} = do
- let criteria = PredDNF $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes
+ let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
, GuessUserDisplayName <$> csvEUserName
, GuessUserSurname <$> csvEUserSurname
From 6244a250ee027361a7346d89db66f7b8a4db9096 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel
Date: Mon, 17 Aug 2020 11:08:34 +0200
Subject: [PATCH 28/31] Apply 1 suggestion(s) to 1 file(s)
---
src/Handler/Utils/ExternalExam/Users.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs
index 6c2243cf0..68d6a5875 100644
--- a/src/Handler/Utils/ExternalExam/Users.hs
+++ b/src/Handler/Utils/ExternalExam/Users.hs
@@ -492,7 +492,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
guessUser' :: ExternalExamUserTableCsv -> DB (Either (NonEmpty (Entity User)) (Entity User))
guessUser' ExternalExamUserTableCsv{..} = do
- let criteria = PredDNF $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes
+ let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
, GuessUserDisplayName <$> csvEUserName
, GuessUserSurname <$> csvEUserSurname
From f2e6435a0371a9066a0def69cef7260a66f652d1 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Mon, 17 Aug 2020 11:29:48 +0200
Subject: [PATCH 29/31] chore: move Utils.Exam to Utils.Exam.Correct
---
src/Handler/Exam/Correct.hs | 2 +-
src/Handler/ExternalExam/Correct.hs | 2 +-
src/Utils/{Exam.hs => Exam/Correct.hs} | 2 +-
3 files changed, 3 insertions(+), 3 deletions(-)
rename src/Utils/{Exam.hs => Exam/Correct.hs} (99%)
diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs
index 2a51d2e55..cc373b0bd 100644
--- a/src/Handler/Exam/Correct.hs
+++ b/src/Handler/Exam/Correct.hs
@@ -14,7 +14,7 @@ import Database.Persist.Sql (transactionUndo)
import Handler.Utils
import Handler.Utils.Exam (fetchExam)
-import Utils.Exam
+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.
diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs
index d91dd4590..8e4987be4 100644
--- a/src/Handler/ExternalExam/Correct.hs
+++ b/src/Handler/ExternalExam/Correct.hs
@@ -15,7 +15,7 @@ import Handler.Utils
import Handler.Utils.ExternalExam
import Handler.Utils.Users
-import Utils.Exam
+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.
diff --git a/src/Utils/Exam.hs b/src/Utils/Exam/Correct.hs
similarity index 99%
rename from src/Utils/Exam.hs
rename to src/Utils/Exam/Correct.hs
index ea025fb1e..eec2fc30a 100644
--- a/src/Utils/Exam.hs
+++ b/src/Utils/Exam/Correct.hs
@@ -1,4 +1,4 @@
-module Utils.Exam
+module Utils.Exam.Correct
( CorrectInterfaceRequest(..)
, CorrectInterfaceResponse(..), ciResponseStatus
, CorrectInterfaceUser(..), userToResponse
From f1411853adff9ddcafef024a9cdfd875c52dc9ff Mon Sep 17 00:00:00 2001
From: Sarah Vaupel
Date: Mon, 17 Aug 2020 11:30:59 +0200
Subject: [PATCH 30/31] Apply 1 suggestion(s) to 1 file(s)
---
frontend/src/utils/exam-correct/exam-correct.js | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/frontend/src/utils/exam-correct/exam-correct.js b/frontend/src/utils/exam-correct/exam-correct.js
index 3e3310cbe..cf23c911d 100644
--- a/frontend/src/utils/exam-correct/exam-correct.js
+++ b/frontend/src/utils/exam-correct/exam-correct.js
@@ -513,7 +513,7 @@ export class ExamCorrect {
}
userElem.appendChild(list);
if (hasMore === true) {
- const moreElem = this._userInputCandidatesMore.cloneNode(true); // TODO I'm lazy
+ const moreElem = this._userInputCandidatesMore.cloneNode(true);
moreElem.removeAttribute('id');
moreElem.hidden = false;
userElem.appendChild(moreElem);
From 97b22171bfeb98480adf62e2c10ee3ea0cdfc64d Mon Sep 17 00:00:00 2001
From: Sarah Vaupel
Date: Mon, 17 Aug 2020 11:35:13 +0200
Subject: [PATCH 31/31] Apply 1 suggestion(s) to 1 file(s)
---
src/Handler/Utils/Users.hs | 1 +
1 file changed, 1 insertion(+)
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 7d95a2e15..9e55182cf 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -124,6 +124,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
, b <- [True,False]
]
+ -- Assuming the input list is sorted in descending order by closeness:
takeClosest [] = []
takeClosest [x] = [x]
takeClosest (x:x':xs)
|