Compare commits
No commits in common. "master" and "v27.4.79" have entirely different histories.
19
src/Audit.hs
19
src/Audit.hs
@ -1,9 +1,7 @@
|
|||||||
-- SPDX-FileCopyrightText: 2023-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||||
--
|
--
|
||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
|
|
||||||
module Audit
|
module Audit
|
||||||
( module Audit.Types
|
( module Audit.Types
|
||||||
, AuditException(..)
|
, AuditException(..)
|
||||||
@ -19,8 +17,6 @@ import Import.NoModel
|
|||||||
import Settings
|
import Settings
|
||||||
import Model
|
import Model
|
||||||
import Database.Persist.Sql
|
import Database.Persist.Sql
|
||||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
||||||
import qualified Database.Esqueleto.Utils as E
|
|
||||||
import Audit.Types
|
import Audit.Types
|
||||||
|
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
@ -182,20 +178,15 @@ reportAdminProblem :: ( IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
|||||||
)
|
)
|
||||||
=> AdminProblem -- ^ Problem to record
|
=> AdminProblem -- ^ Problem to record
|
||||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||||
-- ^ Log a problem that needs interventions by admins, provided this problem has not already been reported and is still unsolved
|
-- ^ Log a problem that needs interventions by admins
|
||||||
--
|
--
|
||||||
-- - `problemLogTime` is now
|
-- - `problemLogTime` is now
|
||||||
-- - `problemSolver` is Nothing, we do not record the person who caused it
|
-- - `problemSolver` is Nothing, we do not record the person who caused it
|
||||||
reportAdminProblem problem = do
|
reportAdminProblem problem@(toJSON -> problemLogInfo) = do
|
||||||
|
problemLogTime <- liftIO getCurrentTime
|
||||||
let problemLogSolved = Nothing
|
let problemLogSolved = Nothing
|
||||||
problemLogSolver = Nothing
|
problemLogSolver = Nothing
|
||||||
problemLogInfo = toJSON problem
|
insert_ ProblemLog{..}
|
||||||
problemLogTime <- liftIO getCurrentTime
|
|
||||||
isKnown <- E.selectExists $ do
|
|
||||||
pl <- E.from $ E.table @ProblemLog
|
|
||||||
E.where_ $ E.isNothing (pl E.^. ProblemLogSolved)
|
|
||||||
E.&&. E.val problemLogInfo E.==. pl E.^. ProblemLogInfo
|
|
||||||
unless isKnown $ insert_ ProblemLog{..}
|
|
||||||
$logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
|
$logWarnS "Problem" $ Text.filter (/= '\n') $ tshow problem -- <> " - " <> pack (prettyCallStack callStack)
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -329,8 +329,6 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
|
|||||||
let usrId = userAvsUser usravs
|
let usrId = userAvsUser usravs
|
||||||
usr <- MaybeT $ get usrId
|
usr <- MaybeT $ get usrId
|
||||||
lift $ do -- maybeT no longer needed from here onwards
|
lift $ do -- maybeT no longer needed from here onwards
|
||||||
uuid :: CryptoUUIDUser <- encrypt usrId
|
|
||||||
$logInfoS "AVS" [st|updateAvsUserByADC: #{tshow uuid}|]
|
|
||||||
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
|
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
|
||||||
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
|
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
|
||||||
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
|
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
|
||||||
@ -382,73 +380,72 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
|
|||||||
, UserAvsLastCardNo =. newAvsCardNo
|
, UserAvsLastCardNo =. newAvsCardNo
|
||||||
]
|
]
|
||||||
|
|
||||||
usr_up2 <- guardMonoidM (oldAvsFirmInfo /= Just newAvsFirmInfo) $ do
|
-- update company association & supervision
|
||||||
-- update company association & supervision
|
newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
|
||||||
newCompanyEnt@Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
|
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
|
||||||
upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo usrId -- ensure firmInfo superior is supervisor for this user
|
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
|
||||||
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
|
let oldCompanyId = entityKey <$> oldCompanyEnt
|
||||||
primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
|
-- oldCompanyMb = entityVal <$> oldCompanyEnt
|
||||||
let oldCompanyId = entityKey <$> oldCompanyEnt
|
-- pst_up = if
|
||||||
-- oldCompanyMb = entityVal <$> oldCompanyEnt
|
-- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
|
||||||
-- pst_up = if
|
-- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||||
-- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
|
-- | isNothing oldCompanyMb
|
||||||
-- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
-- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
||||||
-- | isNothing oldCompanyMb
|
-- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
|
||||||
-- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
|
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
|
||||||
-- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
|
-- | otherwise
|
||||||
-- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
|
-- -> Nothing
|
||||||
-- | otherwise
|
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||||
-- -> Nothing
|
newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
|
||||||
newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
|
||||||
|
|
||||||
case oldAvsFirmInfo of
|
usr_up2 <- case oldAvsFirmInfo of
|
||||||
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
|
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
|
||||||
-> return mempty -- => do nothing
|
-> return mempty -- => do nothing
|
||||||
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
|
(Just oafi) | isJust (view _avsFirmPostAddressSimple oafi)
|
||||||
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|
&& ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- non-empty company address unchanged OR
|
||||||
|| isJust (view _avsFirmPrimaryEmail oafi)
|
|| isJust (view _avsFirmPrimaryEmail oafi)
|
||||||
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
|
&& ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- non-empty company primary email unchanged
|
||||||
-> do -- => just update user company association, keeping supervision privileges
|
-> do -- => just update user company association, keeping supervision privileges
|
||||||
case oldCompanyId of
|
case oldCompanyId of
|
||||||
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
|
Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists
|
||||||
Just ocid -> do
|
Just ocid -> do
|
||||||
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
|
void $ upsertBySafe (UniqueUserCompany usrId ocid) newUserComp (_userCompanyCompany .~ newCompanyId) -- keep default supervisor settings
|
||||||
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
|
void $ updateWhere [ UserSupervisorSupervisor ==. usrId -- update company-related supervisions
|
||||||
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
|
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
|
||||||
, UserSupervisorReason ==. Just superReasonComDef] -- user
|
, UserSupervisorReason ==. Just superReasonComDef] -- user
|
||||||
[ UserSupervisorCompany =. Just newCompanyId]
|
[ UserSupervisorCompany =. Just newCompanyId]
|
||||||
return mempty
|
return mempty
|
||||||
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
|
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
|
||||||
-> do
|
-> do
|
||||||
whenIsJust oldCompanyId $ \oldCid -> do
|
whenIsJust oldCompanyId $ \oldCid -> do
|
||||||
deleteBy $ UniqueUserCompany usrId oldCid
|
deleteBy $ UniqueUserCompany usrId oldCid
|
||||||
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
|
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
|
||||||
return mempty
|
return mempty
|
||||||
_ -- company changed completely
|
_ -- company changed completely
|
||||||
-> do
|
-> do
|
||||||
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
|
(pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
|
||||||
mapM_ reportAdminProblem problems
|
mapM_ reportAdminProblem problems
|
||||||
-- Following line does not type, hence additional parameter needed
|
-- Following line does not type, hence additional parameter needed
|
||||||
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
|
-- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
|
||||||
return pst_up
|
return pst_up
|
||||||
-- SPECIALISED CODE, PROBABLY DEPRECATED
|
-- SPECIALISED CODE, PROBABLY DEPRECATED
|
||||||
-- switch user company, keeping old priority
|
-- switch user company, keeping old priority
|
||||||
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
|
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
|
||||||
-- Nothing ->
|
-- Nothing ->
|
||||||
-- void $ insertUnique newUserComp
|
-- void $ insertUnique newUserComp
|
||||||
-- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
|
-- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
|
||||||
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
|
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
|
||||||
-- delete ucidOld
|
-- delete ucidOld
|
||||||
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
||||||
-- -- adjust supervison
|
-- -- adjust supervison
|
||||||
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
||||||
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
|
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
|
||||||
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
|
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
|
||||||
-- addDefaultSupervisors' newCompanyId $ singleton usrId
|
-- addDefaultSupervisors' newCompanyId $ singleton usrId
|
||||||
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
||||||
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
||||||
-- return pst_up
|
-- return pst_up
|
||||||
|
upsertCompanySuperior newCompanyEnt newAvsFirmInfo oldAvsFirmInfo [usrId] -- ensure firmInfo superior is supervisor for this user
|
||||||
update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2)
|
update usrId usr_up2 -- update user by company switch first (due to possible conflicts with usr_up2)
|
||||||
update usrId usr_up1 -- update user eventually
|
update usrId usr_up1 -- update user eventually
|
||||||
update uaId avs_ups -- update stored avsinfo for future updates
|
update uaId avs_ups -- update stored avsinfo for future updates
|
||||||
@ -588,18 +585,16 @@ getAvsCompany afi =
|
|||||||
|
|
||||||
-- | 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
|
||||||
upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
|
upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Entity Company)
|
||||||
-- upsertAvsCompany newAvsFirmInfo (Just oldAvsFirmInfo)
|
|
||||||
-- | newAvsFirmInfo == oldAvsFirmInfo = maybeM (upsertAvsCompany newAvsFirmInfo Nothing) pure $ getAvsCompany newAvsFirmInfo -- firmInfo unchanged, shortcircuit; SHORTCIRCUIT no longer needed, checked at call-site due to result not being wrapped in Maybe
|
|
||||||
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
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 mbOldAvsFirmInfo} new #{tshow newAvsFirmInfo} ent-new #{tshow mbFirmEnt}|]
|
$logInfoS "AVS" [st|upsertAvsCompany: old #{tshow mbFirmEnt} new #{tshow newAvsFirmInfo}|]
|
||||||
case mbFirmEnt of
|
case (mbFirmEnt, mbOldAvsFirmInfo) of
|
||||||
Nothing -> do -- insert new company, neither AvsId nor Shorthand exist in DB
|
(Nothing, _) -> do -- insert new company, neither AvsId nor Shorthand exist in DB
|
||||||
afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
|
afn <- if 0 < newAvsFirmInfo ^. _avsFirmFirmNo
|
||||||
then return $ newAvsFirmInfo ^. _avsFirmFirmNo
|
then return $ newAvsFirmInfo ^. _avsFirmFirmNo
|
||||||
else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
|
else maybe (-1) (pred . companyAvsId . entityVal) <$> selectMaybe [CompanyAvsId <. 0] [Asc CompanyAvsId]
|
||||||
let upd = flip updateRecord newAvsFirmInfo
|
let upd = flip updateRecord newAvsFirmInfo
|
||||||
dmy = Company -- mostly dummy, values are actually produced 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 = afn
|
, companyAvsId = afn
|
||||||
@ -611,12 +606,11 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
|||||||
$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
|
||||||
|
$logInfoS "AVS" "Insert new company completed."
|
||||||
return newCmp
|
return newCmp
|
||||||
|
|
||||||
(Just Entity{entityKey=firmid, entityVal=firm}) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and identical AvsFirmNo and changes occurred
|
(Just Entity{entityKey=firmid, entityVal=firm}, oldAvsFirmInfo) -> do -- possibly update existing company, if isJust oldAvsFirmInfo and changed occurred
|
||||||
let oldHasSameFirmNo = Just (newAvsFirmInfo ^. _avsFirmFirmNo) == (mbOldAvsFirmInfo ^? _Just . _avsFirmFirmNo)
|
let cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
||||||
oldAvsFirmInfo = guardOnM oldHasSameFirmNo mbOldAvsFirmInfo
|
|
||||||
cmp_ups = mapMaybe (mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
|
|
||||||
key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key
|
key_ups = mkUpdate' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2key
|
||||||
uniq_ups <- mkUpdateCheckUnique' firm newAvsFirmInfo oldAvsFirmInfo firmInfo2companyNo
|
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}|]
|
$logInfoS "AVS" [st|Update company #{companyShorthand firm}: #{tshow (length cmp_ups)}, #{tshow (length key_ups)}, #{tshow (length uniq_ups)} for #{tshow oldAvsFirmInfo}|]
|
||||||
@ -635,7 +629,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
|||||||
| otherwise -> $logInfoS "AVS" $ "Update company shorthand failed for " <> ciOriginal cmp_key <> " and " <> ciOriginal 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
|
maybeM (return res_cmp) return $ getBy uniq_cmp
|
||||||
_otherwise -> return res_cmp
|
_otherwise -> return res_cmp
|
||||||
$logInfoS "AVS" [st|Update company #{companyShorthand firm} completed.|]
|
$logInfoS "AVS" "Update company completed."
|
||||||
return res_cmp2
|
return res_cmp2
|
||||||
where
|
where
|
||||||
firmInfo2key =
|
firmInfo2key =
|
||||||
@ -651,8 +645,8 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
|
|||||||
|
|
||||||
|
|
||||||
-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
|
-- | adjust superiors, assumes that CompanyUser exists for all usrs for given company; does not work otherwise
|
||||||
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> UserId -> DB () -- may return superior (Maybe UserId), but currently not needed
|
upsertCompanySuperior :: Entity Company -> AvsFirmInfo -> Maybe AvsFirmInfo -> [UserId] -> DB () -- may return superior (Maybe UserId), but currently not needed
|
||||||
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrId =
|
upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi usrs =
|
||||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||||
getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
|
getInsertUid eml = altM (guessUserByEmail $ stripCI eml) (catchAll2log' $ Just . entityKey <$> ldapLookupAndUpsert eml)
|
||||||
newAvsNo = newAfi ^. _avsFirmFirmNo
|
newAvsNo = newAfi ^. _avsFirmFirmNo
|
||||||
@ -661,26 +655,22 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u
|
|||||||
mbOldEmail = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
|
mbOldEmail = oldAfi ^? _Just . _avsFirmEMailSuperior . _Just
|
||||||
getSupId = getInsertUid `traverseJoin` mbSupEmail
|
getSupId = getInsertUid `traverseJoin` mbSupEmail
|
||||||
getOldId = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
|
getOldId = (guessUserByEmail . stripCI) `traverseJoin` mbOldEmail
|
||||||
getSupervision :: Maybe UserId -> DB (Maybe (Entity UserSupervisor))
|
unchangedCompany = oldAvsNo == Just newAvsNo
|
||||||
getSupervision = traverseJoin (getBy . flip UniqueUserSupervisor usrId)
|
changedSuperior = mbSupEmail /= mbOldEmail -- beware, both could be Nothing
|
||||||
unchangedCompany = oldAvsNo == Just newAvsNo
|
|
||||||
changedSuperior = mbSupEmail /= mbOldEmail -- beware we only have AvsFirmInfo for one user; also both could be Nothing
|
|
||||||
-- 1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
|
-- 1. not unchangedCompany: do not delete, but ensure that superior supervision is set, since it could be a just a single user company change
|
||||||
-- 2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
|
-- 2. unchangedCompany && not changedSuperior: superior must already been set, short-circuit
|
||||||
-- 3. unchangedCompany && changedSuperior: update superior for all users
|
-- 3. unchangedCompany && changedSuperior: update superior for all users
|
||||||
in unless (unchangedCompany && not changedSuperior) $ do -- do nothing if (unchangedCompany && not changedSuperior).
|
in unless (unchangedCompany && not changedSuperior) $ do -- do nothing if (unchangedCompany && not changedSuperior).
|
||||||
mbSupId <- getSupId
|
mbSupId <- getSupId
|
||||||
mbUsrSup <- getSupervision mbSupId
|
|
||||||
-- delete old superiors, if any
|
-- delete old superiors, if any
|
||||||
when (unchangedCompany && changedSuperior) $
|
when (unchangedCompany && changedSuperior) $
|
||||||
deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
|
deleteWhere $ mcons ((UserSupervisorSupervisor !=.) <$> mbSupId)
|
||||||
[ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
|
[ UserSupervisorCompany ==. Just cid, UserSupervisorReason ==. reasonSuperior ]
|
||||||
unless unchangedCompany $
|
unless unchangedCompany $
|
||||||
deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser ==. usrId ]
|
deleteWhere [ UserSupervisorReason ==. reasonSuperior, UserSupervisorUser <-. usrs ]
|
||||||
-- ensure superior supervision
|
-- ensure superior supervision
|
||||||
case (mbSupId, mbUsrSup) of
|
case mbSupId of
|
||||||
(_ , Just _) -> return () -- supId is already supervisor for uid for any reason
|
Just supId -> do
|
||||||
(Just supId, Nothing) -> do
|
|
||||||
-- ensure association between company and superior at equal-to-top priority
|
-- ensure association between company and superior at equal-to-top priority
|
||||||
prio <- getCompanyUserMaxPrio supId
|
prio <- getCompanyUserMaxPrio supId
|
||||||
void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
|
void $ insertUnique (UserCompany supId cid False False prio True reasonSuperior) -- superior is not a supervisor, do not change existing user company associations
|
||||||
@ -712,7 +702,7 @@ upsertCompanySuperior Entity{entityKey=cid, entityVal=Company{}} newAfi oldAfi u
|
|||||||
when (unchangedCompany && changedSuperior) $ do
|
when (unchangedCompany && changedSuperior) $ do
|
||||||
oldSupId <- getOldId
|
oldSupId <- getOldId
|
||||||
reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
|
reportAdminProblem $ AdminProblemCompanySuperiorChange supId cid oldSupId
|
||||||
(Nothing, Nothing) ->
|
Nothing ->
|
||||||
when (unchangedCompany && changedSuperior) $ do
|
when (unchangedCompany && changedSuperior) $ do
|
||||||
oldSupId <- getOldId
|
oldSupId <- getOldId
|
||||||
reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
|
reportAdminProblem $ AdminProblemCompanySuperiorNotFound mbSupEmail cid oldSupId
|
||||||
|
|||||||
@ -122,11 +122,11 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
|
|||||||
-- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
|
-- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
|
||||||
-- return jobs
|
-- return jobs
|
||||||
let (unlinked, linked) = foldl' discernJob mempty jobs
|
let (unlinked, linked) = foldl' discernJob mempty jobs
|
||||||
$logInfoS "SynchronisAvs" [st|AVS synch start for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
$logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||||
void $ updateAvsUserByIds linked
|
void $ updateAvsUserByIds linked
|
||||||
void $ linktoAvsUserByUIDs unlinked
|
void $ linktoAvsUserByUIDs unlinked
|
||||||
runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
|
runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
|
||||||
$logInfoS "SynchronisAvs" [st|AVS synch end for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
$logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
|
||||||
-- we do not reschedule failed synchs here in order to avoid a loop
|
-- we do not reschedule failed synchs here in order to avoid a loop
|
||||||
where
|
where
|
||||||
discernJob accs ( _ , E.Value (Just api), E.Value True ) = accs & over _2 (Set.insert api)
|
discernJob accs ( _ , E.Value (Just api), E.Value True ) = accs & over _2 (Set.insert api)
|
||||||
|
|||||||
Reference in New Issue
Block a user