8555fb88ef
This makes sure that two threads don't check balanced preferred content at the same time, so each thread always sees a consistent picture of what is happening. This does add a fairly expensive file level lock to every check of preferred content, in commands that use prepareLiveUpdate. It would be good to only do that when live updates are actually needed, eg when the preferred content expression uses balanced preferred content.
116 lines
4 KiB
Haskell
116 lines
4 KiB
Haskell
{- git-annex repo sizes, live updates
|
|
-
|
|
- Copyright 2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
module Annex.RepoSize.LiveUpdate where
|
|
|
|
import Annex.Common
|
|
import Logs.Presence.Pure
|
|
import qualified Database.RepoSize as Db
|
|
import Annex.UUID
|
|
|
|
import Control.Concurrent
|
|
import System.Process
|
|
|
|
{- Called when a location log change is journalled, so the LiveUpdate
|
|
- is done. This is called with the journal still locked, so no concurrent
|
|
- changes can happen while it's running. Waits for the database
|
|
- to be updated. -}
|
|
updateRepoSize :: LiveUpdate -> UUID -> Key -> LogStatus -> Annex ()
|
|
updateRepoSize lu u k s = liftIO $ finishedLiveUpdate lu u k sc
|
|
where
|
|
sc = case s of
|
|
InfoPresent -> AddingKey
|
|
InfoMissing -> RemovingKey
|
|
InfoDead -> RemovingKey
|
|
|
|
-- When the UUID is Nothing, it's a live update of the local repository.
|
|
prepareLiveUpdate :: Maybe UUID -> Key -> SizeChange -> Annex LiveUpdate
|
|
prepareLiveUpdate mu k sc = do
|
|
h <- Db.getRepoSizeHandle
|
|
u <- maybe getUUID pure mu
|
|
needv <- liftIO newEmptyMVar
|
|
startv <- liftIO newEmptyMVar
|
|
readyv <- liftIO newEmptyMVar
|
|
donev <- liftIO newEmptyMVar
|
|
void $ liftIO $ forkIO $ waitstart startv readyv donev h u
|
|
return (LiveUpdate needv startv readyv donev)
|
|
where
|
|
{- Wait for checkLiveUpdate to request a start, or for the
|
|
- LiveUpdate to get garbage collected in the case where
|
|
- it is not needed.
|
|
-
|
|
- Deferring updating the database until here avoids overhead
|
|
- except in cases where preferred content expressions
|
|
- need live updates.
|
|
-}
|
|
waitstart startv readyv donev h u =
|
|
tryNonAsync (takeMVar startv) >>= \case
|
|
Right () -> do
|
|
pid <- getCurrentPid
|
|
cid <- mkSizeChangeId pid
|
|
Db.startingLiveSizeChange h u k sc cid
|
|
putMVar readyv ()
|
|
waitdone donev h u cid
|
|
Left _ -> noop
|
|
|
|
{- Wait for finishedLiveUpdate to be called, or for the LiveUpdate
|
|
- to get garbage collected in the case where the change didn't
|
|
- actually happen. Updates the database. -}
|
|
waitdone donev h u cid = tryNonAsync (takeMVar donev) >>= \case
|
|
Right (Just (u', k', sc', finishv))
|
|
| u' == u && k' == k && sc' == sc -> do
|
|
Db.successfullyFinishedLiveSizeChange h u k sc cid
|
|
putMVar finishv ()
|
|
-- Not the update we were expecting. This can
|
|
-- happen when eg, storing to a cluster
|
|
-- causes fanout and so this is called with
|
|
-- other UUIDs.
|
|
| otherwise -> do
|
|
putMVar finishv ()
|
|
waitdone donev h u cid
|
|
Right Nothing -> abandoned h u cid
|
|
Left _ -> abandoned h u cid
|
|
abandoned h u cid = Db.removeStaleLiveSizeChange h u k sc cid
|
|
|
|
-- Called when a preferred content check indicates that a live update is
|
|
-- needed. Can be called more than once on the same LiveUpdate.
|
|
needLiveUpdate :: LiveUpdate -> Annex ()
|
|
needLiveUpdate NoLiveUpdate = noop
|
|
needLiveUpdate lu = liftIO $ void $ tryPutMVar (liveUpdateNeeded lu) ()
|
|
|
|
-- needLiveUpdate has to be called inside this to take effect. If the
|
|
-- action calls needLiveUpdate and then returns True, the live update is
|
|
-- started. If the action calls needLiveUpdate and then returns False,
|
|
-- the live update is not started.
|
|
--
|
|
-- This can be called more than once on the same LiveUpdate. It will
|
|
-- only start it once.
|
|
--
|
|
-- This serializes calls to the action, so that if the action
|
|
-- queries getLiveRepoSizes it will not race with another such action
|
|
-- that may also be starting a live update.
|
|
checkLiveUpdate :: LiveUpdate -> Annex Bool -> Annex Bool
|
|
checkLiveUpdate NoLiveUpdate a = a
|
|
checkLiveUpdate lu a = Db.lockDbWhile (const go) go
|
|
where
|
|
go = do
|
|
r <- a
|
|
needed <- liftIO $ isJust <$> tryTakeMVar (liveUpdateNeeded lu)
|
|
when (r && needed) $ do
|
|
liftIO $ void $ tryPutMVar (liveUpdateStart lu) ()
|
|
liftIO $ void $ readMVar (liveUpdateReady lu)
|
|
return r
|
|
|
|
finishedLiveUpdate :: LiveUpdate -> UUID -> Key -> SizeChange -> IO ()
|
|
finishedLiveUpdate NoLiveUpdate _ _ _ = noop
|
|
finishedLiveUpdate lu u k sc = do
|
|
finishv <- newEmptyMVar
|
|
tryNonAsync (putMVar (liveUpdateDone lu) (Just (u, k, sc, finishv))) >>= \case
|
|
Right () -> void $ tryNonAsync $ takeMVar finishv
|
|
Left _ -> noop
|