fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Steffen Jost 2024-12-13 16:21:53 +01:00 committed by Sarah Vaupel
parent aaf72f7255
commit 4f524bd8d2
10 changed files with 112 additions and 255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
messages/uniworx/categories/courses/exam/exam/de-de-formal.msg
View File

@ -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
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.
ExamStaff: Hauptverantworliche:r
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
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.
ExamCorrectorAlreadyAdded: Ein Korrektor/eine Korrektorin mit dieser E-Mail ist bereits für diese Prüfung eingetragen
ExamCorrectors: Prüfer:innen
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 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

12
messages/uniworx/categories/courses/exam/exam/en-eu.msg
View File

@ -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
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.
ExamStaff: Chief examiner
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
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.
ExamCorrectorAlreadyAdded: A corrector with this email address already exists
ExamCorrectors: Examiner
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: 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

2
src/Handler/Course/Edit.hs
View File

@ -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

2
src/Handler/Course/Users.hs
View File

@ -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

2
src/Handler/Term.hs
View File

@ -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 ()

2
src/Handler/Tutorial/Edit.hs
View File

@ -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

2
src/Handler/Utils/Delete.hs
View File

@ -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 ->

318
src/Handler/Utils/Form.hs
View File

@ -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
| onlySuggested = suggestions
| otherwise = Just $ E.from return
procEmails :: (UserId -> WidgetFor UniWorX Text) -> Set (Either UserEmail UserId) -> WidgetFor UniWorX Text
procEmails f vs = Text.intercalate ", " <$> forM (Set.toList vs) (procEmail f)
fieldEnctype = UrlEncoded
fieldView theId name attrs val isReq = do
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
procEmail _ (Left email) = return $ CI.original email
procEmail f (Right uid ) = f uid
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|
$newline never
<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
mergeRes [] = pure Nothing
mergeRes vs = pure $ Just $ Set.fromList vs
-- | 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
| onlySuggested = suggestions
| 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
procEmail _ (Left email) = return $ CI.original email
procEmail f (Right uid ) = f uid
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
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
val' <- either pure (viewUid fetchUserEmail) val
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
= case Email.validate (encodeUtf8 t) of
Left notAnEmail -> return $ Left $ SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> do
splitNonEmpty = filter (not . Text.null) . map T.strip . concatMap (Text.splitOn ",")
fieldParse (splitNonEmpty -> ts) _
| 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.limit 3 -- we need a single answer only, so we optimize the query to stop at multiple answers
E.&&. uniqueCI user UserDisplayEmail) -- ensure uniqueness
E.limit 2 -- we need a single unique answer only, so no need to ask for more
return $ user E.^. UserId
case dbRes of
[uid] -> return $ Right $ Just $ E.unValue uid
[] -> return $ Left $ SomeMessage MsgUnknownEmail
_ -> return $ Left $ SomeMessage MsgAmbiguousEmail
| 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 $ Just $ E.unValue uid
[] -> return $ Left $ errMsg $ SomeMessage $ bool MsgUnknown MsgUnknownOrNotAllowed onlySuggested
_ -> return $ Left $ errMsg $ SomeMessage MsgAmbiguous
fieldParse _ _ = return $ Right Nothing
[uid] -> wrapUid $ Right $ E.unValue uid
[] -> wrapUid $ Left email
_ -> throwE $ SomeMessage MsgAmbiguousEmail
Left notAnEmail
| Text.any Char.isAlpha t -> throwE $ SomeMessage $ MsgInvalidEmail [st|#{t} (#{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 2 -- we need a single unique answer only, so no need to ask for more
return $ user E.^. UserId
let errMsg m = SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, text2message t, m]
case dbRes of
[uid] -> wrapUid $ Right $ E.unValue uid
[] -> throwE $ errMsg $ SomeMessage $ bool MsgUnknown MsgUnknownOrNotAllowed onlySuggested
_ -> throwE $ errMsg $ SomeMessage MsgAmbiguous
| otherwise -> return Nothing
uniqueCI user field | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
user' <- lookupExpr'

7
src/Handler/Utils/Memcached.hs
View File

@ -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 ()
memcachedFlushClass mkc = maybeT_ $ do
memcachedInvalidateClass :: (MonadHandler m, HandlerSite m ~ UniWorX) => MemcachedKeyClass -> m ()
memcachedInvalidateClass mkc = maybeT_ $ do
AppMemcached{..} <- MaybeT $ getsYesod appMemcached
cl <- MaybeT $ memcachedByGet mkc
hoist liftIO $ forM_ (unMemcachedKeyClassStore cl) $

8
src/Utils.hs
View File

@ -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 (Just x) _ act = act x
ifNothingM m dft = ifNothing m $ pure dft
maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if
maybePositive a | a > 0 = Just a