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

fix(avs): company update no longer fails on duplicate key

Browse Source
This commit is contained in:
Steffen Jost 2024-06-10 14:56:33 +02:00
parent e553ad4358
commit bb101dee7b
4 changed files with 49 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
models/company.model
View File

@ -11,15 +11,8 @@ Company
prefersPostal Bool default=false -- new company users prefers letters by post instead of email prefersPostal Bool default=false -- new company users prefers letters by post instead of email
postAddress StoredMarkup Maybe -- default company postal address, including company name postAddress StoredMarkup Maybe -- default company postal address, including company name
email UserEmail Maybe -- Case-insensitive generic company eMail address email UserEmail Maybe -- Case-insensitive generic company eMail address
UniqueCompanyName name -- UniqueCompanyName name -- Should be Unique in AVS, but we do not yet need to enforce it
-- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already -- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already
UniqueCompanyAvsId avsId UniqueCompanyAvsId avsId -- Should be the key, is not for historical reasons and for convenience in URLs and columns
Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
deriving Ord Eq Show Generic Binary 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

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

@ -565,16 +565,18 @@ repsertSuperiorSupervisor cid afi uid =
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo -- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company)) getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
getAvsCompany afi = getAvsCompany afi =
let compName :: CompanyName let compName :: CompanyName
compName = afi ^. _avsFirmFirm . from _CI compName = afi ^. _avsFirmFirm . from _CI
compShorthand :: CompanyShorthand compShorthand :: CompanyShorthand
compShorthand = afi ^. _avsFirmAbbreviation . from _CI compShorthand = afi ^. _avsFirmAbbreviation . from _CI
compAvsId = afi ^. _avsFirmFirmNo compAvsId = afi ^. _avsFirmFirmNo
in firstJustM $ in firstJustM $ -- legacy treatment, only use UniqueCompnayAvsId in the future
bcons (compAvsId > 0) guardMonoid (compAvsId > 0)
( getBy $ UniqueCompanyAvsId compAvsId ) [ getBy $ UniqueCompanyAvsId compAvsId
[ getBy $ UniqueCompanyName compName , getEntity $ CompanyKey $ compShorthand <> "-" <> ciShow compAvsId
, getEntity $ CompanyKey compShorthand ] <>
[ getByFilter [CompanyName ==. compName]
, getEntity $ CompanyKey compShorthand
] ]
-- | insert a company from AVS firm info or update an existing one based on previous values -- | insert a company from AVS firm info or update an existing one based on previous values
@ -583,17 +585,20 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name mbFirmEnt <- getAvsCompany newAvsFirmInfo -- primarily by AvsId, then Shorthand, then name
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|] $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
case (mbFirmEnt, mbOldAvsFirmInfo) of case (mbFirmEnt, mbOldAvsFirmInfo) of
(Nothing, _) -> do -- insert new company, neither AvsId, Shorthand or Name are known to exist (Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB
let upd = flip updateRecord newAvsFirmInfo afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
then return $ newAvsFirmInfo ^. _avsFirmFirmNo
else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
let upd = flip updateRecord newAvsFirmInfo
dmy = Company -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency dmy = Company -- mostly dummy, values are actually prodcued through firmInfo2company below for consistency
{ companyName = newAvsFirmInfo ^. _avsFirmFirm . from _CI { companyName = newAvsFirmInfo ^. _avsFirmFirm . from _CI
, companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI , companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI
, companyAvsId = newAvsFirmInfo ^. _avsFirmFirmNo , companyAvsId = afn
, companyPrefersPostal = True , companyPrefersPostal = True
, companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress
, companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI , companyEmail = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
} }
cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyUniques <> firmInfo2company cmp = foldl' upd dmy $ firmInfo2key : firmInfo2companyNo : firmInfo2company
$logInfoS "AVS" $ "Insert new company: " <> tshow cmp $logInfoS "AVS" $ "Insert new company: " <> tshow cmp
newCmp <- insertEntity cmp newCmp <- insertEntity cmp
reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
@ -603,30 +608,33 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred (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 let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key
uniq_ups <- maybeMapM (mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2companyUniques uniq_ups <- mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2companyNo
$logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow newAvsFirmInfo}|] $logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
res_cmp <- updateGetEntity firmid $ cmp_ups <> uniq_ups res_cmp <- updateGetEntity firmid $ mcons uniq_ups cmp_ups
case key_ups of let cmp_id = res_cmp ^. _entityVal . _companyAvsId
Nothing -> do res_cmp2 <- case key_ups of
$logInfoS "AVS" "Update new company completed." Just key_up | cmp_id > 0 -> do
return res_cmp $logInfoS "AVS" $ "Updating CompanyShorthand from " <> ciOriginal (companyShorthand firm) <> " to " <> avsFirmAbbreviation newAvsFirmInfo <> " for AvsNo " <> tshow cmp_id
Just key_up -> do let uniq_cmp = UniqueCompanyAvsId cmp_id
let compId = res_cmp ^. _entityVal . _companyAvsId cmp_key = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI
uniq_cmp = if compId > 0 then UniqueCompanyAvsId compId alt_key = cmp_key <> "-" <> ciShow cmp_id
else UniqueCompanyName $ res_cmp ^. _entityVal . _companyName key_ok <- notExists [CompanyShorthand ==. cmp_key]
updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries alt_ok <- notExists [CompanyShorthand ==. alt_key]
$logInfoS "AVS" "Update new company completed." if | key_ok -> updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries
maybeM (return res_cmp) return $ getBy uniq_cmp | alt_ok -> updateBy uniq_cmp [CompanyShorthand =. alt_key]
| otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal alt_key
maybeM (return res_cmp) return $ getBy uniq_cmp
_otherwise -> return res_cmp
$logInfoS "AVS" "Update company completed."
return res_cmp2
where where
firmInfo2key = firmInfo2key =
CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get
firmInfo2companyUniques = firmInfo2companyNo =
[ CheckUpdate CompanyName $ _avsFirmFirm . from _CI -- Updating unique turned out to be problematic, who would have thought! CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating a unique needs special considerations; AVS does not update FirmNo, but for legacy reasons we might have companies without a number
, CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating unique turned out to be problematic, who would have thought!
]
firmInfo2company = firmInfo2company =
[ CheckUpdate CompanyPostAddress _avsFirmPostAddress [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI
, CheckUpdate CompanyPostAddress _avsFirmPostAddress
, CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
-- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
] ]

4
src/Utils.hs
View File

@ -710,6 +710,10 @@ bcons :: Bool -> a -> [a] -> [a]
bcons False _ = id bcons False _ = id
bcons True x = (x:) bcons True x = (x:)
bsnoc :: Bool -> a -> [a] -> [a]
bsnoc False _ xs = xs
bsnoc True x xs = xs ++ [x]
-- | Merge/Add any attribute-value pair to an existing list of such pairs. -- | Merge/Add any attribute-value pair to an existing list of such pairs.
-- If the attribute exists, the new valu will be prepended, separated by a single empty space -- If the attribute exists, the new valu will be prepended, separated by a single empty space
insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]

5
src/Utils/DB.hs
View File

@ -82,6 +82,9 @@ getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend,
=> Key record -> ReaderT backend m (Entity record) => Key record -> ReaderT backend m (Entity record)
getEntity404 k = Entity k <$> get404 k getEntity404 k = Entity k <$> get404 k
notExists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) => [Filter record] -> ReaderT backend m Bool
notExists = fmap not . exists
existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m) existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
=> Unique record -> ReaderT backend m Bool => Unique record -> ReaderT backend m Bool
existsBy = fmap (is _Just) . getKeyBy existsBy = fmap (is _Just) . getKeyBy
@ -108,6 +111,7 @@ existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend,
existsKey404 = bool notFound (return ()) <=< existsKey existsKey404 = bool notFound (return ()) <=< existsKey
-- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result -- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result
-- getByPeseudoUnique
getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m) getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
=> [Filter record] -> ReaderT backend m (Maybe (Entity record)) => [Filter record] -> ReaderT backend m (Maybe (Entity record))
getByFilter crit = getByFilter crit =
@ -368,7 +372,6 @@ updateRecord ent new (CheckUpdate up l) =
-- | like mkUpdate' but only returns the update if the new value would be unique -- | like mkUpdate' but only returns the update if the new value would be unique
-- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record)) -- mkUpdateCheckUnique' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> DB (Maybe (Update record))
mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) mkUpdateCheckUnique' :: (MonadIO m, PersistQueryRead backend, PersistEntity record, PersistEntityBackend record ~ BaseBackend backend)
=> record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record)) => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record))