chore(avs): towards #124 add filter for multiple firm users with block reason '%firm%'

- also add warning to admin avs licence difference for AVS R licence holders about to be changed

src/Handler/Utils/Avs.hs

@@ -22,7 +22,7 @@ module Handler.Utils.Avs
   , computeDifferingLicences
   -- , synchAvsLicences
   , queryAvsFullStatus
-  -- , lookupAvsUser, lookupAvsUsers
+  , lookupAvsUser, lookupAvsUsers
   , AvsException(..)
   , updateReceivers
   , AvsPersonIdMapPersonCard

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

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
 

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