refactor(form): knownUserField not working as intended (WIP)
This commit is contained in:
parent
a454ac9d32
commit
d6de55a886
@ -32,4 +32,6 @@ PaginationError: Paginierung Parameter dürfen nicht negativ sein
|
||||
|
||||
NullDeletes: Zum Löschen NULL eingeben.
|
||||
SortPriority: Sortierungspriorität
|
||||
NoProblem: Keine Probleme gefunden
|
||||
NoProblem: Keine Probleme gefunden
|
||||
Unknown: ist unbekannt
|
||||
Ambiguous: ist uneindeutig
|
||||
@ -32,4 +32,6 @@ PaginationError: Pagination parameter must not be negative
|
||||
|
||||
NullDeletes: Enter NULL to delete.
|
||||
SortPriority: Sort order priority
|
||||
NoProblem: No Probleme found
|
||||
NoProblem: No Probleme found
|
||||
Unknown: is unknown
|
||||
Ambiguous: is ambiguous
|
||||
@ -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.
|
||||
MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt.
|
||||
AmbiguousEmail: E-Mail-Adresse nicht eindeutig
|
||||
UnknownEmail: E-Mail-Adresse konnte keinem bekannten Benutzer zugeordnet werden
|
||||
InvalidEmailAddress: E-Mail-Adresse ist ungültig
|
||||
InvalidEmailAddressWith e@Text: E-Mail-Adresse #{show e} ist ungültig
|
||||
MailFileAttachment: Dateianhang
|
||||
|
||||
@ -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.
|
||||
MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here.
|
||||
AmbiguousEmail: Email address is ambiguous
|
||||
UnknownEmail: Email adresse is not associated with any registred user
|
||||
InvalidEmailAddress: Email address is invalid
|
||||
InvalidEmailAddressWith e: Email asdress #{show e} is invalid
|
||||
MailFileAttachment: Attached file
|
||||
|
||||
@ -37,12 +37,12 @@ import Handler.Utils
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
data LRQF = LRQF
|
||||
{ lrqfLetter :: Text
|
||||
, lrqfUser :: Either UserEmail UserId
|
||||
, lrqfSuper :: Maybe (Either UserEmail UserId)
|
||||
, lrqfUser :: UserId
|
||||
, lrqfSuper :: Maybe UserId
|
||||
, lrqfQuali :: Entity Qualification
|
||||
, lrqfIdent :: LmsIdent
|
||||
, lrqfPin :: Text
|
||||
@ -54,28 +54,29 @@ makeRenewalForm :: Maybe LRQF -> Form LRQF
|
||||
makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRenewQualification $ \html -> do
|
||||
-- now_day <- utctDay <$> liftIO getCurrentTime
|
||||
flip (renderAForm FormStandard) html $ LRQF
|
||||
<$> areq textField (fslI MsgPrintLetterType) (lrqfLetter <$> tmpl)
|
||||
<*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
|
||||
<*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
|
||||
<*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
|
||||
<*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
|
||||
<*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl)
|
||||
<*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl)
|
||||
<$> areq textField (fslI MsgPrintLetterType) (lrqfLetter <$> tmpl)
|
||||
<*> areq (knownUserField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
|
||||
<*> aopt (knownUserField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
|
||||
<*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
|
||||
<*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
|
||||
<*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl)
|
||||
<*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl)
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)
|
||||
(fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl)
|
||||
(fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl)
|
||||
where
|
||||
lmsField = convertField LmsIdent getLmsIdent textField
|
||||
|
||||
validateLetterRenewQualification :: FormValidator LRQF Handler ()
|
||||
validateLetterRenewQualification = -- do
|
||||
-- LRQF{..} <- State.get
|
||||
validateLetterRenewQualification = do
|
||||
LRQF{..} <- State.get
|
||||
liftHandler $ addMessage Warning $ text2Html $ "Validate called:" <> tshow lrqfUser -- DEBUG
|
||||
return ()
|
||||
|
||||
lrqf2letter :: LRQF -> DB (Entity User, SomeLetter)
|
||||
lrqf2letter LRQF{..}
|
||||
| lrqfLetter == "r" = do
|
||||
usr <- getUser lrqfUser
|
||||
rcvr <- mapM getUser lrqfSuper
|
||||
usr <- getEntity404 lrqfUser
|
||||
rcvr <- mapM getEntity404 lrqfSuper
|
||||
now <- liftIO getCurrentTime
|
||||
let letter = LetterRenewQualification
|
||||
{ lmsLogin = lrqfIdent
|
||||
@ -95,8 +96,8 @@ lrqf2letter LRQF{..}
|
||||
}
|
||||
return (fromMaybe usr rcvr, SomeLetter letter)
|
||||
| lrqfLetter == "e" || lrqfLetter == "E" = do
|
||||
rcvr <- mapM getUser lrqfSuper
|
||||
usr <- getUser lrqfUser
|
||||
rcvr <- mapM getEntity404 lrqfSuper
|
||||
usr <- getEntity404 lrqfUser
|
||||
usrShrt <- encrypt $ entityKey usr
|
||||
usrUuid <- encrypt $ entityKey usr
|
||||
urender <- liftHandler getUrlRender
|
||||
@ -114,10 +115,10 @@ lrqf2letter LRQF{..}
|
||||
}
|
||||
return (fromMaybe usr rcvr, SomeLetter letter)
|
||||
| otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only."
|
||||
where
|
||||
getUser :: Either UserEmail UserId -> DB (Entity User)
|
||||
getUser (Right uid) = getEntity404 uid
|
||||
getUser (Left mail) = getBy404 $ UniqueEmail mail
|
||||
-- where
|
||||
-- getUser :: Either UserEmail UserId -> DB (Entity User)
|
||||
-- getUser (Right uid) = getEntity404 uid
|
||||
-- getUser (Left mail) = getBy404 $ UniqueEmail mail
|
||||
|
||||
|
||||
data PJTableAction = PJActAcknowledge | PJActReprint
|
||||
@ -341,7 +342,7 @@ postPrintSendR = do
|
||||
uid = usr ^. _entityKey
|
||||
mkLetter qual = LRQF
|
||||
{ lrqfLetter = "r"
|
||||
, lrqfUser = Right uid
|
||||
, lrqfUser = uid
|
||||
, lrqfSuper = Nothing
|
||||
, lrqfQuali = qual
|
||||
, lrqfIdent = LmsIdent "stuvwxyz"
|
||||
|
||||
@ -1952,17 +1952,18 @@ knownUserField onlySuggested suggestions = Field{..}
|
||||
|
||||
[whamlet|
|
||||
$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
|
||||
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 user $ Left UserDisplayEmail)
|
||||
E.then_ (user E.^. UserDisplayEmail)
|
||||
, E.when_ (unique user $ Left UserEmail)
|
||||
E.then_ (user E.^. UserEmail)
|
||||
[ E.when_ (uniqueCI user UserDisplayEmail)
|
||||
E.then_ ( user E.^. UserDisplayEmail)
|
||||
, E.when_ (uniqueCI user UserEmail)
|
||||
E.then_ (
|
||||
user E.^. UserEmail)
|
||||
]
|
||||
( E.else_ $ user E.^. UserIdent)
|
||||
, user E.^. UserDisplayName
|
||||
@ -1975,52 +1976,56 @@ knownUserField onlySuggested suggestions = Field{..}
|
||||
#{email} (#{dName})
|
||||
|]
|
||||
fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _
|
||||
| Just lookupExpr' <- lookupExpr = do
|
||||
let cit = CI.mk t
|
||||
dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
|
||||
user <- lookupExpr'
|
||||
E.where_ $ user E.^. UserIdent `E.ciEq` E.val cit
|
||||
E.||. ( user E.^. UserDisplayEmail E.==. E.val cit
|
||||
E.&&. unique user (Left UserDisplayEmail)
|
||||
)
|
||||
E.||. ( user E.^. UserEmail E.==. E.val cit
|
||||
E.&&. unique user (Left UserEmail)
|
||||
)
|
||||
E.||. ( user E.^. UserMatrikelnummer E.==. E.justVal t
|
||||
E.&&. unique user (Right UserMatrikelnummer)
|
||||
)
|
||||
E.||. ( user E.^. UserCompanyPersonalNumber E.==. E.justVal t
|
||||
E.&&. unique user (Right UserCompanyPersonalNumber)
|
||||
)
|
||||
E.limit 3 -- just to optimize the query
|
||||
return $ user E.^. UserId
|
||||
case dbRes of
|
||||
[uid] -> return $ Right $ Just $ E.unValue uid
|
||||
[] -> return $ Left $ SomeMessage $ MsgInvalidEmail t -- TODO: placeholder only, better error message
|
||||
_ -> return $ Left $ SomeMessage MsgAmbiguousEmail -- TODO: placeholder only, better error message
|
||||
| Just lookupExpr' <- lookupExpr = case Email.validate (encodeUtf8 t) of
|
||||
Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> do
|
||||
dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
|
||||
user <- lookupExpr'
|
||||
E.where_ $ E.val email E.==. user E.^. UserIdent -- UserIdent is unique
|
||||
E.||. E.val email E.==. user E.^. UserEmail -- UserEmail is unique
|
||||
E.||. ( E.val email E.==. 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
|
||||
return $ user E.^. UserId
|
||||
case dbRes of
|
||||
[uid] -> return $ Right $ Just $ E.unValue uid
|
||||
[] -> return $ Left $ SomeMessage MsgUnknownEmail
|
||||
_ -> return $ Left $ SomeMessage MsgAmbiguousEmail
|
||||
|
||||
Left _notAnEmail -> 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
|
||||
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
|
||||
|
||||
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'
|
||||
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
|
||||
E.&&. ( user' E.^. UserIdent E.==. user E.^. field
|
||||
E.||. user' E.^. UserEmail 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
|
||||
)
|
||||
unique user (Right field) | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
|
||||
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
|
||||
E.&&. ( user' E.^. UserIdent E.==. user E.^. field
|
||||
E.||. user' E.^. UserEmail E.==. user E.^. field
|
||||
E.||. user' E.^. UserDisplayEmail E.==. user E.^. field
|
||||
)
|
||||
uniqueCI _ _ = 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.^. UserIdent E.==. E.str2citext (user E.^. field)
|
||||
E.||. user' E.^. UserEmail E.==. E.str2citext (user E.^. field)
|
||||
E.||. user' E.^. UserDisplayEmail E.==. E.str2citext (user E.^. field)
|
||||
E.||. user' E.^. UserMatrikelnummer E.==. user E.^. field
|
||||
E.||. user' E.^. UserCompanyPersonalNumber E.==. user E.^. field
|
||||
)
|
||||
unique _ _ = E.true
|
||||
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
|
||||
|
||||
|
||||
examResultField :: forall m res.
|
||||
|
||||
@ -81,6 +81,8 @@ migrateManual = do
|
||||
, ("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_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_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)" )
|
||||
|
||||
Loading…
Reference in New Issue
Block a user