diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index ae750c4ba..98fc33439 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -22,7 +22,7 @@ module Handler.Utils.Avs , computeDifferingLicences -- , synchAvsLicences , queryAvsFullStatus - -- , lookupAvsUser, lookupAvsUsers + , lookupAvsUser, lookupAvsUsers , AvsException(..) , updateReceivers , AvsPersonIdMapPersonCard diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 19888e2e6..cec61ac9e 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -58,7 +58,7 @@ quserToNotify cutoff quser qblock = -- either recently become invalid with no pr E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified) )) --- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended +-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do newerBlock <- E.from $ E.table @QualificationUserBlock @@ -71,6 +71,20 @@ isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. Qualificatio )) ) +-- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended +-- variant for inner joins +isLatestBlockBefore' :: E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) +isLatestBlockBefore' qualBlock cutoff = (cutoff E.>. qualBlock E.^. QualificationUserBlockFrom) E.&&. E.notExists (do + newerBlock <- E.from $ E.table @QualificationUserBlock + E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.==. qualBlock E.^. QualificationUserBlockQualificationUser + E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff + E.&&. newerBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId + E.&&. (( newerBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom) + E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins + E.&&. (newerBlock E.^. QualificationUserBlockFrom E.==. qualBlock E.^. QualificationUserBlockFrom) + )) + ) + -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 6e346cd62..b9835ba99 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -14,6 +14,7 @@ import Import import qualified Data.Text as Text import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.Conduit.List as C import Database.Esqueleto.Experimental ((:&)(..)) @@ -25,6 +26,7 @@ import qualified Database.Esqueleto.Utils as E import Jobs.Queue import Handler.Utils.Avs +import Handler.Utils.Qualification -- pause is a date in the past; don't synch again if the last synch was after pause dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX @@ -150,13 +152,33 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids when (oks > 0) $ logit $ toMaybe (oks /= n) [st|Only #{tshow oks}/#{tshow n} licence changes accepted by AVS|] | otherwise = return () + now <- liftIO getCurrentTime (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences - let mbRemoveRs - | synchLevel >= 3 = id - | otherwise = flip Set.difference rsChanged - when (synchLevel >= 1) $ procLic AvsNoLicence False $ mbRemoveRs avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld - when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ mbRemoveRs avsLicenceDiffGrantVorfeld --grant Vorfeld - when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld - when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True avsLicenceDiffGrantRollfeld --grant Rollfeld + -- for synchLevel < 5 prevent automatic changes to users blocked with a reason mentioning "Firm" and currently being associatd with multiple companies + multiFirmBlocks <- if synchLevel >= 5 + then return mempty + else do + firmBlocks <- runDBRead $ E.select $ do + (uavs :& _qualUser :& qblock) <- E.from $ E.table @UserAvs + `E.innerJoin` E.table @QualificationUser `E.on` (\(uavs :& qualUser) -> uavs E.^. UserAvsUser E.==. qualUser E.^. QualificationUserUser) + `E.innerJoin` E.table @QualificationUserBlock `E.on` (\(_uavs :& qualUser :& qblock) -> + qualUser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser + E.&&. qblock `isLatestBlockBefore'` E.val now) + E.where_ $ (E.val ("Firm"::Text) `E.isInfixOf` qblock E.^. QualificationUserBlockReason) + E.&&. uavs E.^. UserAvsPersonId `E.in_` E.vals (avsLicenceDiffRevokeAll `Set.union` avsLicenceDiffRevokeRollfeld) + E.&&. E.not_ (qblock E.^. QualificationUserBlockUnblock) + return $ uavs E.^. UserAvsPersonId + firmBlockData <- lookupAvsUsers $ Set.fromList $ map E.unValue firmBlocks -- may throw, but we need to abort then + return $ Map.keysSet $ Map.filter hasMultipleFirms firmBlockData + + let fltrIds + | synchLevel >= 5 = id + | synchLevel >= 3 = flip Set.difference multiFirmBlocks + | otherwise = flip Set.difference $ multiFirmBlocks `Set.union` rsChanged + + when (synchLevel >= 1) $ procLic AvsNoLicence False $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld + when (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld + when (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld + when (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 636b28291..0c50360be 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -501,6 +501,10 @@ deriveJSON defaultOptions } ''AvsDataPerson -} +hasMultipleFirms :: AvsDataPerson -> Bool +hasMultipleFirms AvsDataPerson{avsPersonPersonCards=crds} = + 1 < Set.size (Set.filter isJust $ Set.map avsDataFirm crds) + data AvsPersonLicence = AvsPersonLicence { avsLicenceRampLicence :: AvsLicence , avsLicencePersonID :: AvsPersonId