git-annex/Annex/RepoSize/LiveUpdate.hs
Joey Hess 2f20b939b7
LiveUpdate db updates working
I've tested the behavior of the thread that waits for the LiveUpdate to
be finished, and it does get signaled and exit cleanly when the
LiveUpdate is GCed instead.

Made finishedLiveUpdate wait for the thread to finish updating the
database.

There is a case where GC doesn't happen in time and the database is left
with a live update recorded in it. This should not be a problem as such
stale data can also happen when interrupted and will need to be detected
when loading the database.

Balanced preferred content expressions now call startLiveUpdate.
2024-08-24 11:49:58 -04:00

112 lines
3.9 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 qualified Annex
import Logs.Presence.Pure
import qualified Database.RepoSize as Db
import Annex.UUID
import Control.Concurrent
import qualified Data.Map.Strict as M
import qualified Data.Set as S
updateRepoSize :: LiveUpdate -> UUID -> Key -> LogStatus -> Annex ()
updateRepoSize lu u k s = do
-- TODO update reposizes db
-- FIXME locking so the liveupdate is remove in the same
-- transaction that updates reposizes and the db too.
liftIO $ finishedLiveUpdate lu u k sc
rsv <- Annex.getRead Annex.reposizes
liftIO (takeMVar rsv) >>= \case
Nothing -> liftIO (putMVar rsv Nothing)
Just sizemap -> do
let !sizemap' = M.adjust
(fromMaybe (RepoSize 0) . f k . Just)
u sizemap
liftIO $ putMVar rsv (Just sizemap')
where
(sc, f) = case s of
InfoPresent -> (AddingKey, addKeyRepoSize)
InfoMissing -> (RemovingKey, removeKeyRepoSize)
InfoDead -> (RemovingKey, removeKeyRepoSize)
addKeyRepoSize :: Key -> Maybe RepoSize -> Maybe RepoSize
addKeyRepoSize k mrs = case mrs of
Just (RepoSize sz) -> Just $ RepoSize $ sz + ksz
Nothing -> Just $ RepoSize ksz
where
ksz = fromMaybe 0 $ fromKey keySize k
removeKeyRepoSize :: Key -> Maybe RepoSize -> Maybe RepoSize
removeKeyRepoSize k mrs = case mrs of
Just (RepoSize sz) -> Just $ RepoSize $ sz - ksz
Nothing -> Nothing
where
ksz = fromMaybe 0 $ fromKey keySize k
accumRepoSizes :: Key -> (S.Set UUID, S.Set UUID) -> M.Map UUID RepoSize -> M.Map UUID RepoSize
accumRepoSizes k (newlocs, removedlocs) sizemap =
let !sizemap' = foldl' (flip $ M.alter $ addKeyRepoSize k) sizemap newlocs
in foldl' (flip $ M.alter $ removeKeyRepoSize k) sizemap' removedlocs
-- 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
startv <- liftIO newEmptyMVar
donev <- liftIO newEmptyMVar
finishv <- liftIO newEmptyMVar
void $ liftIO $ forkIO $ waitstart startv donev finishv h u
return (LiveUpdate startv donev finishv)
where
{- Wait for startLiveUpdate, or for the LiveUpdate to get garbage
- collected in the case where it is never going to start. -}
waitstart startv donev finishv h u = tryNonAsync (takeMVar startv) >>= \case
Right _ -> do
{- Deferring updating the database until here
- avoids overhead except in cases where preferred
- content expressions need live updates. -}
Db.startingLiveSizeChange h u k sc
waitdone donev finishv h u
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. -}
waitdone donev finishv h u = tryNonAsync (takeMVar donev) >>= \case
-- TODO need to update RepoSize db
-- in same transaction as Db.finishedLiveSizeChange
Right (u', k', sc')
| u' == u && k' == k && sc' == sc -> do
done h u
putMVar finishv ()
-- This can happen when eg, storing to a cluster
-- causes fanout and so this is called with
-- other UUIDs.
| otherwise -> waitdone donev finishv h u
Left _ -> done h u
done h u = Db.finishedLiveSizeChange h u k sc
-- Called when a preferred content check indicates that a live update is
-- needed. Can be called more than once.
startLiveUpdate :: LiveUpdate -> Annex ()
startLiveUpdate (LiveUpdate startv _donev _finishv) =
liftIO $ void $ tryPutMVar startv ()
startLiveUpdate NoLiveUpdate = noop
finishedLiveUpdate :: LiveUpdate -> UUID -> Key -> SizeChange -> IO ()
finishedLiveUpdate (LiveUpdate _startv donev finishv) u k sc = do
tryNonAsync (putMVar donev (u, k, sc)) >>= \case
Right () -> void $ tryNonAsync $ readMVar finishv
Left _ -> noop
finishedLiveUpdate NoLiveUpdate _ _ _ = noop