From ccf934044938277d821eb4b9ea08a8a134e84189 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 17 May 2024 12:05:08 +0200 Subject: [PATCH 1/2] fix(avs): deal gracefully with empty card status results --- messages/uniworx/categories/avs/de-de-formal.msg | 3 ++- messages/uniworx/categories/avs/en-eu.msg | 3 ++- src/Handler/Admin/Avs.hs | 8 ++++---- src/Handler/Utils/Avs.hs | 1 + 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 316f053dc..a2034efe3 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -51,10 +51,11 @@ AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwo AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user} AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr) AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig +AvsSatusSearchEmpty: AVS lieferte keine Ausweisinformationen 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} 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. AvsCardsEmpty: AVS Suche lieferte keinerlei Ausweiskarten -AvsCurrentData: Diese angezeigten Daten wurden kürzlich über die AVS Schnittstelle abgerufen. \ No newline at end of file +AvsCurrentData: Alle angezeigte Daten wurden kürzlich direkt über die AVS Schnittstelle abgerufen. \ 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 6ce16160f..f42c75318 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -51,10 +51,11 @@ AvsInterfaceUnavailable: AVS interface was not configured correctly or does not AvsUserUnassociated user: AVS id unknown for user #{user} AvsUserUnknownByAvs api: AVS reports id #{tshow api} as unknown (or no longer known) AvsUserAmbiguous api: Multiple matching users found for #{tshow api} +AvsStatusSearchEmpty: AVS returned no card information 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 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 AvsCardsEmpty: AVS search returned no id cards -AvsCurrentData: This data has been recently received via the AVS interface. \ No newline at end of file +AvsCurrentData: All shown data has been recently received via the AVS interface. \ No newline at end of file diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 1a6bdaf19..4175379a6 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -696,10 +696,10 @@ postAdminAvsUserR uuid = do Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid -- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID)) - fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID)) + -- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID)) mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId - mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId - -- mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses + -- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId + mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just compDict <- if 1 >= length compsUsed then return mempty -- switch company only sensible if there is more than one company to choose @@ -759,7 +759,7 @@ postAdminAvsUserR uuid = do Left err -> exceptionWgt err Right (AvsResponseStatus asts) -> if null asts - then [whamlet|This should not occur|] -- TODO + then [whamlet|_{MsgAvsPersonSearchEmpty}|] else let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts in mconcat cs diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index da14c9f0c..d384da6ff 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -76,6 +76,7 @@ data AvsException | AvsUserUnassociated Text -- Manipulating AVS Data for a user that is not linked to AVS yet | AvsUserUnknownByAvs AvsPersonId -- AvsPersonId not (or no longer) found in AVS | AvsUserAmbiguous AvsPersonId -- Multiple matching existing users found for a query in AVS or DB + | AvsStatusSearchEmpty -- AvsStatusSearch returned empty result | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result | AvsSetLicencesFailed Text -- AvsSetLicence total failure From ff2347b1c950c7a2bb281cdcd07a52925e23b9f0 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 17 May 2024 18:06:16 +0200 Subject: [PATCH 2/2] fix(avs): avs update on company shorthands working now --- .../uniworx/categories/avs/de-de-formal.msg | 2 +- models/avs.model | 2 +- models/company.model | 12 +++++------ models/jobs.model | 4 ++-- models/lms.model | 14 ++++++------- models/print.model | 6 +++--- models/users.model | 14 ++++++------- src/Application.hs | 4 ++-- src/Handler/Admin/Avs.hs | 2 +- src/Handler/Utils/Avs.hs | 21 +++++++++++++------ src/Utils/DB.hs | 1 + 11 files changed, 46 insertions(+), 36 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index a2034efe3..19c6684c4 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -51,7 +51,7 @@ AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwo AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user} AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr) AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig -AvsSatusSearchEmpty: AVS lieferte keine Ausweisinformationen +AvsStatusSearchEmpty: AVS lieferte keine Ausweisinformationen AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason} diff --git a/models/avs.model b/models/avs.model index 067fb9d21..ee4dd9a19 100644 --- a/models/avs.model +++ b/models/avs.model @@ -31,4 +31,4 @@ AvsSync creationTime UTCTime pause Day Maybe -- Don't synch if last synch after this day, otherwise synch UniqueAvsSyncUser user - deriving Generic \ No newline at end of file + deriving Generic Show \ No newline at end of file diff --git a/models/company.model b/models/company.model index 7cf61bb5e..c123e281b 100644 --- a/models/company.model +++ b/models/company.model @@ -17,9 +17,9 @@ Company Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } deriving Ord Eq Show Generic Binary --- TODO: a way to populate this table (manually) -CompanySynonym - synonym CompanyName - canonical CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId - UniqueCompanySynonym synonym - deriving Ord Eq Show Generic +-- -- TODO: a way to populate this table (manually) +-- CompanySynonym +-- synonym CompanyName +-- canonical CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId +-- UniqueCompanySynonym synonym +-- deriving Ord Eq Show Generic diff --git a/models/jobs.model b/models/jobs.model index 98aa8c3b8..bc24e931f 100644 --- a/models/jobs.model +++ b/models/jobs.model @@ -20,11 +20,11 @@ CronLastExec time UTCTime -- When was the job executed instance InstanceId -- Which uni2work-instance did the work UniqueCronLastExec job - deriving Generic + deriving Generic Show TokenBucket ident TokenBucketIdent lastValue Int64 lastAccess UTCTime Primary ident - deriving Generic \ No newline at end of file + deriving Generic Show \ No newline at end of file diff --git a/models/lms.model b/models/lms.model index 9e96df730..c47e69a8c 100644 --- a/models/lms.model +++ b/models/lms.model @@ -22,7 +22,7 @@ Qualification -- across all schools, only one qualification may be a driving licence: UniqueQualificationAvsLicence avsLicence !force -- either empty or unique -- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints! - deriving Eq Generic + deriving Show Eq Generic -- TODOs: -- - Enstehen Kosten, wenn Teilnehmer für KnowHow eingereiht werden, aber nicht am Kurs teilnehmen? @@ -44,7 +44,7 @@ QualificationPrecondition -- NOTE: this can only be enforc qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions required [QualificationId] -- OR : alternatives, any one will suffice continuous Bool -- expiring precondition blocks qualification - deriving Generic + deriving Generic Show -- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version) -- QualificationRequirement @@ -60,7 +60,7 @@ QualificationEdit user UserId time UTCTime qualification QualificationId OnDeleteCascade OnUpdateCascade - deriving Generic + deriving Generic Show QualificationUser user UserId OnDeleteCascade OnUpdateCascade @@ -73,7 +73,7 @@ QualificationUser -- Reasons and temporary revocations are implemented through QualificationUserBlock -- TODO: adjust SAP interface to transmit end dates UniqueQualificationUser qualification user - deriving Generic + deriving Generic Show QualificationUserBlock qualificationUser QualificationUserId OnDeleteCascade OnUpdateCascade @@ -130,7 +130,7 @@ LmsUser -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this? No. UniqueLmsIdent ident -- idents must be unique accross all qualifications, since idents are global within LMS! UniqueLmsQualificationUser qualification user -- each user may be enrolled at most once per course - deriving Generic + deriving Generic Show -- LmsUserStatus -- lmsUser LmsUserId OnDeleteCascade OnUpdateCascade @@ -148,7 +148,7 @@ LmsReport lock Bool -- (0|1) timestamp UTCTime default=now() UniqueLmsReport qualification ident -- required by DBTable - deriving Generic + deriving Generic Show -- LmsAudit removed by commit 71cde92a -- due to frequent transmit errors, a separate lms tranmission log is necessary again @@ -160,4 +160,4 @@ LmsReportLog lock Bool -- (0|1) timestamp UTCTime default=now() missing Bool default=false - deriving Generic \ No newline at end of file + deriving Generic Show \ No newline at end of file diff --git a/models/print.model b/models/print.model index ee22cf922..bdf7b5a56 100644 --- a/models/print.model +++ b/models/print.model @@ -16,16 +16,16 @@ PrintJob lmsUser LmsIdent Maybe OnDeleteSetNull OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used - deriving Generic + deriving Generic Show PrintAcknowledge -- just to store acknowledging requests to be evaluated by a background job later on apcIdent Text timestamp UTCTime default=now() processed Bool - deriving Generic + deriving Generic Show PrintAckIdAlias needle Text replacement Text priority Int - deriving Generic \ No newline at end of file + deriving Generic Show \ No newline at end of file diff --git a/models/users.model b/models/users.model index f1e35c47e..afe59e77a 100644 --- a/models/users.model +++ b/models/users.model @@ -61,31 +61,31 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation function SchoolFunction UniqueUserFunction user school function deriving Generic -UserSystemFunction +UserSystemFunction Show user UserId function SystemFunction -- Defined in Model.Types.User manual Bool -- Inserted manually by Admin or automatic from LDAP isOptOut Bool -- User has currently deactivate the role for themselves UniqueUserSystemFunction user function - deriving Generic + deriving Generic Show UserExamOffice user UserId field StudyTermsId UniqueUserExamOffice user field - deriving Generic + deriving Generic Show UserSchool -- Managed by users themselves, encodes "schools of interest" user UserId school SchoolId isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically UniqueUserSchool user school - deriving Generic + deriving Generic Show UserGroupMember group UserGroupName user UserId primary Checkmark nullable UniquePrimaryUserGroupMember group primary !force UniqueUserGroupMember group user - deriving Generic + deriving Generic Show UserCompany user UserId company CompanyId OnDeleteCascade OnUpdateCascade @@ -94,7 +94,7 @@ UserCompany priority Int default=0 -- higher number, higher priority useCompanyAddress Bool default=true -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once - deriving Generic + deriving Generic Show UserSupervisor supervisor UserId -- multiple supervisor per trainee possible user UserId @@ -102,5 +102,5 @@ UserSupervisor company CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry reason Text Maybe -- miscellaneous reason, e.g. Winterservice supervisision UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) - deriving Generic + deriving Generic Show diff --git a/src/Application.hs b/src/Application.hs index 83bda733e..e7dc88b68 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -746,8 +746,8 @@ shutdownApp app = do -- | Run a handler handler, handler' :: Handler a -> IO a -handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h +handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h +handler' h = runResourceT $ getAppSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries db, db' :: DB a -> IO a diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 4175379a6..82d739bb8 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -759,7 +759,7 @@ postAdminAvsUserR uuid = do Left err -> exceptionWgt err Right (AvsResponseStatus asts) -> if null asts - then [whamlet|_{MsgAvsPersonSearchEmpty}|] + then [whamlet|_{MsgAvsStatusSearchEmpty}|] else let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts in mconcat cs diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index d384da6ff..9f4951f49 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -584,19 +584,28 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI } - newCmp <- insertEntity $ foldl' upd dmy firmInfo2company + newCmp <- insertEntity $ foldl' upd dmy $ firmInfo2key : firmInfo2company reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp return newCmp (Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company - Entity firmid <$> updateGet firmid cmp_ups - + key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key + res_cmp <- updateGetEntity firmid cmp_ups + case key_ups of + Nothing -> return res_cmp + Just key_up -> do + let uniq_cmp = UniqueCompanyAvsId $ res_cmp ^. _entityVal . _companyAvsId + updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries + maybeM (return res_cmp) return $ getBy uniq_cmp + + where + firmInfo2key = + CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get firmInfo2company = - [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI - , CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI - , CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade + [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI + , CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating unique might be problematic -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available , CheckUpdate CompanyPostAddress _avsFirmPostAddress , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 1bbadb1f6..6420dccc2 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -129,6 +129,7 @@ updateBy uniq updates = do key <- getKeyBy uniq for_ key $ flip update updates +-- | update and retrieve an entity. Will throw an error if the key is updaded updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record) updateGetEntity k = fmap (Entity k) . updateGet k