diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg
index fbc36aa90..960a75fe2 100644
--- a/messages/uniworx/misc/de-de-formal.msg
+++ b/messages/uniworx/misc/de-de-formal.msg
@@ -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
\ No newline at end of file
+NoProblem: Keine Probleme gefunden
+Unknown: ist unbekannt
+Ambiguous: ist uneindeutig
\ No newline at end of file
diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg
index 05d12945c..14d4838c6 100644
--- a/messages/uniworx/misc/en-eu.msg
+++ b/messages/uniworx/misc/en-eu.msg
@@ -32,4 +32,6 @@ PaginationError: Pagination parameter must not be negative
NullDeletes: Enter NULL to delete.
SortPriority: Sort order priority
-NoProblem: No Probleme found
\ No newline at end of file
+NoProblem: No Probleme found
+Unknown: is unknown
+Ambiguous: is ambiguous
\ No newline at end of file
diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg
index 4b9e83764..b706ef0eb 100644
--- a/messages/uniworx/utils/utils/de-de-formal.msg
+++ b/messages/uniworx/utils/utils/de-de-formal.msg
@@ -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
diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg
index c4c694c69..028c09adb 100644
--- a/messages/uniworx/utils/utils/en-eu.msg
+++ b/messages/uniworx/utils/utils/en-eu.msg
@@ -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
diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs
index d9291e51d..7672dbcac 100644
--- a/src/Handler/PrintCenter.hs
+++ b/src/Handler/PrintCenter.hs
@@ -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"
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 5f0e8d4e5..9af3f4d9a 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -1952,17 +1952,18 @@ knownUserField onlySuggested suggestions = Field{..}
[whamlet|
$newline never
-
+
|]
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.
diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index 6c7da942a..8643802ad 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/src/Model/Migration/Definitions.hs
@@ -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)" )