fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: improve logging/metrics wrt. batch jobs

Browse Source
This commit is contained in:
Gregor Kleen 2020-09-21 13:31:53 +02:00
parent 8afacdd6b7
commit d21faf4de0
7 changed files with 327 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Jobs.hs
View File

@ -102,6 +102,7 @@ handleJobs foundation@UniWorX{..}
jobCurrentCrontab <- liftIO $ newTVarIO Nothing jobCurrentCrontab <- liftIO $ newTVarIO Nothing
jobHeldLocks <- liftIO $ newTVarIO Set.empty jobHeldLocks <- liftIO $ newTVarIO Set.empty
registerJobHeldLocksCount jobHeldLocks registerJobHeldLocksCount jobHeldLocks
registerJobWorkerQueueDepth appJobState
atomically $ putTMVar appJobState JobState atomically $ putTMVar appJobState JobState
{ jobContext = JobContext{..} { jobContext = JobContext{..}
, .. , ..
@ -452,6 +453,12 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
JobHandlerException act -> do JobHandlerException act -> do
act & withJobWorkerState wNum (JobWorkerExecJob content) act & withJobWorkerState wNum (JobWorkerExecJob content)
runDB $ setSerializable cleanup runDB $ setSerializable cleanup
JobHandlerAtomicWithFinalizer act fin -> do
res <- runDBJobs . setSerializable $ do
res <- act & withJobWorkerState wNum (JobWorkerExecJob content)
hoist lift cleanup
return res
fin res
handleCmd JobCtlDetermineCrontab = do handleCmd JobCtlDetermineCrontab = do
newCTab <- liftHandler . runDB $ setSerializable determineCrontab' newCTab <- liftHandler . runDB $ setSerializable determineCrontab'
-- logDebugS logIdent $ tshow newCTab -- logDebugS logIdent $ tshow newCTab

326
src/Jobs/Handler/Files.hs
View File

@ -34,11 +34,13 @@ import Handler.Utils.Files (sourceFileDB)
dispatchJobPruneSessionFiles :: JobHandler UniWorX dispatchJobPruneSessionFiles :: JobHandler UniWorX
dispatchJobPruneSessionFiles = JobHandlerAtomic . hoist lift $ do dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin
now <- liftIO getCurrentTime where
expires <- getsYesod $ view _appSessionFilesExpire act = hoist lift $ do
n <- deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ] now <- liftIO getCurrentTime
$logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|] expires <- getsYesod $ view _appSessionFilesExpire
deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ]
fin n = $logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|]
@ -64,142 +66,146 @@ pruneUnreferencedFilesIntervalsCache :: TVar (Map Natural [(Maybe FileContentChu
pruneUnreferencedFilesIntervalsCache = unsafePerformIO $ newTVarIO Map.empty pruneUnreferencedFilesIntervalsCache = unsafePerformIO $ newTVarIO Map.empty
dispatchJobPruneUnreferencedFiles :: Natural -> Natural -> Natural -> JobHandler UniWorX dispatchJobPruneUnreferencedFiles :: Natural -> Natural -> Natural -> JobHandler UniWorX
dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtomic . hoist lift $ do dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtomicWithFinalizer act fin
now <- liftIO getCurrentTime where
interval <- getsYesod $ view _appPruneUnreferencedFilesInterval act = hoist lift $ do
keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles now <- liftIO getCurrentTime
interval <- getsYesod $ view _appPruneUnreferencedFilesInterval
keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles
let let
chunkHashBytes :: forall h. chunkHashBytes :: forall h.
( Unwrapped FileContentChunkReference ~ Digest h ) ( Unwrapped FileContentChunkReference ~ Digest h )
=> Integer => Integer
chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h)) chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h))
chunkHashBits = chunkHashBytes * 8 chunkHashBits = chunkHashBytes * 8
base :: Integer base :: Integer
base = 2 ^ chunkHashBits base = 2 ^ chunkHashBits
intervals :: [Integer] intervals :: [Integer]
-- | Exclusive upper bounds
intervals
| numIterations <= 0 = pure base
| otherwise = go protoIntervals ^.. folded . _1
where
go [] = []
go ints
| maximumOf (folded . _1) ints == Just base = ints
| otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts
where
closest = maximumBy (comparing $ view _2) ints
(lts, geqs) = partition (((>) `on` view _1) closest) ints
gts = filter (((<) `on` view _1) closest) geqs
-- | Exclusive upper bounds -- | Exclusive upper bounds
protoIntervals :: [(Integer, Integer)] intervals
protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations | numIterations <= 0 = pure base
| i <- [1 .. toInteger numIterations] | otherwise = go protoIntervals ^.. folded . _1
] where
go [] = []
go ints
| maximumOf (folded . _1) ints == Just base = ints
| otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts
where
closest = maximumBy (comparing $ view _2) ints
(lts, geqs) = partition (((>) `on` view _1) closest) ints
gts = filter (((<) `on` view _1) closest) geqs
-- | Exclusive upper bounds
protoIntervals :: [(Integer, Integer)]
protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations
| i <- [1 .. toInteger numIterations]
]
intervalsDgsts' = zipWith (curry . over both $ toDigest <=< assertM' (> 0)) (0 : init intervals) intervals intervalsDgsts' = zipWith (curry . over both $ toDigest <=< assertM' (> 0)) (0 : init intervals) intervals
toDigest :: Integer -> Maybe FileContentChunkReference toDigest :: Integer -> Maybe FileContentChunkReference
toDigest = fmap (review _Wrapped) . digestFromByteString . pad . ByteString.pack . reverse . unfoldr step toDigest = fmap (review _Wrapped) . digestFromByteString . pad . ByteString.pack . reverse . unfoldr step
where step i where step i
| i <= 0 = Nothing | i <= 0 = Nothing
| otherwise = Just (fromIntegral i, i `shiftR` 8) | otherwise = Just (fromIntegral i, i `shiftR` 8)
pad bs pad bs
| toInteger (ByteString.length bs) >= chunkHashBytes = bs | toInteger (ByteString.length bs) >= chunkHashBytes = bs
| otherwise = pad $ ByteString.cons 0 bs | otherwise = pad $ ByteString.cons 0 bs
intervalsDgsts <- atomically $ do intervalsDgsts <- atomically $ do
cachedDgsts <- readTVar pruneUnreferencedFilesIntervalsCache cachedDgsts <- readTVar pruneUnreferencedFilesIntervalsCache
case Map.lookup numIterations cachedDgsts of case Map.lookup numIterations cachedDgsts of
Just c -> return c Just c -> return c
Nothing -> do Nothing -> do
modifyTVar' pruneUnreferencedFilesIntervalsCache $ force . Map.insert numIterations intervalsDgsts' modifyTVar' pruneUnreferencedFilesIntervalsCache $ force . Map.insert numIterations intervalsDgsts'
return intervalsDgsts' return intervalsDgsts'
let let
permIntervalsDgsts = shuffleM intervalsDgsts `evalRand` mkStdGen (hash epoch) permIntervalsDgsts = shuffleM intervalsDgsts `evalRand` mkStdGen (hash epoch)
(minBoundDgst, maxBoundDgst) = permIntervalsDgsts !! fromIntegral (toInteger iteration `mod` genericLength permIntervalsDgsts)
chunkIdFilter :: E.SqlExpr (E.Value FileContentChunkReference) -> E.SqlExpr (E.Value Bool)
chunkIdFilter cRef = E.and $ catMaybes
[ minBoundDgst <&> \b -> cRef E.>=. E.val b
, maxBoundDgst <&> \b -> cRef E.<. E.val b
]
$logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst) (minBoundDgst, maxBoundDgst) = permIntervalsDgsts !! fromIntegral (toInteger iteration `mod` genericLength permIntervalsDgsts)
chunkIdFilter :: E.SqlExpr (E.Value FileContentChunkReference) -> E.SqlExpr (E.Value Bool)
E.insertSelectWithConflict chunkIdFilter cRef = E.and $ catMaybes
(UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint") [ minBoundDgst <&> \b -> cRef E.>=. E.val b
(E.from $ \fileContentChunk -> do , maxBoundDgst <&> \b -> cRef E.<. E.val b
E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do ]
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId
$logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst)
E.insertSelectWithConflict
(UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint")
(E.from $ \fileContentChunk -> do
E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId
return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash
E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash
return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now
)
(\current excluded ->
[ FileContentChunkUnreferencedSince E.=. E.min (current E.^. FileContentChunkUnreferencedSince) (excluded E.^. FileContentChunkUnreferencedSince) ]
)
E.delete . E.from $ \fileContentChunkUnreferenced -> do
E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash
E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now
)
(\current excluded ->
[ FileContentChunkUnreferencedSince E.=. E.min (current E.^. FileContentChunkUnreferencedSince) (excluded E.^. FileContentChunkUnreferencedSince) ]
)
E.delete . E.from $ \fileContentChunkUnreferenced -> do let
E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do
return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash
E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
return . E.max_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince
E.where_ $ E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) unreferencedSince
let E.groupBy $ fileContentEntry E.^. FileContentEntryHash
getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryHash ]
let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do
E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash
E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
return . E.max_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince
E.where_ $ E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) unreferencedSince
E.groupBy $ fileContentEntry E.^. FileContentEntryHash return $ fileContentEntry E.^. FileContentEntryHash
E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryHash ]
return $ fileContentEntry E.^. FileContentEntryHash
deleteEntry :: _ -> DB (Sum Natural) deleteEntry :: _ -> DB (Sum Natural)
deleteEntry (E.Value fRef) = deleteEntry (E.Value fRef) =
bool 0 1 . (> 0) <$> deleteWhereCount [FileContentEntryHash ==. fRef] bool 0 1 . (> 0) <$> deleteWhereCount [FileContentEntryHash ==. fRef]
Sum deletedEntries <- runConduit $
getEntryCandidates
.| takeWhileTime (interval / 3)
.| C.mapM deleteEntry
.| C.fold
when (deletedEntries > 0) $
$logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedEntries} long-unreferenced files|]
let
getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do
E.where_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.<. E.val (addUTCTime (-keep) now)
E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry ->
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
return ( fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash Sum deletedEntries <- runConduit $
, E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash $ E.length_ . (E.^. FileContentChunkContent) getEntryCandidates
) .| takeWhileTime (interval / 3)
.| C.mapM deleteEntry
.| C.fold
deleteChunk :: _ -> DB (Sum Natural, Sum Word64) let
deleteChunk (E.Value cRef, E.Value size) = do getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do
deleteWhere [ FileContentChunkUnreferencedHash ==. cRef ] E.where_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.<. E.val (addUTCTime (-keep) now)
(, Sum size) . fromIntegral <$> deleteWhereCount [FileContentChunkHash ==. unFileContentChunkKey cRef] E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry ->
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
(Sum deletedChunks, Sum deletedChunkSize) <- runConduit $ E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
getChunkCandidates
.| takeWhileTime (interval / 3)
.| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64)
.| C.mapM deleteChunk
.| C.fold
when (deletedChunks > 0 || deletedChunkSize > 0) $ return ( fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
$logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{tshow deletedChunkSize} bytes)|] , E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash $ E.length_ . (E.^. FileContentChunkContent)
)
deleteChunk :: _ -> DB (Sum Natural, Sum Word64)
deleteChunk (E.Value cRef, E.Value size) = do
deleteWhere [ FileContentChunkUnreferencedHash ==. cRef ]
(, Sum size) . fromIntegral <$> deleteWhereCount [FileContentChunkHash ==. unFileContentChunkKey cRef]
(Sum deletedChunks, Sum deletedChunkSize) <- runConduit $
getChunkCandidates
.| takeWhileTime (interval / 3)
.| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64)
.| C.mapM deleteChunk
.| C.fold
return (deletedEntries, deletedChunks, deletedChunkSize)
fin (deletedEntries, deletedChunks, deletedChunkSize) = do
observeDeletedUnreferencedFiles deletedEntries
$logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedEntries} long-unreferenced files|]
observeDeletedUnreferencedChunks deletedChunks deletedChunkSize
$logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{tshow deletedChunkSize} bytes)|]
dispatchJobInjectFiles :: JobHandler UniWorX dispatchJobInjectFiles :: JobHandler UniWorX
@ -245,10 +251,10 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
.| maybe (C.map id) (takeWhileTime . (/ 2)) interval .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
.| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize) .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize)
.| C.mapM (lift . injectOrDelete) .| C.mapM (lift . injectOrDelete)
.| C.mapM (\res@(Sum inj, Sum sz) -> res <$ observeRechunkedFiles inj sz)
.| C.fold .| C.fold
when (injectedFiles > 0 || injectedSize > 0) $ $logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{tshow injectedSize} bytes)|]
$logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{tshow injectedSize} bytes)|]
data RechunkFileException data RechunkFileException
@ -258,38 +264,42 @@ data RechunkFileException
deriving anyclass (Exception) deriving anyclass (Exception)
dispatchJobRechunkFiles :: JobHandler UniWorX dispatchJobRechunkFiles :: JobHandler UniWorX
dispatchJobRechunkFiles = JobHandlerAtomic . hoist lift $ do dispatchJobRechunkFiles = JobHandlerAtomicWithFinalizer act fin
interval <- getsYesod $ view _appRechunkFiles where
let act = hoist lift $ do
getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> E.distinctOnOrderBy [E.asc $ fileContentEntry E.^. FileContentEntryHash] $ do interval <- getsYesod $ view _appRechunkFiles
E.where_ . E.exists . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do let
E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> E.distinctOnOrderBy [E.asc $ fileContentEntry E.^. FileContentEntryHash] $ do
E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash E.where_ . E.exists . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do
E.where_ . E.not_ $ fileContentChunk E.^. FileContentChunkContentBased
let size = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do
E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash
E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash
return $ E.sum_ (E.length_ $ fileContentChunk E.^. FileContentChunkContent:: E.SqlExpr (E.Value Word64)) E.where_ . E.not_ $ fileContentChunk E.^. FileContentChunkContentBased
return ( fileContentEntry E.^. FileContentEntryHash
, size
)
rechunkFile :: FileContentReference -> Word64 -> DB (Sum Natural, Sum Word64) let size = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do
rechunkFile fRef sz = do E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash
fRef' <- sinkFileDB True $ sourceFileDB fRef E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash
unless (fRef == fRef') $ return $ E.sum_ (E.length_ $ fileContentChunk E.^. FileContentChunkContent:: E.SqlExpr (E.Value Word64))
throwM $ RechunkFileExceptionHashMismatch fRef fRef'
return (Sum 1, Sum sz)
(Sum rechunkedFiles, Sum rechunkedSize) <- runConduit $ return ( fileContentEntry E.^. FileContentEntryHash
getEntryCandidates , size
.| C.mapMaybe (\(E.Value fRef, E.Value sz) -> (fRef, ) <$> sz) )
.| maybe (C.map id) (takeWhileTime . (/ 2)) interval
.| persistentTokenBucketTakeC' TokenBucketRechunkFiles (view _2 :: _ -> Word64) rechunkFile :: FileContentReference -> Word64 -> DB (Sum Natural, Sum Word64)
.| C.mapM (uncurry rechunkFile) rechunkFile fRef sz = do
.| C.fold fRef' <- sinkFileDB True $ sourceFileDB fRef
unless (fRef == fRef') $
when (rechunkedFiles > 0 || rechunkedSize > 0) $ throwM $ RechunkFileExceptionHashMismatch fRef fRef'
$logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedFiles} files in database (#{tshow rechunkedSize} bytes)|] return (Sum 1, Sum sz)
(Sum rechunkedFiles, Sum rechunkedSize) <- runConduit $
getEntryCandidates
.| C.mapMaybe (\(E.Value fRef, E.Value sz) -> (fRef, ) <$> sz)
.| maybe (C.map id) (takeWhileTime . (/ 2)) interval
.| persistentTokenBucketTakeC' TokenBucketRechunkFiles (view _2 :: _ -> Word64)
.| C.mapM (uncurry rechunkFile)
.| C.fold
return (rechunkedFiles, rechunkedSize)
fin (rechunkedFiles, rechunkedSize) = do
observeRechunkedFiles rechunkedFiles rechunkedSize
$logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedFiles} files in database (#{tshow rechunkedSize} bytes)|]

12
src/Jobs/Handler/PersonalisedSheetFiles.hs
View File

@ -8,8 +8,10 @@ import Database.Persist.Sql (deleteWhereCount)
dispatchJobPruneFallbackPersonalisedSheetFilesKeys :: JobHandler UniWorX dispatchJobPruneFallbackPersonalisedSheetFilesKeys :: JobHandler UniWorX
dispatchJobPruneFallbackPersonalisedSheetFilesKeys = JobHandlerAtomic . hoist lift $ do dispatchJobPruneFallbackPersonalisedSheetFilesKeys = JobHandlerAtomicWithFinalizer act fin
now <- liftIO getCurrentTime where
expires <- getsYesod $ view _appFallbackPersonalisedSheetFilesKeysExpire act = hoist lift $ do
n <- deleteWhereCount [ FallbackPersonalisedSheetFilesKeyGenerated <. addUTCTime (- expires) now ] now <- liftIO getCurrentTime
$logInfoS "PruneFallbackPersonalisedSheetFilesKeys" [st|Deleted #{n} expired fallback personalised sheet files keys|] expires <- getsYesod $ view _appFallbackPersonalisedSheetFilesKeysExpire
deleteWhereCount [ FallbackPersonalisedSheetFilesKeyGenerated <. addUTCTime (- expires) now ]
fin n = $logInfoS "PruneFallbackPersonalisedSheetFilesKeys" [st|Deleted #{n} expired fallback personalised sheet files keys|]

10
src/Jobs/Handler/PruneInvitations.hs
View File

@ -7,7 +7,9 @@ import Import
import Database.Persist.Sql (deleteWhereCount) import Database.Persist.Sql (deleteWhereCount)
dispatchJobPruneInvitations :: JobHandler UniWorX dispatchJobPruneInvitations :: JobHandler UniWorX
dispatchJobPruneInvitations = JobHandlerAtomic . hoist lift $ do dispatchJobPruneInvitations = JobHandlerAtomicWithFinalizer act fin
now <- liftIO getCurrentTime where
n <- deleteWhereCount [ InvitationExpiresAt <. Just now ] act = hoist lift $ do
$logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|] now <- liftIO getCurrentTime
deleteWhereCount [ InvitationExpiresAt <. Just now ]
fin n = $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|]

40
src/Jobs/Handler/TransactionLog.hs
View File

@ -9,23 +9,27 @@ import Handler.Utils.DateTime
import Database.Persist.Sql (updateWhereCount, deleteWhereCount) import Database.Persist.Sql (updateWhereCount, deleteWhereCount)
dispatchJobTruncateTransactionLog, dispatchJobDeleteTransactionLogIPs :: JobHandler UniWorX dispatchJobTruncateTransactionLog, dispatchJobDeleteTransactionLogIPs :: JobHandler UniWorX
dispatchJobTruncateTransactionLog = JobHandlerAtomic . hoist lift $ do dispatchJobTruncateTransactionLog = JobHandlerAtomicWithFinalizer act fin
now <- liftIO getCurrentTime where
let localNow = utcToLocalTime now act = hoist lift $ do
(localCurrentYear, _, _) = toGregorian $ localDay localNow now <- liftIO getCurrentTime
localStartOfPreviousYear = LocalTime (fromGregorian (pred localCurrentYear) 1 1) midnight let localNow = utcToLocalTime now
(currentYear, _, _) = toGregorian $ utctDay now (localCurrentYear, _, _) = toGregorian $ localDay localNow
startOfPreviousYear = UTCTime (fromGregorian (pred currentYear) 1 1) 0 localStartOfPreviousYear = LocalTime (fromGregorian (pred localCurrentYear) 1 1) midnight
startOfPreviousYear' = case localTimeToUTC localStartOfPreviousYear of (currentYear, _, _) = toGregorian $ utctDay now
LTUUnique utc' _ -> utc' startOfPreviousYear = UTCTime (fromGregorian (pred currentYear) 1 1) 0
_other -> startOfPreviousYear startOfPreviousYear' = case localTimeToUTC localStartOfPreviousYear of
LTUUnique utc' _ -> utc'
_other -> startOfPreviousYear
n <- deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ] deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ]
$logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|] fin n = $logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|]
dispatchJobDeleteTransactionLogIPs = JobHandlerAtomic . hoist lift $ do dispatchJobDeleteTransactionLogIPs = JobHandlerAtomicWithFinalizer act fin
now <- liftIO getCurrentTime where
retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime act = hoist lift $ do
let cutoff = addUTCTime (- retentionTime) now now <- liftIO getCurrentTime
retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime
let cutoff = addUTCTime (- retentionTime) now
n <- updateWhereCount [ TransactionLogTime <. cutoff, TransactionLogRemote !=. Nothing ] [ TransactionLogRemote =. Nothing ] updateWhereCount [ TransactionLogTime <. cutoff, TransactionLogRemote !=. Nothing ] [ TransactionLogRemote =. Nothing ]
$logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|] fin n = $logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|]

29
src/Jobs/Types.hs
View File

@ -11,11 +11,10 @@ module Jobs.Types
, JobContext(..) , JobContext(..)
, JobState(..) , JobState(..)
, jobWorkerNames , jobWorkerNames
, JobWorkerState(..) , JobWorkerState(..), _jobWorkerJobCtl, _jobWorkerJob
, withJobWorkerState
, JobWorkerId , JobWorkerId
, showWorkerId, newWorkerId , showWorkerId, newWorkerId
, JobQueue, jqInsert, jqDequeue , JobQueue, jqInsert, jqDequeue, jqDepth
, JobPriority(..), prioritiseJob , JobPriority(..), prioritiseJob
, jobNoQueueSame , jobNoQueueSame
, module Cron , module Cron
@ -38,10 +37,6 @@ import qualified Data.Set as Set
import Data.PQueue.Prio.Max (MaxPQueue) import Data.PQueue.Prio.Max (MaxPQueue)
import qualified Data.PQueue.Prio.Max as PQ import qualified Data.PQueue.Prio.Max as PQ
import Utils.Metrics (withJobWorkerStateLbls)
import qualified Prometheus (Label4)
import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone) import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
@ -179,7 +174,8 @@ type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJo
data JobHandler site data JobHandler site
= JobHandlerAtomic (YesodJobDB site ()) = JobHandlerAtomic (YesodJobDB site ())
| JobHandlerException (HandlerFor site ()) | JobHandlerException (HandlerFor site ())
deriving (Generic, Typeable) | forall a. JobHandlerAtomicWithFinalizer (YesodJobDB site a) (a -> HandlerFor site ())
deriving (Typeable)
makePrisms ''JobHandler makePrisms ''JobHandler
@ -199,20 +195,6 @@ deriveJSON defaultOptions
, sumEncoding = TaggedObject "state" "data" , sumEncoding = TaggedObject "state" "data"
} ''JobWorkerState } ''JobWorkerState
classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4
classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob)
where
Aeson.Object obj = Aeson.toJSON jws
Aeson.String tag = obj HashMap.! "state"
mJobCtl = asum
[ classifyJobCtl <$> jws ^? _jobWorkerJobCtl
, "perform" <$ jws ^? _jobWorkerJob
]
mJob = classifyJob <$> jws ^? _jobWorkerJob
withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a
withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt
newtype JobWorkerId = JobWorkerId { jobWorkerUnique :: Unique } newtype JobWorkerId = JobWorkerId { jobWorkerUnique :: Unique }
deriving (Eq, Ord) deriving (Eq, Ord)
@ -273,6 +255,9 @@ jqInsert job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job) job
jqDequeue :: JobQueue -> Maybe (JobCtl, JobQueue) jqDequeue :: JobQueue -> Maybe (JobCtl, JobQueue)
jqDequeue = fmap ((\r@(_, q) -> q `deepseq` r) . over _2 JobQueue) . PQ.maxView . getJobQueue jqDequeue = fmap ((\r@(_, q) -> q `deepseq` r) . over _2 JobQueue) . PQ.maxView . getJobQueue
jqDepth :: Integral n => JobQueue -> n
jqDepth = fromIntegral . PQ.size . getJobQueue
data JobState = JobState data JobState = JobState
{ jobWorkers :: Map (Async ()) (TVar JobQueue) { jobWorkers :: Map (Async ()) (TVar JobQueue)

116
src/Utils/Metrics.hs
View File

@ -1,14 +1,18 @@
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module Utils.Metrics module Utils.Metrics
( withHealthReportMetrics ( withHealthReportMetrics
, registerGHCMetrics , registerGHCMetrics
, observeHTTPRequestLatency , observeHTTPRequestLatency
, registerReadyMetric , registerReadyMetric
, registerJobHeldLocksCount , withJobWorkerState
, withJobWorkerStateLbls
, observeYesodCacheSize , observeYesodCacheSize
, observeFavouritesQuickActionsDuration , observeFavouritesQuickActionsDuration
, LoginOutcome(..), observeLoginOutcome , LoginOutcome(..), observeLoginOutcome
, registerJobHeldLocksCount
, FileChunkStorage(..), observeSourcedChunk, observeSunkChunk , FileChunkStorage(..), observeSourcedChunk, observeSunkChunk
, observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles
, registerJobWorkerQueueDepth
) where ) where
import Import.NoModel hiding (Vector, Info) import Import.NoModel hiding (Vector, Info)
@ -29,6 +33,11 @@ import Yesod.Core.Types (HandlerData(..), GHState(..))
import qualified Data.Set as Set import qualified Data.Set as Set
import Jobs.Types
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
{-# ANN module ("HLint: ignore Use even" :: String) #-} {-# ANN module ("HLint: ignore Use even" :: String) #-}
@ -130,15 +139,75 @@ jobHeldLocksCount heldLocks = Metric $ return (MkJobHeldLocksCount, collectJobHe
sourcedFileChunkSizes :: Vector Label1 Histogram sourcedFileChunkSizes :: Vector Label1 Histogram
sourcedFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets sourcedFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets
where info = Info "uni2work_sourced_file_chunks_bytes" where info = Info "uni2work_sourced_file_chunks_bytes"
"Sizes of files chunks sourced" "Sizes of file chunks sourced"
buckets = 0 : histogramBuckets 1 20000000 buckets = 0 : histogramBuckets 1 1000000000
{-# NOINLINE sunkFileChunkSizes #-} {-# NOINLINE sunkFileChunkSizes #-}
sunkFileChunkSizes :: Vector Label1 Histogram sunkFileChunkSizes :: Vector Label1 Histogram
sunkFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets sunkFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets
where info = Info "uni2work_sunk_file_chunks_bytes" where info = Info "uni2work_sunk_file_chunks_bytes"
"Sizes of files chunks sunk" "Sizes of file chunks sunk"
buckets = 0 : histogramBuckets 1 100000000 buckets = 0 : histogramBuckets 1 1000000000
{-# NOINLINE deletedUnreferencedFiles #-}
deletedUnreferencedFiles :: Counter
deletedUnreferencedFiles = unsafeRegister $ counter info
where info = Info "uni2work_deleted_unreferenced_files_count"
"Number of unreferenced files deleted"
{-# NOINLINE deletedUnreferencedChunks #-}
deletedUnreferencedChunks :: Counter
deletedUnreferencedChunks = unsafeRegister $ counter info
where info = Info "uni2work_deleted_unreferenced_chunks_count"
"Number of unreferenced chunks deleted"
{-# NOINLINE deletedUnreferencedChunksBytes #-}
deletedUnreferencedChunksBytes :: Counter
deletedUnreferencedChunksBytes = unsafeRegister $ counter info
where info = Info "uni2work_deleted_unreferenced_chunks_bytes"
"Size of unreferenced chunks deleted"
{-# NOINLINE injectedFiles #-}
injectedFiles :: Counter
injectedFiles = unsafeRegister $ counter info
where info = Info "uni2work_injected_files_count"
"Number of files injected from upload cache into database"
{-# NOINLINE injectedFilesBytes #-}
injectedFilesBytes :: Counter
injectedFilesBytes = unsafeRegister $ counter info
where info = Info "uni2work_injected_files_bytes"
"Size of files injected from upload cache into database"
{-# NOINLINE rechunkedFiles #-}
rechunkedFiles :: Counter
rechunkedFiles = unsafeRegister $ counter info
where info = Info "uni2work_rechunked_files_count"
"Number of files rechunked within database"
{-# NOINLINE rechunkedFilesBytes #-}
rechunkedFilesBytes :: Counter
rechunkedFilesBytes = unsafeRegister $ counter info
where info = Info "uni2work_rechunked_files_bytes"
"Size of files rechunked within database"
data JobWorkerQueueDepth = MkJobWorkerQueueDepth
jobWorkerQueueDepth :: TMVar JobState -> Metric JobWorkerQueueDepth
jobWorkerQueueDepth jSt = Metric $ return (MkJobWorkerQueueDepth, collectJobWorkerQueueDepth)
where
collectJobWorkerQueueDepth = maybeT (return []) $ do
wQueues <- hoist atomically $ do
JobState{..} <- MaybeT $ tryReadTMVar jSt
flip ifoldMapM jobWorkers $ \wAsync wQueue
-> lift $ pure . (jobWorkerName wAsync, ) . jqDepth <$> readTVar wQueue
return [ SampleGroup info GaugeType
[ Sample "uni2work_queued_jobs_count" [("worker", showWorkerId wName)] . encodeUtf8 $ tshow wDepth
| (wName, wDepth) <- wQueues
]
]
info = Info "uni2work_queued_jobs_count"
"Number of JobQueue entries in this Uni2work-instance"
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
withHealthReportMetrics act = do withHealthReportMetrics act = do
@ -181,6 +250,20 @@ observeHTTPRequestLatency classifyHandler app req respond' = do
registerReadyMetric :: MonadIO m => m () registerReadyMetric :: MonadIO m => m ()
registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime
classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4
classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob)
where
Aeson.Object obj = Aeson.toJSON jws
Aeson.String tag = obj HashMap.! "state"
mJobCtl = asum
[ classifyJobCtl <$> jws ^? _jobWorkerJobCtl
, "perform" <$ jws ^? _jobWorkerJob
]
mJob = classifyJob <$> jws ^? _jobWorkerJob
withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a
withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt
withJobWorkerStateLbls :: (MonadIO m, MonadMask m) => Label4 -> m a -> m a withJobWorkerStateLbls :: (MonadIO m, MonadMask m) => Label4 -> m a -> m a
withJobWorkerStateLbls newLbls act = do withJobWorkerStateLbls newLbls act = do
liftIO $ withLabel jobWorkerStateTransitions newLbls incCounter liftIO $ withLabel jobWorkerStateTransitions newLbls incCounter
@ -240,3 +323,24 @@ observeSourcedChunk store = liftIO . observeChunkSize sourcedFileChunkSizes stor
observeChunkSize :: Vector Label1 Histogram -> FileChunkStorage -> Integer -> IO () observeChunkSize :: Vector Label1 Histogram -> FileChunkStorage -> Integer -> IO ()
observeChunkSize metric (toPathPiece -> storageLabel) = withLabel metric storageLabel . flip observe . fromInteger observeChunkSize metric (toPathPiece -> storageLabel) = withLabel metric storageLabel . flip observe . fromInteger
observeDeletedUnreferencedFiles :: MonadIO m => Natural -> m ()
observeDeletedUnreferencedFiles = liftIO . void . addCounter deletedUnreferencedFiles . fromIntegral
observeDeletedUnreferencedChunks :: MonadIO m => Natural -> Word64 -> m ()
observeDeletedUnreferencedChunks num size = liftIO $ do
void . addCounter deletedUnreferencedChunks $ fromIntegral num
void . addCounter deletedUnreferencedChunksBytes $ fromIntegral size
observeInjectedFiles :: MonadIO m => Natural -> Word64 -> m ()
observeInjectedFiles num size = liftIO $ do
void . addCounter injectedFiles $ fromIntegral num
void . addCounter injectedFilesBytes $ fromIntegral size
observeRechunkedFiles :: MonadIO m => Natural -> Word64 -> m ()
observeRechunkedFiles num size = liftIO $ do
void . addCounter rechunkedFiles $ fromIntegral num
void . addCounter rechunkedFilesBytes $ fromIntegral size
registerJobWorkerQueueDepth :: MonadIO m => TMVar JobState -> m ()
registerJobWorkerQueueDepth = liftIO . void . register . jobWorkerQueueDepth