From ff2347b1c950c7a2bb281cdcd07a52925e23b9f0 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 17 May 2024 18:06:16 +0200 Subject: [PATCH] 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