-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Jobs.Handler.SynchroniseAvs ( dispatchJobSynchroniseAvs -- , dispatchJobSynchroniseAvsId -- , dispatchJobSynchroniseAvsUser , dispatchJobSynchroniseAvsQueue , dispatchJobSynchroniseAvsLicences ) where 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 ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E hiding (upsert) -- import qualified Database.Esqueleto.PostgreSQL as E 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 dispatchJobSynchroniseAvs numIterations epoch iteration pause = JobHandlerException . runDB $ do now <- liftIO getCurrentTime todos <- runConduit $ readUsers .| filterIteration now .| sinkList putMany todos $logInfoS "SynchronisAvs" [st|AVS synch summary for #{tshow numIterations}/#{tshow epoch}/#{tshow iteration}: #{length todos}|] void $ queueJob JobSynchroniseAvsQueue where readUsers :: ConduitT () UserId _ () readUsers = selectKeys [] [] filterIteration :: UTCTime -> ConduitT UserId AvsSync _ () filterIteration now = C.mapMaybeM $ \userId -> runMaybeT $ do let userIteration, currentIteration :: Integer userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations currentIteration = toInteger iteration `mod` toInteger numIterations $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] guard $ userIteration == currentIteration return $ AvsSync userId now pause -- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX -- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ -- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid) -- where -- processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause -- insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid -- dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX -- dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ workJobSychronizeAvs uid pause -- workJobSychronizeAvs :: UserId -> Maybe Day -> Handler () -- workJobSychronizeAvs uid pause = do -- now <- liftIO getCurrentTime -- -- void $ E.upsert -- -- AvsSync { avsSyncUser = uid -- -- , avsSyncCreationTime = now -- -- , avsSyncPause = pause -- -- } -- -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308 -- runDB $ maybeM -- (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause}) -- (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} -> -- update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now]) -- (getBy $ UniqueAvsSyncUser uid) -- void $ queueJob JobSynchroniseAvsQueue -- dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX -- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do -- (unlinked,linked) <- runDB $ do -- jobs <- E.select (do -- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync -- `E.leftJoin` E.table @UserAvs -- `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser) -- let pause = avsSync E.^. AvsSyncPause -- lastSync = usrAvs E.?. UserAvsLastSynch -- E.where_ $ E.isNothing pause -- E.||. E.isNothing lastSync -- E.||. pause E.>. E.dayMaybe lastSync -- return (avsSync E.^. AvsSyncId, avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId) -- ) -- let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs -- E.deleteWhere [AvsSyncId <-. syncIds] -- return (unlinked, linked) -- void $ updateAvsUserByIds linked -- void $ linktoAvsUserByUIDs unlinked -- -- we do not reschedule failed synchs here in order to avoid a loop -- where -- discernJob (accSync, accUid, accApi) (E.Value k, _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi) -- discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value Nothing ) = (k:accSync, Set.insert uid accUid, accApi) dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX dispatchJobSynchroniseAvsQueue = JobHandlerException $ do jobs <- runDBRead $ do E.select (do (avsSync :& usrAvs) <- E.from $ E.table @AvsSync `E.leftJoin` E.table @UserAvs `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser) let pause = avsSync E.^. AvsSyncPause lastSync = usrAvs E.?. UserAvsLastSynch proceed = E.isNothing pause E.||. E.isNothing lastSync E.||. pause E.>. E.dayMaybe lastSync -- E.where_ proceed -- we still want to delete all paused jobs, rather than to delay them only return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId, proceed) ) -- now <- liftIO getCurrentTime -- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing -- return jobs let (unlinked, linked) = foldl' discernJob mempty jobs $logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|] void $ updateAvsUserByIds linked void $ linktoAvsUserByUIDs unlinked runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)] $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 where discernJob accs ( _ , E.Value (Just api), E.Value True ) = accs & over _2 (Set.insert api) discernJob accs (E.Value uid, E.Value Nothing , E.Value True ) = accs & over _1 (Set.insert uid) discernJob accs ( _ , _ , E.Value False ) = accs ----------------- -- AVS Licences dispatchJobSynchroniseAvsLicences :: JobHandler UniWorX -- dispatchJobSynchroniseAvsLicences = error "TODO" dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel > 0) $ do AvsLicenceSynchConf { avsLicenceSynchLevel = synchLevel -- SynchLevel corresponds to tables of ProblemAvsSynchR: 4=top grant R, 3= reduce R->F, 2= grant F, 1= revoke F , avsLicenceSynchReasonFilter = reasonFilter , avsLicenceSynchMaxChanges = maxChanges } <- getsYesod $ view _appAvsLicenceSynchConf let -- TODO: enable a cron job by setting procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler () procLic aLic up apids | n <- Set.size apids, n > 0 = let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic logit errm = runDB $ logInterface' "AVS" subtype False (isJust errm) (Just n) (fromMaybe "Automatic synch" errm) catchAllAvs = flip catch (\err -> logit (Just $ tshow (err :: SomeException)) >> return (-1)) in if NTop (Just n) <= NTop maxChanges then do 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|] else logit $ Just [st|Too many changes at once. Consider increasing avs-licence-synch-max-changes #{tshow maxChanges}|] | otherwise = return () (AvsLicenceDifferences{..}, rsChanged) <- retrieveDifferingLicences -- prevent automatic changes to users blocked with certain reasons and with currently being associated with multiple companies multiFirmBlocks <- ifNothingM reasonFilter mempty $ \reasons -> do now <- liftIO getCurrentTime 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_ $ (qblock E.^. QualificationUserBlockReason E.~*. E.val reasons) 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