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

chore(avs): update company supervisors on avs user update

Browse Source
This commit is contained in:
Steffen Jost 2024-03-06 13:41:18 +01:00
parent 0b7175c26c
commit c179c03f9d
6 changed files with 120 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/users.model
View File

@ -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

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

@ -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

26
src/Model/Types/Avs.hs
View File

@ -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

11
src/Model/Types/Misc.hs
View File

@ -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

28
src/Utils.hs
View File

@ -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.

7
src/Utils/Persist.hs
View File

@ -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]