191 lines
10 KiB
Haskell
191 lines
10 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- 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
|
|
|