57 lines
2.5 KiB
Haskell
57 lines
2.5 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Jobs.Handler.SynchroniseAvs
|
|
( dispatchJobSynchroniseAvs
|
|
, dispatchJobSynchroniseAvsId
|
|
, dispatchJobSynchroniseAvsUser
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Conduit.List as C
|
|
import Jobs.Queue
|
|
|
|
import Handler.Utils.Avs
|
|
|
|
dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe UTCTime -> JobHandler UniWorX
|
|
dispatchJobSynchroniseAvs numIterations epoch iteration pause
|
|
= JobHandlerAtomic . runConduit $
|
|
readUsers .| filterIteration .| sinkDBJobs
|
|
where
|
|
readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
|
|
readUsers = selectKeys [] []
|
|
|
|
filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
|
|
filterIteration = 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)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
|
|
guard $ userIteration == currentIteration
|
|
|
|
return $ JobSynchroniseAvsUser userId pause
|
|
|
|
|
|
workJobSynchroniseAvs :: Either AvsPersonId UserId -> Maybe UTCTime -> JobHandler UniWorX
|
|
workJobSynchroniseAvs eauid pause = JobHandlerException $ do
|
|
let uniqKey = either UniqueUserAvsId UniqueUserAvsUser eauid
|
|
runDB (getBy uniqKey) >>= \case
|
|
Nothing -> return () -- do not create new newers in this background job, only update existing
|
|
Just Entity{entityVal=UserAvs{..}}
|
|
| maybe False (userAvsLastSynch >=) pause -> return () -- we just updated this one within the given limit
|
|
| otherwise -> catch (void $ upsertAvsUserById userAvsPersonId) -- updates UserAvsLastSynch
|
|
(\case
|
|
AvsInterfaceUnavailable -> return () -- ignore and retry later
|
|
AvsUserUnknownByAvs _ -> return () -- ignore for users no longer listed in AVS
|
|
otherExc -> throwM otherExc
|
|
)
|
|
|
|
dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe UTCTime -> JobHandler UniWorX
|
|
dispatchJobSynchroniseAvsId = workJobSynchroniseAvs . Left
|
|
|
|
dispatchJobSynchroniseAvsUser :: UserId -> Maybe UTCTime -> JobHandler UniWorX
|
|
dispatchJobSynchroniseAvsUser = workJobSynchroniseAvs . Right
|