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

refactor(form): knownUserField not working as intended (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2024-12-05 18:17:34 +01:00
parent a454ac9d32
commit d6de55a886
7 changed files with 84 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/misc/de-de-formal.msg
View File

@ -32,4 +32,6 @@ PaginationError: Paginierung Parameter dürfen nicht negativ sein
NullDeletes: Zum Löschen NULL eingeben. NullDeletes: Zum Löschen NULL eingeben.
SortPriority: Sortierungspriorität SortPriority: Sortierungspriorität
NoProblem: Keine Probleme gefunden NoProblem: Keine Probleme gefunden
Unknown: ist unbekannt
Ambiguous: ist uneindeutig

4
messages/uniworx/misc/en-eu.msg
View File

@ -32,4 +32,6 @@ PaginationError: Pagination parameter must not be negative
NullDeletes: Enter NULL to delete. NullDeletes: Enter NULL to delete.
SortPriority: Sort order priority SortPriority: Sort order priority
NoProblem: No Probleme found NoProblem: No Probleme found
Unknown: is unknown
Ambiguous: is ambiguous

1
messages/uniworx/utils/utils/de-de-formal.msg
View File

@ -81,6 +81,7 @@ MultiUserFieldExplanationAnyUser: Dieses Eingabefeld sucht in den Adressen aller
MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden können, wird eine Einladung per E-Mail versandt. MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden können, wird eine Einladung per E-Mail versandt.
MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt. MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt.
AmbiguousEmail: E-Mail-Adresse nicht eindeutig AmbiguousEmail: E-Mail-Adresse nicht eindeutig
UnknownEmail: E-Mail-Adresse konnte keinem bekannten Benutzer zugeordnet werden
InvalidEmailAddress: E-Mail-Adresse ist ungültig InvalidEmailAddress: E-Mail-Adresse ist ungültig
InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
MailFileAttachment: Dateianhang MailFileAttachment: Dateianhang

1
messages/uniworx/utils/utils/en-eu.msg
View File

@ -81,6 +81,7 @@ MultiUserFieldExplanationAnyUser: This input searches through the addresses of a
MultiUserFieldInvitationExplanation: For addresses, which are not found in this way, an invitation will be sent via email. MultiUserFieldInvitationExplanation: For addresses, which are not found in this way, an invitation will be sent via email.
MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here. MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here.
AmbiguousEmail: Email address is ambiguous AmbiguousEmail: Email address is ambiguous
UnknownEmail: Email adresse is not associated with any registred user
InvalidEmailAddress: Email address is invalid InvalidEmailAddress: Email address is invalid
InvalidEmailAddressWith e: Email asdress #{show e} is invalid InvalidEmailAddressWith e: Email asdress #{show e} is invalid
MailFileAttachment: Attached file MailFileAttachment: Attached file

45
src/Handler/PrintCenter.hs
View File

@ -37,12 +37,12 @@ import Handler.Utils
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Jobs.Queue import Jobs.Queue
import qualified Control.Monad.State.Class as State
data LRQF = LRQF data LRQF = LRQF
{ lrqfLetter :: Text { lrqfLetter :: Text
, lrqfUser :: Either UserEmail UserId , lrqfUser :: UserId
, lrqfSuper :: Maybe (Either UserEmail UserId) , lrqfSuper :: Maybe UserId
, lrqfQuali :: Entity Qualification , lrqfQuali :: Entity Qualification
, lrqfIdent :: LmsIdent , lrqfIdent :: LmsIdent
, lrqfPin :: Text , lrqfPin :: Text
@ -54,28 +54,29 @@ makeRenewalForm :: Maybe LRQF -> Form LRQF
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualification $ \html -> do makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualification $ \html -> do
-- now_day <- utctDay <$> liftIO getCurrentTime -- now_day <- utctDay <$> liftIO getCurrentTime
flip (renderAForm FormStandard) html $ LRQF flip (renderAForm FormStandard) html $ LRQF
<$> areq textField (fslI MsgPrintLetterType) (lrqfLetter <$> tmpl) <$> areq textField (fslI MsgPrintLetterType) (lrqfLetter <$> tmpl)
<*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) <*> areq (knownUserField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
<*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl) <*> aopt (knownUserField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
<*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl) <*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
<*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl) <*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
<*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl) <*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl)
<*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) <*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl)
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)
(fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl) (fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl)
where where
lmsField = convertField LmsIdent getLmsIdent textField lmsField = convertField LmsIdent getLmsIdent textField
validateLetterRenewQualification :: FormValidator LRQF Handler () validateLetterRenewQualification :: FormValidator LRQF Handler ()
validateLetterRenewQualification = -- do validateLetterRenewQualification = do
-- LRQF{..} <- State.get LRQF{..} <- State.get
liftHandler $ addMessage Warning $ text2Html $ "Validate called:" <> tshow lrqfUser -- DEBUG
return () return ()
lrqf2letter :: LRQF -> DB (Entity User, SomeLetter) lrqf2letter :: LRQF -> DB (Entity User, SomeLetter)
lrqf2letter LRQF{..} lrqf2letter LRQF{..}
| lrqfLetter == "r" = do | lrqfLetter == "r" = do
usr <- getUser lrqfUser usr <- getEntity404 lrqfUser
rcvr <- mapM getUser lrqfSuper rcvr <- mapM getEntity404 lrqfSuper
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let letter = LetterRenewQualification let letter = LetterRenewQualification
{ lmsLogin = lrqfIdent { lmsLogin = lrqfIdent
@ -95,8 +96,8 @@ lrqf2letter LRQF{..}
} }
return (fromMaybe usr rcvr, SomeLetter letter) return (fromMaybe usr rcvr, SomeLetter letter)
| lrqfLetter == "e" || lrqfLetter == "E" = do | lrqfLetter == "e" || lrqfLetter == "E" = do
rcvr <- mapM getUser lrqfSuper rcvr <- mapM getEntity404 lrqfSuper
usr <- getUser lrqfUser usr <- getEntity404 lrqfUser
usrShrt <- encrypt $ entityKey usr usrShrt <- encrypt $ entityKey usr
usrUuid <- encrypt $ entityKey usr usrUuid <- encrypt $ entityKey usr
urender <- liftHandler getUrlRender urender <- liftHandler getUrlRender
@ -114,10 +115,10 @@ lrqf2letter LRQF{..}
} }
return (fromMaybe usr rcvr, SomeLetter letter) return (fromMaybe usr rcvr, SomeLetter letter)
| otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only." | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only."
where -- where
getUser :: Either UserEmail UserId -> DB (Entity User) -- getUser :: Either UserEmail UserId -> DB (Entity User)
getUser (Right uid) = getEntity404 uid -- getUser (Right uid) = getEntity404 uid
getUser (Left mail) = getBy404 $ UniqueEmail mail -- getUser (Left mail) = getBy404 $ UniqueEmail mail
data PJTableAction = PJActAcknowledge | PJActReprint data PJTableAction = PJActAcknowledge | PJActReprint
@ -341,7 +342,7 @@ postPrintSendR = do
uid = usr ^. _entityKey uid = usr ^. _entityKey
mkLetter qual = LRQF mkLetter qual = LRQF
{ lrqfLetter = "r" { lrqfLetter = "r"
, lrqfUser = Right uid , lrqfUser = uid
, lrqfSuper = Nothing , lrqfSuper = Nothing
, lrqfQuali = qual , lrqfQuali = qual
, lrqfIdent = LmsIdent "stuvwxyz" , lrqfIdent = LmsIdent "stuvwxyz"

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

@ -1952,17 +1952,18 @@ knownUserField onlySuggested suggestions = Field{..}
[whamlet| [whamlet|
$newline never $newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}> <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|] |]
whenIsJust suggestions $ \suggestions' -> do 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 . runDB . E.select $ do
user <- suggestions' user <- suggestions'
return ( E.case_ return ( E.case_
[ E.when_ (unique user $ Left UserDisplayEmail) [ E.when_ (uniqueCI user UserDisplayEmail)
E.then_ (user E.^. UserDisplayEmail) E.then_ ( user E.^. UserDisplayEmail)
, E.when_ (unique user $ Left UserEmail) , E.when_ (uniqueCI user UserEmail)
E.then_ (user E.^. UserEmail) E.then_ (
user E.^. UserEmail)
] ]
( E.else_ $ user E.^. UserIdent) ( E.else_ $ user E.^. UserIdent)
, user E.^. UserDisplayName , user E.^. UserDisplayName
@ -1975,52 +1976,56 @@ knownUserField onlySuggested suggestions = Field{..}
#{email} (#{dName}) #{email} (#{dName})
|] |]
fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _ fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _
| Just lookupExpr' <- lookupExpr = do | Just lookupExpr' <- lookupExpr = case Email.validate (encodeUtf8 t) of
let cit = CI.mk t Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> do
dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
user <- lookupExpr' user <- lookupExpr'
E.where_ $ user E.^. UserIdent `E.ciEq` E.val cit E.where_ $ E.val email E.==. user E.^. UserIdent -- UserIdent is unique
E.||. ( user E.^. UserDisplayEmail E.==. E.val cit E.||. E.val email E.==. user E.^. UserEmail -- UserEmail is unique
E.&&. unique user (Left UserDisplayEmail) E.||. ( E.val email E.==. user E.^. UserDisplayEmail
) E.&&. uniqueCI user UserDisplayEmail -- ensure uniqueness
E.||. ( user E.^. UserEmail E.==. E.val cit )
E.&&. unique user (Left UserEmail) E.limit 3 -- we need a single answer only, so we optimize the query to stop at multiple answers
) return $ user E.^. UserId
E.||. ( user E.^. UserMatrikelnummer E.==. E.justVal t case dbRes of
E.&&. unique user (Right UserMatrikelnummer) [uid] -> return $ Right $ Just $ E.unValue uid
) [] -> return $ Left $ SomeMessage MsgUnknownEmail
E.||. ( user E.^. UserCompanyPersonalNumber E.==. E.justVal t _ -> return $ Left $ SomeMessage MsgAmbiguousEmail
E.&&. unique user (Right UserCompanyPersonalNumber)
) Left _notAnEmail -> do -- allow known user entry by avs-nr or corporate-id for convenience
E.limit 3 -- just to optimize the query dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
return $ user E.^. UserId user <- lookupExpr'
case dbRes of E.where_ $ ( E.justVal t E.==. user E.^. UserCompanyPersonalNumber
[uid] -> return $ Right $ Just $ E.unValue uid E.&&. uniqueTX user UserCompanyPersonalNumber
[] -> return $ Left $ SomeMessage $ MsgInvalidEmail t -- TODO: placeholder only, better error message )
_ -> return $ Left $ SomeMessage MsgAmbiguousEmail -- TODO: placeholder only, better error message 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
case dbRes of
[uid] -> return $ Right $ Just $ E.unValue uid
[] -> return $ Left $ SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, SomeMessage MsgUnknown]
_ -> return $ Left $ SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, SomeMessage MsgAmbiguous]
-- email <- either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . CI.mk . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
fieldParse _ _ = return $ Right Nothing fieldParse _ _ = return $ Right Nothing
unique user (Left field) | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do uniqueCI user field | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
user' <- lookupExpr' user' <- lookupExpr'
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
E.&&. ( user' E.^. UserIdent E.==. user E.^. field E.&&. ( user' E.^. UserIdent E.==. user E.^. field
E.||. user' E.^. UserEmail E.==. user E.^. field E.||. user' E.^. UserEmail E.==. user E.^. field
E.||. user' E.^. UserDisplayEmail E.==. user E.^. field E.||. user' E.^. UserDisplayEmail E.==. user E.^. field
E.||. E.str2citext (user' E.^. UserMatrikelnummer) E.==. user E.^. field )
E.||. E.str2citext (user' E.^. UserCompanyPersonalNumber) E.==. user E.^. field uniqueCI _ _ = E.true
)
unique user (Right field) | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do uniqueTX user field | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
user' <- lookupExpr' user' <- lookupExpr'
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
E.&&. ( user' E.^. UserIdent E.==. E.str2citext (user E.^. field) E.&&. ( user' E.^. UserMatrikelnummer E.==. user E.^. field
E.||. user' E.^. UserEmail E.==. E.str2citext (user E.^. field) E.||. user' E.^. UserCompanyPersonalNumber E.==. user E.^. field
E.||. user' E.^. UserDisplayEmail E.==. E.str2citext (user E.^. field) )
E.||. user' E.^. UserMatrikelnummer E.==. user E.^. field uniqueTX _ _ = E.true
E.||. user' E.^. UserCompanyPersonalNumber E.==. user E.^. field
)
unique _ _ = E.true
examResultField :: forall m res. examResultField :: forall m res.

2
src/Model/Migration/Definitions.hs
View File

@ -81,6 +81,8 @@ migrateManual = do
, ("user_lower_display_email", "CREATE INDEX user_lower_display_email ON \"user\" (lower(display_email))" ) , ("user_lower_display_email", "CREATE INDEX user_lower_display_email ON \"user\" (lower(display_email))" )
, ("user_lower_email", "CREATE INDEX user_lower_email ON \"user\" (lower(email))" ) , ("user_lower_email", "CREATE INDEX user_lower_email ON \"user\" (lower(email))" )
, ("user_lower_ident", "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))" ) , ("user_lower_ident", "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))" )
, ("user_company_personal_number", "CREATE INDEX user_company_personal_number ON \"user\" (company_personal_number))" )
, ("user_matrikelnummer", "CREATE INDEX user_matrikelnummer ON \"user\" (matrikelnummer))" )
, ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" ) , ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" )
, ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" ) , ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" )
, ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" ) , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" )