refactor(form): make all userField variants consistent with each other

messages/uniworx/categories/courses/exam/exam/de-de-formal.msg

@@ -64,14 +64,14 @@ ExamAutomaticGradingTip: Sollen die Gesamtleistungen der Teilnehmer:innen automa
 ExamBonus: Bonuspunkte-System
 ExamGradingMode: Bewertungsmodus
 ExamGradingModeTip: In welcher Form werden Prüfungsleistungen für diese Prüfung eingetragen?
-ExamStaff: Prüfer:innen
+ExamStaff: Hauptverantworliche:r
-ExamStaffTip: Geben Sie bitte in jedem Fall einen Namen an, der Prüfer:in/Veranstalter:in/Hochschullehrer:in eindeutig identifiziert! Sollte der Name des Prüfers/der Prüferin allein womöglich nicht eindeutig sein, so geben Sie bitte eindeutig identifizierende Zusatzinfos, wie beispielsweise den Lehrstuhl bzw. die LFE o.Ä., an.
+ExamStaffTip: Hauptverantwortliche:r Prüfer:in, Textfeld zur reinen Information der Teilnehmenden.
 ExamExamOfficeSchools: Zusätzliche Bereiche
 ExamExamOfficeSchoolsTip: Prüfungsbeauftragte von Bereichen, die Sie hier angeben, erhalten im System (zusätzlich zum primären Bereich der zugehörigen Kursart) volle Einsicht in sämtliche für diese Prüfung hinterlegten Leistungen, unabhängig von den Studiendaten der Teilnehmer:innen.
 ExamCorrectorEmail: E-Mail
-ExamCorrectors: Korrektor:innen
+ExamCorrectors: Prüfer:innen
-ExamCorrectorsTip: Hier eingetragene Korrektor:innen können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer:innen im System hinterlegen.
+ExamCorrectorsTip: Hier eingetragene Prüfer:innen können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer:innen im System hinterlegen.
-ExamCorrectorAlreadyAdded: Ein Korrektor/eine Korrektorin mit dieser E-Mail ist bereits für diese Prüfung eingetragen
+ExamCorrectorAlreadyAdded: Ein Prüfer:innen mit dieser E-Mail ist bereits für diese Prüfung eingetragen
 ExamRoom: Raum
 ExamRoomManual': Keine automatische bzw. selbstständige Zuteilung
 ExamRoomSurname': Nach Nachname
@@ -266,7 +266,7 @@ ExamAutoOccurrenceExceptionRoomTooSmall: Automatische Verteilung gescheitert. Ei
 ExamBonusInfoPoints: Zur Berechnung von Bonuspunkten werden nur jene Blätter herangezogen, deren Aktivitätszeitraum vor Start des jeweiligen Termin/Prüfung begonnen hat
 ExamUserCsvSheetName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn} Teilnehmer
 
-ExamRoomExaminerTip: Nur bereits eingetragene Korrektor:innen sind hier erlaubt
+ExamRoomExaminerTip: Nur bereits eingetragene Prüfer:innen sind hier erlaubt
 ExamRoomCapacityTip: Maximale Anzahl an Prüfungsteilnehmern für diesen Termin/Raum; leer lassen  für unbeschränkte Teilnehmeranzahl
 ExamRoomMappingRandom: Verteilung
 ExamFinishHeading: Prüfungsergebnisse sichtbar schalten

messages/uniworx/categories/courses/exam/exam/en-eu.msg

@@ -64,14 +64,14 @@ ExamAutomaticGradingTip: Should the exam achievement be automatically computed f
 ExamBonus: Bonus point system
 ExamGradingMode: Grading mode
 ExamGradingModeTip: In which format should grades for this exam be entered?
-ExamStaff: Examiner
+ExamStaff: Chief examiner
-ExamStaffTip: Please always specify a name that uniquely identifies the examiner/organiser/repsonsible university teacher! If there is a possibility that the name alone is ambiguous please also specify some additional information e.g. the professorial chair or the educational and research unit.
+ExamStaffTip: Primary responsible examiner, arbirary text field for pure informational purposes.
 ExamExamOfficeSchools: Additional departments
 ExamExamOfficeSchoolsTip: Exam offices of departments you specify here will also have full access to all results for this exam disregarding the individual participants' features of study.
 ExamCorrectorEmail: Email
-ExamCorrectors: Correctors
+ExamCorrectors: Examiner
-ExamCorrectorsTip: Correctors configured here may, after the start of the exam and until "Results visible from", enter exam part results for all exam parts and participants.
+ExamCorrectorsTip: Examiners configured here may, after the start of the exam and until "Results visible from", enter exam part results for all exam parts and participants.
-ExamCorrectorAlreadyAdded: A corrector with this email address already exists
+ExamCorrectorAlreadyAdded: An examiner with this email address already exists
 ExamRoom: Room
 ExamRoomManual': No automatic or autonomous assignment
 ExamRoomSurname': By surname
@@ -265,7 +265,7 @@ ExamAutoOccurrenceExceptionRoomTooSmall: Automatic distribution failed. A differ
 ExamBonusInfoPoints: When calculating an exam bonus only those sheets will be considered, for which the submission period started before the start of the relevant occurrence/room
 ExamUserCsvSheetName tid ssh csh examn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn} Participants
 
-ExamRoomExaminerTip: Only correctors allowed here, add beforehand
+ExamRoomExaminerTip: Only examiners allowed here, add beforehand
 ExamRoomCapacityTip: Maximum number of participants for this occurrence/room; leave empty for unlimited capacity
 ExamRoomMappingRandom: Distribution
 ExamFinishHeading: Make results visible

src/Handler/Course/Edit.hs

@@ -452,7 +452,7 @@ courseEditHandler miButtonAction mbCourseForm = do
                     sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
                     void $ upsertCourseQualifications aid cid $ cfQualis res
                     insert_ $ CourseEdit aid now cid
-                    memcachedFlushClass MemcachedKeyClassTutorialOccurrences
+                    memcachedInvalidateClass MemcachedKeyClassTutorialOccurrences
                     memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
                     addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True

src/Handler/Course/Users.hs

@@ -516,7 +516,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
           -- , ("course-user-note", error "TODO") -- TODO
           , single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
           , single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
-          , single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
+          , single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> ifNothing criterion E.true $ \shn
                      -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
                           E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
                           E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser

src/Handler/Term.hs

@@ -201,7 +201,7 @@ termEditHandler mtid template = do
                 , termActiveFor = tafFor
                 }
             lift . audit $ TransactionTermEdit tid
-          memcachedFlushClass MemcachedKeyClassTutorialOccurrences
+          memcachedInvalidateClass MemcachedKeyClassTutorialOccurrences
           addMessageI Success $ MsgTermEdited tid
           redirect TermShowR
       FormMissing      -> return ()

src/Handler/Tutorial/Edit.hs

@@ -86,7 +86,7 @@ postTEditR tid ssh csh tutn = do
     case insertRes of
       Just _  -> addMessageI Error $ MsgTutorialNameTaken tfName
       Nothing -> do
-        memcachedFlushClass MemcachedKeyClassTutorialOccurrences
+        memcachedInvalidateClass MemcachedKeyClassTutorialOccurrences
         addMessageI Success $ MsgTutorialEdited tfName
         redirect $ CourseR tid ssh csh CTutorialListR
 

src/Handler/Utils/Delete.hs

@@ -114,7 +114,7 @@ deleteR' DeleteRoute{..} = do
     True -> do
       runDBJobs $ do
         forM_ drRecords $ \k -> drDelete k $ delete k
-        memcachedFlushClass MemcachedKeyClassTutorialOccurrences
+        memcachedInvalidateClass MemcachedKeyClassTutorialOccurrences
         addMessageI Success drSuccessMessage
       redirect drSuccess
     False ->

src/Handler/Utils/Form.hs

@@ -1739,6 +1739,8 @@ multiUserInvitationField mode
           _{MsgMultiUserFieldInvitationExplanation}
         |]
 
+
+-- | Field for entering multiple users by email, matriculation or personnel number. Unknown valid emails are also accepted, e.g. for sending invitations
 multiUserField :: forall m.
                   ( MonadHandler m
                   , HandlerSite m ~ UniWorX
@@ -1746,90 +1748,21 @@ multiUserField :: forall m.
                => Bool -- ^ Only resolve suggested users?
                -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
                -> Field m (Set (Either UserEmail UserId))
-multiUserField onlySuggested suggestions = Field{..}
+multiUserField = userFieldAux procEmails wrapUid mergeRes
   where
-    lookupExpr
+    procEmails :: (UserId -> WidgetFor UniWorX Text) -> Set (Either UserEmail UserId) -> WidgetFor UniWorX Text
-      | onlySuggested = suggestions
+    procEmails f vs = Text.intercalate ", " <$> forM (Set.toList vs) (procEmail f)
-      | otherwise     = Just $ E.from return
 
-    fieldEnctype = UrlEncoded
+    procEmail _ (Left email) = return $ CI.original email
-    fieldView theId name attrs val isReq = do
+    procEmail f (Right uid ) = f uid
-      val' <- case val of
-        Left t -> return t
-        Right vs -> Text.intercalate ", " . map CI.original <$> do
-          let (emails, uids) = partitionEithers $ Set.toList vs
-          rEmails <- case lookupExpr of
-            Nothing -> return []
-            Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
-              dbRes <- liftHandler . runDB . E.select $ do
-                user <- lookupExpr'
-                E.where_ $ user E.^. UserId E.==. E.val uid
-                return $ user E.^. UserEmail
-              case dbRes of
-                [E.Value email] -> return [email]
-                _other -> return []
-          return $ emails ++ rEmails
 
-      datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
+    wrapUid (Right uid)  = return $ Just $ Right uid
+    wrapUid (Left email) = return $ Just $ Left email
 
-      [whamlet|
+    mergeRes [] = pure Nothing
-        $newline never
+    mergeRes vs = pure $ Just $ Set.fromList vs
-        <input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
-      |]
-
-      whenIsJust suggestions $ \suggestions' -> do
-        suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
-          user <- suggestions'
-          return ( E.case_
-                       [ E.when_ (unique UserDisplayEmail user)
-                         E.then_ (user E.^. UserDisplayEmail)
-                       , E.when_ (unique UserEmail user)
-                         E.then_ (user E.^. UserEmail)
-                       ]
-                       ( E.else_ $ user E.^. UserIdent)
-                   , user E.^. UserDisplayName
-                   )
-        [whamlet|
-          $newline never
-          <datalist id=#{datalistId}>
-            $forall (email, dName) <- suggestedEmails
-              <option value=#{email}>
-                #{email} (#{dName})
-        |]
-    fieldParse (all Text.null -> True) _ = return $ Right Nothing
-    fieldParse ts _ = runExceptT . fmap Just $ do
-      let ts' = concatMap (Text.splitOn ",") ts
-      emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
-      fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
-        Nothing -> return $ Left email
-        Just lookupExpr' -> do
-            dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDB . E.select $ do
-              user <- lookupExpr'
-              E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
-                   E.||. (       user E.^. UserDisplayEmail `E.ciEq` E.val email
-                           E.&&. unique UserDisplayEmail user
-                         )
-                   E.||. (       user E.^. UserEmail `E.ciEq` E.val email
-                           E.&&. unique UserEmail user
-                         )
-              return $ user E.^. UserId
-            if | Set.null dbRes
-                 -> return $ Left email
-               | [uid] <- Set.toList dbRes
-                 -> return $ Right uid
-               | otherwise
-                 -> throwE $ SomeMessage MsgAmbiguousEmail
-
-    unique field user = case lookupExpr of
-      Just lookupExpr' -> E.not_ . E.exists $ do
-        user' <- lookupExpr'
-        E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
-             E.&&. (       user' E.^. UserIdent        `E.ciEq` user E.^. field
-                     E.||. user' E.^. UserEmail        `E.ciEq` user E.^. field
-                     E.||. user' E.^. UserDisplayEmail `E.ciEq` user E.^. field
-                   )
-      Nothing -> E.true
 
+-- | Field for entering a user by email, matriculation or personnel number. Unknown valid emails are also accepted, e.g. for sending invitations
 userField :: forall m.
              ( MonadHandler m
              , HandlerSite m ~ UniWorX
@@ -1837,116 +1770,15 @@ userField :: forall m.
           => Bool -- ^ Only resolve suggested users?
           -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
           -> Field m (Either UserEmail UserId)
-userField onlySuggested suggestions = Field{..}
+userField = userFieldAux procEmail wrapUid (pure . listToMaybe)
   where
-    lookupExpr
+    procEmail _ (Left email) = return $ CI.original email
-      | onlySuggested = suggestions
+    procEmail f (Right uid ) = f uid
-      | otherwise     = Just $ E.from return
-
-    fieldEnctype = UrlEncoded
-    fieldView theId name attrs val isReq = do
-      val' <- case val of
-        Left t -> return t
-        Right v -> case v of
-          Right uid -> case lookupExpr of
-            Nothing -> return mempty
-            Just lookupExpr' -> do
-              dbRes <- liftHandler . runDB . E.select $ do
-                user <- lookupExpr'
-                E.where_ $ user E.^. UserId E.==. E.val uid
-                return $ user E.^. UserEmail
-              case dbRes of
-                [E.Value email] -> return $ CI.original email
-                _other -> return mempty
-          Left email -> return $ CI.original email
-
-      datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
-
-      [whamlet|
-        $newline never
-        <input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
-      |]
-
-      whenIsJust suggestions $ \suggestions' -> do
-        suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
-          user <- suggestions'
-          return ( E.case_
-                       [ E.when_ (unique UserDisplayEmail user)
-                         E.then_ (user E.^. UserDisplayEmail)
-                       , E.when_ (unique UserEmail user)
-                         E.then_ (user E.^. UserEmail)
-                       ]
-                       ( E.else_ $ user E.^. UserIdent)
-                   , user E.^. UserDisplayName
-                   )
-        [whamlet|
-          $newline never
-          <datalist id=#{datalistId}>
-            $forall (email, dName) <- suggestedEmails
-              <option value=#{email}>
-                #{email} (#{dName})
-        |]
-    fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _ = runExceptT . fmap Just $
-      case Email.validate (encodeUtf8 t) of
-        Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> case lookupExpr of
-          Nothing -> return $ Left email
-          Just lookupExpr' -> do
-              dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDBRead . E.select $ do
-                user <- lookupExpr'
-                E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
-                    E.||. (       user E.^. UserDisplayEmail `E.ciEq` E.val email
-                            E.&&. unique UserDisplayEmail user
-                          )
-                    E.||. (       user E.^. UserEmail `E.ciEq` E.val email
-                            E.&&. unique UserEmail user
-                          )
-                return $ user E.^. UserId
-              if  | Set.null dbRes
-                    -> return $ Left email
-                  | [uid] <- Set.toList dbRes
-                    -> return $ Right uid
-                  | otherwise
-                    -> throwE $ SomeMessage MsgAmbiguousEmail
-        Left notAnEmail
-          | Just lookupExpr' <- lookupExpr -> do           -- allow known user entry by avs-nr or corporate-id for convenience
-            dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
-              user <- lookupExpr'
-              E.where_ $  ( E.justVal t E.==. user E.^. UserCompanyPersonalNumber
-                                    E.&&. uniqueTX user UserCompanyPersonalNumber
-                          )
-                    E.||. ( E.justVal t E.==. user E.^. UserMatrikelnummer
-                                    E.&&. uniqueTX user UserMatrikelnummer
-                          )
-              E.limit 3     -- we need a single answer only, so we optimize the query to stop at multiple answers
-              return $ user E.^. UserId
-            let errMsg m = SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, text2message t, m]
-            case dbRes of
-              [uid] -> return $ Right $ E.unValue uid
-              _ | Text.any Char.isAlpha t -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
-              []    -> throwE $ errMsg $ SomeMessage $ bool MsgUnknown MsgUnknownOrNotAllowed onlySuggested
-              _     -> throwE $ errMsg $ SomeMessage MsgAmbiguous
-          | otherwise -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
-    fieldParse _ _ = return $ Right Nothing
-
-    unique field user = case lookupExpr of
-      Just lookupExpr' -> E.not_ . E.exists $ do
-        user' <- lookupExpr'
-        E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
-             E.&&. (       user' E.^. UserIdent        `E.ciEq` user E.^. field
-                     E.||. user' E.^. UserEmail        `E.ciEq` user E.^. field
-                     E.||. user' E.^. UserDisplayEmail `E.ciEq` user E.^. field
-                   )
-      Nothing -> E.true
-
-    uniqueTX user field | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
-      user' <- lookupExpr'
-      E.where_ $  user' E.^. UserId                     E.!=. user E.^. UserId
-          E.&&. ( user' E.^. UserMatrikelnummer         E.==. user E.^. field
-            E.||. user' E.^. UserCompanyPersonalNumber  E.==. user E.^. field
-          )
-    uniqueTX _ _ =  E.true
 
+    wrapUid (Right uid)  = return $ Just $ Right uid
+    wrapUid (Left email) = return $ Just $ Left email
 
+-- | Field for entering registered users only, either by email, matriculation or personnel number
 knownUserField :: forall m.
              ( MonadHandler m
              , HandlerSite m ~ UniWorX
@@ -1954,36 +1786,50 @@ knownUserField :: forall m.
           => Bool -- ^ Only resolve suggested users?
           -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
           -> Field m UserId
-knownUserField onlySuggested suggestions = Field{..}
+knownUserField = userFieldAux ($) wrapUid (pure . listToMaybe)  -- maybe throw an error on multiple results?
+  where
+    wrapUid (Right uid) = return $ Just uid
+    wrapUid (Left    _) = throwE $ SomeMessage MsgUnknownEmail
+
+userFieldAux :: forall m a b.
+             ( MonadHandler m
+             , HandlerSite m ~ UniWorX
+             )
+          => ((UserId -> WidgetFor UniWorX Text) -> a -> WidgetFor UniWorX Text)    -- ^ View result type as a text, given a function that already does this for a UserId
+          -> (Either (CI Text) UserId -> ExceptT (SomeMessage UniWorX) m (Maybe b)) -- ^ Wrap identified UserId in desired result type
+          -> ([b] -> ExceptT (SomeMessage UniWorX) m (Maybe a))                     -- ^ Merge multiple results to the overall result
+          -> Bool -- ^ Only resolve suggested users?
+          -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
+          -> Field m a
+userFieldAux viewUid wrapUid mergeRes onlySuggested suggestions = Field{..}
   where
     lookupExpr
       | onlySuggested = suggestions
       | otherwise     = Just $ E.from return
 
+    fetchUserEmail uid
+      | Just lookupExpr' <- lookupExpr
+        = do
+            dbRes <- liftHandler . runDBRead . E.select $ do
+              user <- lookupExpr'
+              E.where_ $ user E.^. UserId E.==. E.val uid
+              return $ user E.^. UserEmail
+            case dbRes of
+              [E.Value email] -> return $ CI.original email
+              _other -> return mempty
+      | otherwise = return mempty
+
     fieldEnctype = UrlEncoded
+
     fieldView theId name attrs val isReq = do
-      val' <- case val of
+      val' <- either pure (viewUid fetchUserEmail) val
-        Left t -> return t
-        Right uid -> case lookupExpr of
-            Nothing -> return mempty
-            Just lookupExpr' -> do
-              dbRes <- liftHandler . runDB . E.select $ do
-                user <- lookupExpr'
-                E.where_ $ user E.^. UserId E.==. E.val uid
-                return $ user E.^. UserEmail
-              case dbRes of
-                [E.Value email] -> return $ CI.original email
-                _other -> return mempty
-
       datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
-
       [whamlet|
         $newline never
-        <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
+        <input id="#{theId}" name="#{name}" *{attrs} type="text" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
       |]
-
       whenIsJust suggestions $ \suggestions' -> do
-        suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
+        suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDBRead . E.select $ do
           user <- suggestions'
           return ( E.case_
                        [ E.when_ (uniqueCI user UserDisplayEmail)
@@ -2002,42 +1848,48 @@ knownUserField onlySuggested suggestions = Field{..}
               <option value=#{email}>
                 #{email} (#{dName})
         |]
-    fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _
+
-      | Text.any Char.isAlpha t, Just lookupExpr' <- lookupExpr
+    splitNonEmpty = filter (not . Text.null) . map T.strip . concatMap (Text.splitOn ",")
-       = case Email.validate (encodeUtf8 t) of
+
-        Left notAnEmail -> return $ Left $ SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
+    fieldParse (splitNonEmpty -> ts) _
-        Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> do
+      | null ts   = return $ Right Nothing
+      | otherwise = runExceptT (forM ts usrParse >>= (mergeRes . catMaybes))
+
+    usrParse t = case Email.validate (encodeUtf8 t) of
+        Right (CI.mk . decodeUtf8 . Email.toByteString -> email) ->
+          ifNothing lookupExpr (wrapUid $ Left email) $ \lookupExpr' -> do
             dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
               user <- lookupExpr'
               E.where_ $    E.val email `E.ciEq` user E.^. UserIdent          -- UserIdent is unique
                     E.||.   E.val email `E.ciEq` user E.^. UserEmail          -- UserEmail is unique
+                           --     E.&&. uniqueCI user UserEmail       )       -- we could ensure that there is no confusion with UserDisplayEmail
                     E.||. ( E.val email `E.ciEq` user E.^. UserDisplayEmail
-                                    E.&&. uniqueCI user UserDisplayEmail   -- ensure uniqueness
+                                  E.&&. uniqueCI user UserDisplayEmail)       -- ensure uniqueness
-                          )
+              E.limit 2   -- we need a single unique answer only, so no need to ask for more
-              E.limit 3     -- we need a single answer only, so we optimize the query to stop at multiple answers
               return $ user E.^. UserId
             case dbRes of
-              [uid] -> return $ Right $ Just $ E.unValue uid
+              [uid] -> wrapUid $ Right $ E.unValue uid
-              []    -> return $ Left  $ SomeMessage MsgUnknownEmail
+              []    -> wrapUid $ Left email
-              _     -> return $ Left  $ SomeMessage MsgAmbiguousEmail
+              _     -> throwE $ SomeMessage MsgAmbiguousEmail
-      | Just lookupExpr' <- lookupExpr = do                    -- allow known user entry by avs-nr or corporate-id for convenience
+        Left notAnEmail
-          dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
+          | Text.any Char.isAlpha t -> throwE $ SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
-            user <- lookupExpr'
+          | Just lookupExpr' <- lookupExpr -> do                    -- allow known user entry by avs-nr or corporate-id for convenience
-            E.where_ $  ( E.justVal t E.==. user E.^. UserCompanyPersonalNumber
+              dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
-                                  E.&&. uniqueTX user UserCompanyPersonalNumber
+                user <- lookupExpr'
-                        )
+                E.where_ $  ( E.justVal t E.==. user E.^. UserCompanyPersonalNumber
-                  E.||. ( E.justVal t E.==. user E.^. UserMatrikelnummer
+                                      E.&&. uniqueTX user UserCompanyPersonalNumber
-                                  E.&&. uniqueTX user UserMatrikelnummer
+                            )
-                        )
+                      E.||. ( E.justVal t E.==. user E.^. UserMatrikelnummer
-            E.limit 3     -- we need a single answer only, so we optimize the query to stop at multiple answers
+                                      E.&&. uniqueTX user UserMatrikelnummer
-            return $ user E.^. UserId
+                            )
-          let errMsg m = SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, text2message t, m]
+                E.limit 2     -- we need a single unique answer only, so no need to ask for more
-          case dbRes of
+                return $ user E.^. UserId
-            [uid] -> return $ Right $ Just $ E.unValue uid
+              let errMsg m = SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, text2message t, m]
-            []    -> return $ Left  $ errMsg $ SomeMessage $ bool MsgUnknown MsgUnknownOrNotAllowed onlySuggested
+              case dbRes of
-            _     -> return $ Left  $ errMsg $ SomeMessage MsgAmbiguous
+                [uid] -> wrapUid $ Right $ E.unValue uid
-
+                []    -> throwE $ errMsg $ SomeMessage $ bool MsgUnknown MsgUnknownOrNotAllowed onlySuggested
-    fieldParse _ _ = return $ Right Nothing
+                _     -> throwE $ errMsg $ SomeMessage MsgAmbiguous
+          | otherwise -> return     Nothing
 
     uniqueCI user field | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
       user' <- lookupExpr'

src/Handler/Utils/Memcached.hs

@@ -7,7 +7,7 @@
 module Handler.Utils.Memcached
   ( memcachedAvailable
   , memcached, memcachedBy
-  , memcachedByClass, memcachedFlushClass, MemcachedKeyClass(..)
+  , memcachedByClass, memcachedInvalidateClass, MemcachedKeyClass(..)
   , memcachedHere, memcachedByHere
   , memcachedSet, memcachedGet
   , memcachedInvalidate, memcachedByInvalidate, memcachedFlushAll
@@ -348,6 +348,7 @@ memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet
 
 data MemcachedKeyClass
     = MemcachedKeyClassTutorialOccurrences
+    | MemcachedKeyClassExamOccurrences
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, NFData)
   deriving anyclass (Hashable, Binary, Universe, Finite)
 
@@ -373,8 +374,8 @@ memcachedByClass mkc mExp k = memcachedWith (memcachedByGet k, setAndAddClass)
         -- memcachedBySet Nothing mkc $ cl <> MemcachedKeyClassStore $ Set.singleton vKey
       return v
 
-memcachedFlushClass :: (MonadHandler m, HandlerSite m ~ UniWorX) => MemcachedKeyClass -> m ()
+memcachedInvalidateClass :: (MonadHandler m, HandlerSite m ~ UniWorX) => MemcachedKeyClass -> m ()
-memcachedFlushClass mkc = maybeT_ $ do
+memcachedInvalidateClass mkc = maybeT_ $ do
   AppMemcached{..} <- MaybeT $ getsYesod appMemcached
   cl <- MaybeT $ memcachedByGet mkc
   hoist liftIO $ forM_ (unMemcachedKeyClassStore cl) $

src/Utils.hs

@@ -971,14 +971,18 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
 whenIsJust Nothing  _ = return ()
 
+-- | Often a more convenient argument order as compared to `maybe`
+ifNothing :: Maybe a -> b -> (a -> b) -> b
+ifNothing Nothing dft _  = dft
+ifNothing (Just x) _ act = act x
+
 -- | Often a more convenient argument order as compared to the not quite identical `maybeM`.
 --
 -- @
 --    ifNothingM m d a = maybe (return d) a m
 -- @
 ifNothingM :: Applicative m => Maybe a -> b -> (a -> m b) -> m b
-ifNothingM Nothing dft _  = pure dft
+ifNothingM m dft = ifNothing m $ pure dft
-ifNothingM (Just x) _ act = act x
 
 maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if
 maybePositive a | a > 0     = Just a