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

refactor(avs): complete createAvsUserById

Browse Source
This commit is contained in:
Steffen Jost 2024-04-18 18:02:16 +02:00
parent 234dd28f48
commit b7af6312f9
5 changed files with 92 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -47,4 +47,5 @@ AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig
AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason} AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}
AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2} AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2}
AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt.

3
messages/uniworx/categories/avs/en-eu.msg
View File

@ -47,4 +47,5 @@ AvsUserAmbiguous api: Multiple matching users found for #{tshow api}
AvsPersonSearchEmpty: AVS search returned empty result AvsPersonSearchEmpty: AVS search returned empty result
AvsPersonSearchAmbiguous: AVS search returned more than one result AvsPersonSearchAmbiguous: AVS search returned more than one result
AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason} AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead
AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique

117
src/Handler/Utils/Avs.hs
View File

@ -75,8 +75,8 @@ data AvsException
| AvsPersonSearchEmpty -- AvsPersonSearch returned empty result | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result
| AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result
| AvsSetLicencesFailed Text -- AvsSetLicence total failure | AvsSetLicencesFailed Text -- AvsSetLicence total failure
| AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query | AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query
-- | AvsUserCreationFailed | AvsUserCreationFailed AvsPersonId
deriving (Show, Eq, Ord, Generic) deriving (Show, Eq, Ord, Generic)
instance Exception AvsException instance Exception AvsException
embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user initiated actions -- moved to Foundation.I18n embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user initiated actions -- moved to Foundation.I18n
@ -360,7 +360,7 @@ updateReceivers uid = do
-- TODO #36 "company postal preference", but for updates only yet -- TODO #36 "company postal preference", but for updates only yet
-- --
-- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do -- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do
-- TODO: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API -- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
class SomeAvsQuery q where class SomeAvsQuery q where
@ -615,61 +615,80 @@ updateAvsUserByIds apids0 = do
-- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints -- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
createAvsUserById :: AvsPersonId -> Handler UserId createAvsUserById :: AvsPersonId -> Handler UserId
createAvsUserById api = do createAvsUserById api = do
AvsResponseContact res <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
case Set.toList res of case Set.toList contactRes of
[] -> throwM $ AvsUserUnknownByAvs api [] -> throwM $ AvsUserUnknownByAvs api
(_:_:_) -> throwM $ AvsUserAmbiguous api (_:_:_) -> throwM $ AvsUserAmbiguous api
[AvsDataContact{avsContactPersonInfo=cpi,..}] [AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
| otherwise -> do | otherwise -> do
usrCardNo <- queryAvsFullCardNo api -- check for matching existing user
let pinPass = avsFullCardNo2pin <$> usrCardNo
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany avsContactFirmInfo Nothing -- individual runDB, since no need to rollback
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
newUserData = AddUserData oldUsr <- runDB $ do
{ audTitle = Nothing mbUid <- firstJustM $ catMaybes
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
, audSurname = cpi ^. _avsInfoLastName & Text.strip , persMail <&> guessUserByEmail
, audDisplayName = cpi ^. _avsInfoDisplayName ]
, audDisplayEmail = persMail & fromMaybe mempty mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) return (mbUid, mbUAvs)
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api ) usrCardNo <- queryAvsFullCardNo api
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
, audSex = Nothing
, audBirthday = cpi ^. _avsInfoDateOfBirth
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
, audTelephone = Nothing
, audFPersonalNumber = internalPersNo
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
, audPostAddress = Nothing -- use company address indirectly
, audPrefersPostal = cmp ^. _companyPrefersPostal
, audPinPassword = pinPass
}
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
runDB $ do -- any failure must rollback all DB write transactions let usrAvs uid mbFirmInfo = UserAvs
uid <- maybeThrowM AvsInterfaceUnavailable $ addNewUserDB newUserData
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
userCompId <- maybeThrowM AvsInterfaceUnavailable $ insertUnique userComp
-- TODO: link with existing user, if insertion failed?
-- TODO: write suitable exceptions, replacing all 3 AvsInterfaceUnavailable within this block
-- TODO: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
-- Supervision
addCompanySupervisors cid uid
repsertSuperiorSupervisor (Just cid) avsContactFirmInfo uid
-- Save AVS data for future updates
userAvsId <- maybeThrowM AvsInterfaceUnavailable $ insertUnique UserAvs
{ userAvsPersonId = api { userAvsPersonId = api
, userAvsUser = uid , userAvsUser = uid
, userAvsNoPerson = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail , userAvsNoPerson = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail
, userAvsLastSynch = now , userAvsLastSynch = now
, userAvsLastSynchError = Nothing , userAvsLastSynchError = Nothing
, userAvsLastPersonInfo = Just cpi , userAvsLastPersonInfo = Just cpi
, userAvsLastFirmInfo = Just avsContactFirmInfo , userAvsLastFirmInfo = mbFirmInfo
, userAvsLastCardNo = usrCardNo , userAvsLastCardNo = usrCardNo
}
case oldUsr of
(_ , Just Entity{entityVal=UserAvs{userAvsPersonId=api'}})
| api /= api' -> throwM $ AvsIdMismatch api api'
| otherwise -> throwM $ AvsUserUnknownByAvs api
(Just uid, Nothing) -> runDB $ do -- link with matching exisitng user
insert_ $ usrAvs uid Nothing -- company info should cause the user to be associated with the company during the update
updRes <- updateAvsUserByIds $ Set.singleton api -- no loop, since updateAvsUserByIds does not call createAvsUserById
case Set.toList updRes of
[(api',uid')] | api == api' -> return uid' -- && uid == uid' -> return uid
| otherwise -> throwM $ AvsIdMismatch api api'
[] -> throwM $ AvsUserUnknownByAvs api
_ -> throwM $ AvsUserAmbiguous api
(Nothing, Nothing) -> do
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
let pinPass = avsFullCardNo2pin <$> usrCardNo
newUserData = AddUserData
{ audTitle = Nothing
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
, audSurname = cpi ^. _avsInfoLastName & Text.strip
, audDisplayName = cpi ^. _avsInfoDisplayName
, audDisplayEmail = persMail & fromMaybe mempty
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
, audSex = Nothing
, audBirthday = cpi ^. _avsInfoDateOfBirth
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
, audTelephone = Nothing
, audFPersonalNumber = internalPersNo
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
, audPostAddress = Nothing -- always use company address indirectly
, audPrefersPostal = cmp ^. _companyPrefersPostal
, audPinPassword = pinPass
} }
return $ seq userCompId $ seq userAvsId uid runDB $ do -- any failure must rollback all DB write transactions here
uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
-- Supervision
addCompanySupervisors cid uid
repsertSuperiorSupervisor (Just cid) firmInfo uid
-- Save AVS data for future updates
insert_ $ usrAvs uid $ Just firmInfo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
return uid
-- | upsert superior by eMail through LDAP only (currently no email search available in AVS) -- | upsert superior by eMail through LDAP only (currently no email search available in AVS)
@ -762,12 +781,8 @@ guessAvsUser someid = do
other -> do -- attempt to recover by trying other ids other -> do -- attempt to recover by trying other ids
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
runDB . runMaybeT $ runDB . runMaybeT $
let someIdent = stripCI someid -- also see Handler.Utils.guessUserByEmail for a similar function, this one is more lenient, since a unique email is acceptable, even it would not be unique as DisplayEmail MaybeT (guessUserByEmail $ stripCI someid) -- recall that monadic actions are only executed until first success here
in MaybeT (getKeyBy $ UniqueEmail someIdent) -- recall that monadic actions are only executed until first success here <|> MaybeT (getKeyByFilter [UserDisplayName ==. someid])
<|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
<|> MaybeT (getKeyByFilter [UserDisplayEmail ==. someIdent])
<|> MaybeT (getKeyBy $ UniqueLdapPrimaryKey $ Just someid)
<|> MaybeT (getKeyByFilter [UserDisplayName ==. someid])
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update. -- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
@ -797,7 +812,7 @@ upsertAvsUserById0 api = do
[(api',uid)] [(api',uid)]
| api == api' -> return uid | api == api' -> return uid
| otherwise -> throwM $ AvsIdMismatch api api' | otherwise -> throwM $ AvsIdMismatch api api'
-- error $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "." -- error $ "Handler.Utils.Avs.updateAvsUserByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "."
(_:_:_) -> throwM $ AvsUserAmbiguous api (_:_:_) -> throwM $ AvsUserAmbiguous api

17
src/Handler/Utils/Users.hs
View File

@ -200,14 +200,17 @@ getSupervisees = do
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
computeUserAuthenticationDigest = hashlazy . JSON.encode computeUserAuthenticationDigest = hashlazy . JSON.encode
-- guessUserByCompanyPersonalNumber :: Text -> Text -> DB (Maybe UserId)
-- guessUserByCompanyPersonalNumber surname ipn = getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn, UserSurname ==. surname]
guessUserByEmail :: UserEmail -> DB (Maybe UserId) guessUserByEmail :: UserEmail -> DB (Maybe UserId)
guessUserByEmail eml = getKeyByFilter $ ofoldl1Ex' (||.) $ guessUserByEmail eml = firstJustM $
mcons (getFraportLogin (CI.original eml) <&> (\lgi -> [ getKeyBy $ UniqueEmail eml
[UserLdapPrimaryKey ==. Just lgi])) -- Note that we must exclude `==. Nothing` here! , getKeyBy $ UniqueAuthentication eml -- aka UserIdent
[ [UserDisplayEmail ==. eml] , getKeyByFilter [UserDisplayEmail ==. eml]
, [UserEmail ==. eml] ] <> maybeEmpty (getFraportLogin (CI.original eml)) (\lgi ->
, [UserIdent ==. eml] [ getKeyBy $ UniqueLdapPrimaryKey $ Just lgi
] ])
data GuessUserInfo data GuessUserInfo
= GuessUserMatrikelnummer = GuessUserMatrikelnummer

17
src/Handler/Utils/avs_callgraph.md
View File

@ -5,13 +5,16 @@
flowchart LR; flowchart LR;
gau([guessAvsUser]) gau([guessAvsUser])
%% uau([XupsertAvsUser]) %% uau([XupsertAvsUser])
uaubi[?upsertAvsUserById] uaubi[upsertAvsUserById]
uaubis[upsertAvsUserByIds]
uaubc[upsertAvsUserByCard] uaubc[upsertAvsUserByCard]
ldap[[ldapLookupAndUpsert]] ldap[[ldapLookupAndUpsert]]
lau[lookupAvsUser] lau[lookupAvsUser]
laus[lookupAvsUsers - DEPRECATED?] laus[lookupAvsUsers - DEPRECATED?]
gla[guessLicenceAddress - DEPRECATED] gla[guessLicenceAddress - DEPRECATED]
ur([?updateReceivers]) ur([?updateReceivers])
caubi[createAvsUserById]
ucomp[upsertAvsCompany]
aqc{{AvsQueryContact}} aqc{{AvsQueryContact}}
aqp{{AvsQueryPerson}} aqp{{AvsQueryPerson}}
@ -28,10 +31,14 @@ flowchart LR;
%% uau-..->uaubi %% uau-..->uaubi
%% uau-..->uaubc %% uau-..->uaubc
uaubi-.->lau uaubi-->uaubis
uaubi-.->ldap uaubi-->caubi-->uaubis
uaubi-.->gla uaubis-->aqc
uaubi-->aqc caubi-->aqs
caubi-->aqc
caubi-->ucomp
uaubis-->ucomp
lau-->laus lau-->laus
laus-->aqs laus-->aqs