From b7af6312f91e3d43417e909fefc4dbee6ff8dad0 Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 18 Apr 2024 18:02:16 +0200 Subject: [PATCH] refactor(avs): complete createAvsUserById --- .../uniworx/categories/avs/de-de-formal.msg | 3 +- messages/uniworx/categories/avs/en-eu.msg | 3 +- src/Handler/Utils/Avs.hs | 117 ++++++++++-------- src/Handler/Utils/Users.hs | 17 +-- src/Handler/Utils/avs_callgraph.md | 17 ++- 5 files changed, 92 insertions(+), 65 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 0e4de3deb..115a976c1 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -47,4 +47,5 @@ AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse 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} \ No newline at end of file +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. \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index e572b8888..7faef6163 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -47,4 +47,5 @@ AvsUserAmbiguous api: Multiple matching users found for #{tshow api} AvsPersonSearchEmpty: AVS search returned empty result AvsPersonSearchAmbiguous: AVS search returned more than one result AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason} -AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead \ No newline at end of file +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 \ No newline at end of file diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index d282b3e77..b0020140a 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -75,8 +75,8 @@ data AvsException | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result | AvsSetLicencesFailed Text -- AvsSetLicence total failure - | AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query - -- | AvsUserCreationFailed + | AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query + | AvsUserCreationFailed AvsPersonId deriving (Show, Eq, Ord, Generic) instance Exception AvsException 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 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 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 createAvsUserById :: AvsPersonId -> Handler UserId createAvsUserById api = do - AvsResponseContact res <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api - case Set.toList res of + AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api + case Set.toList contactRes of [] -> throwM $ AvsUserUnknownByAvs api (_:_:_) -> throwM $ AvsUserAmbiguous api - [AvsDataContact{avsContactPersonInfo=cpi,..}] + [AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}] | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID | otherwise -> do - usrCardNo <- queryAvsFullCardNo api - let pinPass = avsFullCardNo2pin <$> usrCardNo - Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany avsContactFirmInfo Nothing -- individual runDB, since no need to rollback + -- check for matching existing user let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo - persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI - 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 -- use company address indirectly - , audPrefersPostal = cmp ^. _companyPrefersPostal - , audPinPassword = pinPass - } + persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI + oldUsr <- runDB $ do + mbUid <- firstJustM $ catMaybes + [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing + , persMail <&> guessUserByEmail + ] + mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid + return (mbUid, mbUAvs) + usrCardNo <- queryAvsFullCardNo api now <- liftIO getCurrentTime - runDB $ do -- any failure must rollback all DB write transactions - 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 + let usrAvs uid mbFirmInfo = UserAvs { userAvsPersonId = api , userAvsUser = uid , userAvsNoPerson = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail , userAvsLastSynch = now , userAvsLastSynchError = Nothing , userAvsLastPersonInfo = Just cpi - , userAvsLastFirmInfo = Just avsContactFirmInfo + , userAvsLastFirmInfo = mbFirmInfo , 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) @@ -762,12 +781,8 @@ guessAvsUser someid = do 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 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 - in MaybeT (getKeyBy $ UniqueEmail someIdent) -- recall that monadic actions are only executed until first success here - <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) - <|> MaybeT (getKeyByFilter [UserDisplayEmail ==. someIdent]) - <|> MaybeT (getKeyBy $ UniqueLdapPrimaryKey $ Just someid) - <|> MaybeT (getKeyByFilter [UserDisplayName ==. someid]) + MaybeT (guessUserByEmail $ stripCI someid) -- recall that monadic actions are only executed until first success here + <|> MaybeT (getKeyByFilter [UserDisplayName ==. someid]) -- | 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 == api' -> return uid | 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 diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 844ad0c20..9e39ca041 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -200,14 +200,17 @@ getSupervisees = do computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 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 eml = getKeyByFilter $ ofoldl1Ex' (||.) $ - mcons (getFraportLogin (CI.original eml) <&> (\lgi -> - [UserLdapPrimaryKey ==. Just lgi])) -- Note that we must exclude `==. Nothing` here! - [ [UserDisplayEmail ==. eml] - , [UserEmail ==. eml] - , [UserIdent ==. eml] - ] +guessUserByEmail eml = firstJustM $ + [ getKeyBy $ UniqueEmail eml + , getKeyBy $ UniqueAuthentication eml -- aka UserIdent + , getKeyByFilter [UserDisplayEmail ==. eml] + ] <> maybeEmpty (getFraportLogin (CI.original eml)) (\lgi -> + [ getKeyBy $ UniqueLdapPrimaryKey $ Just lgi + ]) data GuessUserInfo = GuessUserMatrikelnummer diff --git a/src/Handler/Utils/avs_callgraph.md b/src/Handler/Utils/avs_callgraph.md index ee642ae22..0b5c56281 100644 --- a/src/Handler/Utils/avs_callgraph.md +++ b/src/Handler/Utils/avs_callgraph.md @@ -5,13 +5,16 @@ flowchart LR; gau([guessAvsUser]) %% uau([XupsertAvsUser]) - uaubi[?upsertAvsUserById] + uaubi[upsertAvsUserById] + uaubis[upsertAvsUserByIds] uaubc[upsertAvsUserByCard] ldap[[ldapLookupAndUpsert]] lau[lookupAvsUser] laus[lookupAvsUsers - DEPRECATED?] gla[guessLicenceAddress - DEPRECATED] ur([?updateReceivers]) + caubi[createAvsUserById] + ucomp[upsertAvsCompany] aqc{{AvsQueryContact}} aqp{{AvsQueryPerson}} @@ -28,10 +31,14 @@ flowchart LR; %% uau-..->uaubi %% uau-..->uaubc - uaubi-.->lau - uaubi-.->ldap - uaubi-.->gla -uaubi-->aqc + uaubi-->uaubis + uaubi-->caubi-->uaubis + uaubis-->aqc + caubi-->aqs + caubi-->aqc + + caubi-->ucomp + uaubis-->ucomp lau-->laus laus-->aqs