From c179c03f9da82abb171a773838060ba4f6a77355 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 6 Mar 2024 13:41:18 +0100 Subject: [PATCH] chore(avs): update company supervisors on avs user update --- models/users.model | 2 +- src/Handler/Utils/Avs.hs | 88 ++++++++++++++++++++++++++++++---------- src/Model/Types/Avs.hs | 26 ++++++------ src/Model/Types/Misc.hs | 11 +++++ src/Utils.hs | 28 ++++++++++--- src/Utils/Persist.hs | 7 ++++ 6 files changed, 120 insertions(+), 42 deletions(-) diff --git a/models/users.model b/models/users.model index 05741d3b6..d01e7d1dc 100644 --- a/models/users.model +++ b/models/users.model @@ -98,7 +98,7 @@ UserSupervisor user UserId rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well company CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry - reason Text Maybe -- miscellanoues reason, e.g. Winterservice supervisision + 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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index e41044aa1..aa1893d25 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -48,6 +48,7 @@ import Handler.Utils.Memcached import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.PostgreSQL as E import Servant.Client.Core.ClientError (ClientError) @@ -644,14 +645,20 @@ queryAvsCardNo crd = do _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) _avsFirmPostAddress = to mkPost + where + mkPost afi@AvsFirmInfo{avsFirmFirm} = + let someAddr = afi ^. _avsFirmPostAddressSimple + prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n' + in prefAddr <$> someAddr + +-- | company post address without company name, better suited for comparisons +_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +_avsFirmPostAddressSimple = to mkPost where mkPost AvsFirmInfo{..} = let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress - someAddr = fromMaybe "" $ asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] - in if null someAddr - then Nothing - else Just $ plaintextToStoredMarkup $ avsFirmFirm <> Text.cons '\n' someAddr + in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) _avsFirmPrimaryEmail = to mkEmail @@ -736,8 +743,8 @@ updateAvsUserByIds apids = do eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail) in mkUpdate usr eml_new eml_old $ CheckAvsUpdate UserDisplayEmail $ to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo PROBLEM: Hängt auch von der FirmenEmail ab und muss daher im Verbund betrachtet werden. - frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr newAvsFirmInfo oldAvsFirmInfo') - [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup) + frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr newAvsFirmInfo oldAvsFirmInfo') + [ CheckAvsUpdate UserPostAddress _avsFirmPostAddress ] usr_ups = mcons eml_up $ frm_ups <> per_ups avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` @@ -746,25 +753,62 @@ updateAvsUserByIds apids = do , UserAvsLastPersonInfo =. Just newAvsPersonInfo , UserAvsLastFirmInfo =. Just newAvsFirmInfo ] - _newCompanyId <- lift $ upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo - -- TODO: if the company id has changed, update supervision too - lift $ update usrId usr_ups - lift $ update uaId avs_ups + lift $ do -- no more maybe here + update usrId usr_ups + oldCompanyMb <- join <$> (getAvsCompany `traverse` oldAvsFirmInfo) + let oldCompanyId = entityKey <$> oldCompanyMb + newCompanyId <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo + -- newCompanyMb <- get newCompanyId + -- adjusting supervisors + -- case (oldAvsFirmInfo, oldCompanyMb, newCompanyMb) of + case oldAvsFirmInfo of + _ | oldCompanyId == Just newCompanyId -- company unchanged entirely + -> return () + (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged + -> return () + (Just oafi) | ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged + -> return () + _ -- company changed completely + -> do + let superReasonComDef = tshow SupervisorReasonCompanyDefault + superCompanyFilter = maybe [UserSupervisorCompany ==. Nothing] (UserSupervisorCompany ~=.) oldCompanyId + deleteWhere $ (UserSupervisorUser ==. usrId) : mconcat [superCompanyFilter, UserSupervisorReason ~=. superReasonComDef] + E.insertSelectWithConflict + UniqueUserSupervisor + ( do + userCompany <- E.from $ E.table @UserCompany + E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val newCompanyId + E.&&. userCompany E.^. UserCompanySupervisor + return $ UserSupervisor + E.<# (userCompany E.^. UserCompanyUser) + E.<&> E.val usrId + E.<&> (userCompany E.^. UserCompanySupervisorReroute) + E.<&> E.justVal newCompanyId + E.<&> E.justVal superReasonComDef + ) + (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists + [ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] + , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ] + ] + ) + return () + update uaId avs_ups return $ Set.singleton (apid, usrId) --- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked +-- | 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 - compName = afi ^. _avsFirmFirm . re _CI + compName = afi ^. _avsFirmFirm . from _CI compShorthand :: CompanyShorthand - compShorthand = afi ^. _avsFirmAbbreviation . re _CI + compShorthand = afi ^. _avsFirmAbbreviation . from _CI compAvsId = afi ^. _avsFirmFirmNo - in firstJustM - [ getBy $ UniqueCompanyAvsId compAvsId - , getEntity $ CompanyKey compShorthand - , getBy $ UniqueCompanyName compName - ] + in firstJustM $ + bcons (compAvsId > 0) + ( getBy $ UniqueCompanyAvsId compAvsId ) + [ getEntity $ CompanyKey compShorthand + , getBy $ UniqueCompanyName compName + ] upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB CompanyId upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do @@ -773,8 +817,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do (Nothing, _) -> do -- insert new company let upd = flip updateRecord newAvsFirmInfo dmy = Company - { companyName = newAvsFirmInfo ^. _avsFirmFirm . re _CI - , companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . re _CI + { companyName = newAvsFirmInfo ^. _avsFirmFirm . from _CI + , companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . from _CI , companyAvsId = newAvsFirmInfo ^. _avsFirmFirmNo , companyPrefersPostal = True , companyPostAddress = Nothing @@ -792,8 +836,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do return firmid where firmInfo2company = - [ CheckAvsUpdate CompanyName $ _avsFirmFirm . re _CI - , CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . re _CI + [ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI + , CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI , CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade -- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available , CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 4f1057bc3..b9b0fb2d5 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -613,21 +613,19 @@ data AvsFirmInfo = AvsFirmInfo } deriving (Eq, Ord, Show, Generic, NFData, Binary) makeLenses_ ''AvsFirmInfo +-- additional convenience lenses declared in Handler.Utils.Avs due to required dependencies: +-- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) +-- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool +-- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) --- | FirmAddress is never empty, since it always includes the company name -_avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text -_avsFirmAddress = to mkAddr - where - mkAddr AvsFirmInfo{..} = - let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry - commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress - in textUnlines $ avsFirmFirm : catMaybes [commAddr <|> firmAddr] - --- Necessarily Moved to Handler.Utils.Avs due to dependencies: --- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) --- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool --- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) - +-- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead +-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text +-- _avsFirmAddress = to mkAddr +-- where +-- mkAddr AvsFirmInfo{..} = +-- let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry +-- commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress +-- in textUnlines $ avsFirmFirm : catMaybes [commAddr <|> firmAddr] instance FromJSON AvsFirmInfo where parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index d686c8e0a..e407cdd7d 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -58,6 +58,17 @@ $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " derivePersistField "Theme" +data SupervisorReason + = SupervisorReasonCompanyDefault + | SupervisorReasonUnknown + deriving (Eq, Ord, Enum, Bounded, Generic) + deriving anyclass (Universe, Finite, NFData) + +instance Show SupervisorReason where + show SupervisorReasonCompanyDefault = "Firmenstandard" + show SupervisorReasonUnknown = "Unbekannt" + + data FavouriteReason = FavouriteVisited | FavouriteParticipant diff --git a/src/Utils.hs b/src/Utils.hs index 312d19920..2f708775a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -703,6 +703,10 @@ zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys zipMaybes (_:xs) (_:ys) = zipMaybes xs ys zipMaybes _ _ = [] +bcons :: Bool -> a -> [a] -> [a] +bcons False _ = id +bcons True x = (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)] @@ -1027,12 +1031,26 @@ altM ma mb = ma >>= \case -- The first one to return a @Just@ wins. Returns @Nothing@ if all computations -- return @Nothing@. -- Copied from GHC.Data.Maybe, which could not be imported somehow. -firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) -firstJustM = foldlM go Nothing +-- HOWEVER, this function counterintuitively forces the entire foldable! +-- firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +-- firstJustM = foldlM go Nothing +-- where +-- go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) +-- go Nothing action = action +-- go result@(Just _) _action = return result + +-- | executes actions until the first one returns Just, the remaining actions are not computed; container not required to be finite +firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustM = Fold.foldr go (return Nothing) where - go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) - go Nothing action = action - go result@(Just _) _action = return result + go :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a) + go n p = n >>= \case {Nothing -> p; res -> return res} + +-- firstJustM1 :: (Monad m, MonoFoldable mono, Element mono ~ m (Maybe a)) => mono -> m (Maybe a) +-- firstJustM1 = foldr go (return Nothing) +-- where +-- go n p = n >>= \case {Nothing -> p; res -> return res} + -- | Run the maybe computation repeatedly until the first Just is returned -- or the number of maximum retries is exhausted. diff --git a/src/Utils/Persist.hs b/src/Utils/Persist.hs index e414e2924..3a03ac19b 100644 --- a/src/Utils/Persist.hs +++ b/src/Utils/Persist.hs @@ -5,6 +5,7 @@ module Utils.Persist ( fromPersistValueError , fromPersistValueErrorSql + , (~=.) ) where import ClassyPrelude @@ -37,3 +38,9 @@ fromPersistValueErrorSql :: forall p a. -> PersistValue -> Text fromPersistValueErrorSql _ = fromPersistValueError (tshow $ typeRep @a) (tshow $ sqlType (Proxy @a)) + + +infix 4 ~=. +-- | is Equal or Nothing +(~=.) :: PersistField a => EntityField v (Maybe a) -> a -> [Filter v] +(~=.) f v = [f ==. Just v] ||. [f ==. Nothing] \ No newline at end of file