diff --git a/models/company.model b/models/company.model index c123e281b..4ed5274e1 100644 --- a/models/company.model +++ b/models/company.model @@ -11,15 +11,8 @@ Company prefersPostal Bool default=false -- new company users prefers letters by post instead of email postAddress StoredMarkup Maybe -- default company postal address, including company name 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 - UniqueCompanyAvsId avsId - Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } + 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 } 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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index af7610502..f115de106 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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 getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company)) getAvsCompany afi = - let compName :: CompanyName + let compName :: CompanyName compName = afi ^. _avsFirmFirm . from _CI compShorthand :: CompanyShorthand compShorthand = afi ^. _avsFirmAbbreviation . from _CI compAvsId = afi ^. _avsFirmFirmNo - in firstJustM $ - bcons (compAvsId > 0) - ( getBy $ UniqueCompanyAvsId compAvsId ) - [ getBy $ UniqueCompanyName compName - , getEntity $ CompanyKey compShorthand + in firstJustM $ -- legacy treatment, only use UniqueCompnayAvsId in the future + guardMonoid (compAvsId > 0) + [ getBy $ UniqueCompanyAvsId compAvsId + , getEntity $ CompanyKey $ compShorthand <> "-" <> ciShow compAvsId + ] <> + [ getByFilter [CompanyName ==. compName] + , getEntity $ CompanyKey compShorthand ] -- | 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 $logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|] case (mbFirmEnt, mbOldAvsFirmInfo) of - (Nothing, _) -> do -- insert new company, neither AvsId, Shorthand or Name are known to exist - let upd = flip updateRecord newAvsFirmInfo + (Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB + 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 { companyName = newAvsFirmInfo ^. _avsFirmFirm . from _CI , companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI - , companyAvsId = newAvsFirmInfo ^. _avsFirmFirmNo + , companyAvsId = afn , companyPrefersPostal = True , companyPostAddress = newAvsFirmInfo ^. _avsFirmPostAddress , 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 newCmp <- insertEntity cmp 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 let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key - uniq_ups <- maybeMapM (mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2companyUniques - $logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow newAvsFirmInfo}|] - res_cmp <- updateGetEntity firmid $ cmp_ups <> uniq_ups - case key_ups of - Nothing -> do - $logInfoS "AVS" "Update new company completed." - return res_cmp - Just key_up -> do - let compId = res_cmp ^. _entityVal . _companyAvsId - uniq_cmp = if compId > 0 then UniqueCompanyAvsId compId - else UniqueCompanyName $ res_cmp ^. _entityVal . _companyName - updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries - $logInfoS "AVS" "Update new company completed." - maybeM (return res_cmp) return $ getBy uniq_cmp - + 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 oldAvsFirmInfo}|] + res_cmp <- updateGetEntity firmid $ mcons uniq_ups cmp_ups + let cmp_id = res_cmp ^. _entityVal . _companyAvsId + res_cmp2 <- case key_ups of + Just key_up | cmp_id > 0 -> do + $logInfoS "AVS" $ "Updating CompanyShorthand from " <> ciOriginal (companyShorthand firm) <> " to " <> avsFirmAbbreviation newAvsFirmInfo <> " for AvsNo " <> tshow cmp_id + let uniq_cmp = UniqueCompanyAvsId cmp_id + cmp_key = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI + alt_key = cmp_key <> "-" <> ciShow cmp_id + key_ok <- notExists [CompanyShorthand ==. cmp_key] + alt_ok <- notExists [CompanyShorthand ==. alt_key] + if | key_ok -> updateBy uniq_cmp [key_up] -- this is ok, since we have OnUpdateCascade on all CompanyId entries + | 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 firmInfo2key = CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI -- Updating primary key works in principle thanks to OnUpdateCascade, but fails due to update get - firmInfo2companyUniques = - [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI -- Updating unique turned out to be problematic, who would have thought! - , CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating unique turned out to be problematic, who would have thought! - ] + firmInfo2companyNo = + 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 firmInfo2company = - [ CheckUpdate CompanyPostAddress _avsFirmPostAddress + [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI + , CheckUpdate CompanyPostAddress _avsFirmPostAddress , 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 ] diff --git a/src/Utils.hs b/src/Utils.hs index 21685f564..18edea373 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -710,6 +710,10 @@ bcons :: Bool -> a -> [a] -> [a] bcons False _ = id 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. -- If the attribute exists, the new valu will be prepended, separated by a single empty space insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index e624ef497..29b74757d 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -82,6 +82,9 @@ getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend, => Key record -> ReaderT backend m (Entity record) 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) => Unique record -> ReaderT backend m Bool existsBy = fmap (is _Just) . getKeyBy @@ -108,6 +111,7 @@ existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, existsKey404 = bool notFound (return ()) <=< existsKey -- | 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) => [Filter record] -> ReaderT backend m (Maybe (Entity record)) 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 -- 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) => record -> a -> Maybe a -> CheckUpdate record a -> ReaderT backend m (Maybe (Update record))