plumb in LiveUpdate (WIP)

Each command that first checks preferred content (and/or required
content) and then does something that can change the sizes of
repositories needs to call prepareLiveUpdate, and plumb it through the
preferred content check and the location log update.

So far, only Command.Drop is done. Many other commands that don't need
to do this have been updated to keep working.

There may be some calls to NoLiveUpdate in places where that should be
done. All will need to be double checked.

Not currently in a compilable state.
This commit is contained in:
Joey Hess 2024-08-23 16:35:12 -04:00
parent 4885073377
commit c3d40b9ec3
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
58 changed files with 363 additions and 247 deletions

View file

@ -1,6 +1,6 @@
{- git-annex monad
-
- Copyright 2010-2021 Joey Hess <id@joeyh.name>
- Copyright 2010-2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -79,6 +79,7 @@ import Types.RepoSize
import Annex.VectorClock.Utility
import Annex.Debug.Utility
import qualified Database.Keys.Handle as Keys
import Database.RepoSize.Handle
import Utility.InodeCache
import Utility.Url
import Utility.ResourcePool
@ -225,6 +226,7 @@ data AnnexState = AnnexState
, insmudgecleanfilter :: Bool
, getvectorclock :: IO CandidateVectorClock
, proxyremote :: Maybe (Either ClusterUUID (Types.Remote.RemoteA Annex))
, reposizehandle :: Maybe RepoSizeHandle
}
newAnnexState :: GitConfig -> Git.Repo -> IO AnnexState
@ -280,6 +282,7 @@ newAnnexState c r = do
, insmudgecleanfilter = False
, getvectorclock = vc
, proxyremote = Nothing
, reposizehandle = Nothing
}
{- Makes an Annex state object for the specified git repo.

View file

@ -108,7 +108,10 @@ clusterProxySelector clusteruuid protocolversion (Bypass bypass) = do
, proxyPUT = \af k -> do
locs <- S.fromList <$> loggedLocations k
let l = filter (flip S.notMember locs . Remote.uuid . remote) nodes
l' <- filterM (\n -> isPreferredContent (Just (Remote.uuid (remote n))) mempty (Just k) af True) l
--- XXX FIXME TODO NoLiveUpdate should not be used
-- here. Doing a live update here is exactly why
-- live update is needed.
l' <- filterM (\n -> isPreferredContent NoLiveUpdate (Just (Remote.uuid (remote n))) mempty (Just k) af True) l
-- PUT to no nodes doesn't work, so fall
-- back to all nodes.
return $ nonempty [l', l] nodes

View file

@ -11,6 +11,7 @@ import Annex.Locations as X
import Annex.Debug as X (fastDebug, debug)
import Messages as X
import Git.Quote as X
import Types.RepoSize as X
#ifndef mingw32_HOST_OS
import System.Posix.IO as X hiding (createPipe, append)
#endif

View file

@ -788,7 +788,7 @@ moveBad key = do
createAnnexDirectory (parentDir dest)
cleanObjectLoc key $
liftIO $ moveFile src dest
logStatus key InfoMissing
logStatus NoLiveUpdate key InfoMissing
return dest
data KeyLocation = InAnnex | InAnywhere

View file

@ -29,9 +29,9 @@ type Reason = String
- required content, and numcopies settings.
-
- Skips trying to drop from remotes that are appendonly, since those drops
- would presumably fail. Also skips dropping from exporttree/importtree remotes,
- which don't allow dropping individual keys, and from thirdPartyPopulated
- remotes.
- would presumably fail. Also skips dropping from exporttree/importtree
- remotes, which don't allow dropping individual keys, and from
- thirdPartyPopulated remotes.
-
- The UUIDs are ones where the content is believed to be present.
- The Remote list can include other remotes that do not have the content;
@ -92,11 +92,12 @@ handleDropsFrom locs rs reason fromhere key afile si preverified runner = do
dropr fs r n >>= go fs rest
| otherwise = pure n
checkdrop fs n u a =
checkdrop fs n u a = do
let afs = map (AssociatedFile . Just) fs
pcc = Command.Drop.PreferredContentChecked True
in ifM (wantDrop True u (Just key) afile (Just afs))
( dodrop n u (a pcc)
let pcc = Command.Drop.PreferredContentChecked True
lu <- prepareLiveUpdate u key RemovingKey
ifM (wantDrop lu True u (Just key) afile (Just afs))
( dodrop n u (a lu pcc)
, return n
)
@ -116,12 +117,16 @@ handleDropsFrom locs rs reason fromhere key afile si preverified runner = do
, return n
)
dropl fs n = checkdrop fs n Nothing $ \pcc numcopies mincopies ->
dropl fs n = checkdrop fs n Nothing $ \lu pcc numcopies mincopies ->
stopUnless (inAnnex key) $
Command.Drop.startLocal pcc afile ai si numcopies mincopies key preverified (Command.Drop.DroppingUnused False)
Command.Drop.startLocal lu pcc afile ai si
numcopies mincopies key preverified
(Command.Drop.DroppingUnused False)
dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \pcc numcopies mincopies ->
Command.Drop.startRemote pcc afile ai si numcopies mincopies key (Command.Drop.DroppingUnused False) r
dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \lu pcc numcopies mincopies ->
Command.Drop.startRemote lu pcc afile ai si
numcopies mincopies key
(Command.Drop.DroppingUnused False) r
ai = mkActionItem (key, afile)

View file

@ -53,22 +53,22 @@ import Control.Monad.Writer
type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex)
checkFileMatcher :: GetFileMatcher -> RawFilePath -> Annex Bool
checkFileMatcher getmatcher file =
checkFileMatcher' getmatcher file (return True)
checkFileMatcher :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool
checkFileMatcher lu getmatcher file =
checkFileMatcher' lu getmatcher file (return True)
-- | Allows running an action when no matcher is configured for the file.
checkFileMatcher' :: GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool
checkFileMatcher' getmatcher file notconfigured = do
checkFileMatcher' :: LiveUpdate -> GetFileMatcher -> RawFilePath -> Annex Bool -> Annex Bool
checkFileMatcher' lu getmatcher file notconfigured = do
matcher <- getmatcher file
checkMatcher matcher Nothing afile S.empty notconfigured d
checkMatcher matcher Nothing afile lu S.empty notconfigured d
where
afile = AssociatedFile (Just file)
-- checkMatcher will never use this, because afile is provided.
d = return True
checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool
checkMatcher matcher mkey afile notpresent notconfigured d
checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> LiveUpdate -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool
checkMatcher matcher mkey afile lu notpresent notconfigured d
| isEmpty (fst matcher) = notconfigured
| otherwise = case (mkey, afile) of
(_, AssociatedFile (Just file)) ->
@ -85,12 +85,12 @@ checkMatcher matcher mkey afile notpresent notconfigured d
in go (MatchingInfo i)
(Nothing, _) -> d
where
go mi = checkMatcher' matcher mi notpresent
go mi = checkMatcher' matcher mi lu notpresent
checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Bool
checkMatcher' (matcher, (MatcherDesc matcherdesc)) mi notpresent = do
checkMatcher' :: FileMatcher Annex -> MatchInfo -> LiveUpdate -> AssumeNotPresent -> Annex Bool
checkMatcher' (matcher, (MatcherDesc matcherdesc)) mi lu notpresent = do
(matches, desc) <- runWriterT $ matchMrun' matcher $ \op ->
matchAction op notpresent mi
matchAction op lu notpresent mi
explain (mkActionItem mi) $ UnquotedString <$>
describeMatchResult matchDesc desc
((if matches then "matches " else "does not match ") ++ matcherdesc ++ ": ")
@ -259,9 +259,9 @@ addUnlockedMatcher = AddUnlockedMatcher <$>
matchalways True = return (MOp limitAnything, matcherdesc)
matchalways False = return (MOp limitNothing, matcherdesc)
checkAddUnlockedMatcher :: AddUnlockedMatcher -> MatchInfo -> Annex Bool
checkAddUnlockedMatcher (AddUnlockedMatcher matcher) mi =
checkMatcher' matcher mi S.empty
checkAddUnlockedMatcher :: LiveUpdate -> AddUnlockedMatcher -> MatchInfo -> Annex Bool
checkAddUnlockedMatcher lu (AddUnlockedMatcher matcher) mi =
checkMatcher' matcher mi lu S.empty
simply :: MatchFiles Annex -> ParseResult (MatchFiles Annex)
simply = Right . Operation
@ -271,8 +271,8 @@ usev a v = Operation <$> a v
call :: String -> Either String (Matcher (MatchFiles Annex)) -> ParseResult (MatchFiles Annex)
call desc (Right sub) = Right $ Operation $ MatchFiles
{ matchAction = \notpresent mi ->
matchMrun sub $ \o -> matchAction o notpresent mi
{ matchAction = \lu notpresent mi ->
matchMrun sub $ \o -> matchAction o lu notpresent mi
, matchNeedsFileName = any matchNeedsFileName sub
, matchNeedsFileContent = any matchNeedsFileContent sub
, matchNeedsKey = any matchNeedsKey sub

View file

@ -191,7 +191,7 @@ recordImportTree remote importtreeconfig imported = do
let updater db moldkey _newkey _ = case moldkey of
Just oldkey | not (isGitShaKey oldkey) ->
unlessM (stillpresent db oldkey) $
logChange oldkey (Remote.uuid remote) InfoMissing
logChange NoLiveUpdate oldkey (Remote.uuid remote) InfoMissing
_ -> noop
-- When the remote is versioned, it still contains keys
-- that are not present in the new tree.
@ -763,7 +763,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
tryNonAsync (importkey loc cid sz nullMeterUpdate) >>= \case
Right (Just k) -> do
recordcidkeyindb db cid k
logChange k (Remote.uuid remote) InfoPresent
logChange NoLiveUpdate k (Remote.uuid remote) InfoPresent
return $ Just (loc, Right k)
Right Nothing -> return Nothing
Left e -> do
@ -799,7 +799,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
, providedMimeEncoding = Nothing
, providedLinkType = Nothing
}
islargefile <- checkMatcher' matcher mi mempty
islargefile <- checkMatcher' matcher mi NoLiveUpdate mempty
metered Nothing sz bwlimit $ const $ if islargefile
then doimportlarge importkey cidmap loc cid sz f
else doimportsmall cidmap loc cid sz
@ -823,7 +823,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
Just k -> checkSecureHashes k >>= \case
Nothing -> do
recordcidkey cidmap cid k
logChange k (Remote.uuid remote) InfoPresent
logChange NoLiveUpdate k (Remote.uuid remote) InfoPresent
if importcontent
then getcontent k
else return (Just (k, True))
@ -839,7 +839,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
(combineMeterUpdate p' p)
ok <- moveAnnex k af tmpfile
when ok $
logStatus k InfoPresent
logStatus NoLiveUpdate k InfoPresent
return (Just (k, ok))
checkDiskSpaceToGet k Nothing Nothing $
notifyTransfer Download af $
@ -883,8 +883,8 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
ok <- moveAnnex k af tmpfile
when ok $ do
recordcidkey cidmap cid k
logStatus k InfoPresent
logChange k (Remote.uuid remote) InfoPresent
logStatus NoLiveUpdate k InfoPresent
logChange NoLiveUpdate k (Remote.uuid remote) InfoPresent
return (Right k, ok)
Just sha -> do
recordcidkey cidmap cid k
@ -910,7 +910,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
, contentFile = tmpfile
, matchKey = Nothing
}
islargefile <- checkMatcher' matcher mi mempty
islargefile <- checkMatcher' matcher mi NoLiveUpdate mempty
if islargefile
then do
backend <- chooseBackend f
@ -1085,7 +1085,7 @@ isKnownImportLocation dbhandle loc = liftIO $
not . null <$> Export.getExportTreeKey dbhandle loc
matchesImportLocation :: FileMatcher Annex -> ImportLocation -> Integer -> Annex Bool
matchesImportLocation matcher loc sz = checkMatcher' matcher mi mempty
matchesImportLocation matcher loc sz = checkMatcher' matcher mi NoLiveUpdate mempty
where
mi = MatchingInfo $ ProvidedInfo
{ providedFilePath = Just (fromImportLocation loc)

View file

@ -288,7 +288,7 @@ cleanOldKeys file newkey = do
(f:_) -> do
ic <- withTSDelta (liftIO . genInodeCache f)
void $ linkToAnnex key f ic
_ -> logStatus key InfoMissing
_ -> logStatus NoLiveUpdate key InfoMissing
{- On error, put the file back so it doesn't seem to have vanished.
- This can be called before or after the symlink is in place. -}
@ -349,7 +349,7 @@ gitAddParams (CheckGitIgnore False) = return [Param "-f"]
addUnlocked :: AddUnlockedMatcher -> MatchInfo -> Bool -> Annex Bool
addUnlocked matcher mi contentpresent =
((not . coreSymlinks <$> Annex.getGitConfig) <||>
(checkAddUnlockedMatcher matcher mi) <||>
(checkAddUnlockedMatcher NoLiveUpdate matcher mi) <||>
(maybe False go . snd <$> getCurrentBranch)
)
where

View file

@ -365,6 +365,6 @@ canProxyForRemote rs myproxies myclusters remoteuuid =
mkProxyMethods :: ProxyMethods
mkProxyMethods = ProxyMethods
{ removedContent = \u k -> logChange k u InfoMissing
, addedContent = \u k -> logChange k u InfoPresent
{ removedContent = \u k -> logChange NoLiveUpdate k u InfoMissing
, addedContent = \u k -> logChange NoLiveUpdate k u InfoPresent
}

View file

@ -15,7 +15,6 @@ import Annex.Common
import Annex.RepoSize.LiveUpdate
import qualified Annex
import Annex.Branch (UnmergedBranches(..), getBranch)
import Types.RepoSize
import qualified Database.RepoSize as Db
import Logs
import Logs.Location
@ -71,9 +70,9 @@ calcRepoSizes quiet rsv = bracket setup cleanup $ \h -> go h `onException` faile
liftIO $ Db.setRepoSizes h sizemap branchsha
calcJournalledRepoSizes sizemap branchsha
setup = Db.openDb
setup = Db.getRepoSizeHandle
cleanup = Db.closeDb
cleanup _ = return ()
failed = do
liftIO $ putMVar rsv (Just M.empty)

View file

@ -11,15 +11,16 @@ module Annex.RepoSize.LiveUpdate where
import Annex.Common
import qualified Annex
import Types.RepoSize
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 :: UUID -> Key -> LogStatus -> Annex ()
updateRepoSize u k s = do
updateRepoSize :: LiveUpdate -> UUID -> Key -> LogStatus -> Annex ()
updateRepoSize lu u k s = do
rsv <- Annex.getRead Annex.reposizes
liftIO (takeMVar rsv) >>= \case
Nothing -> liftIO (putMVar rsv Nothing)
@ -52,3 +53,48 @@ accumRepoSizes :: Key -> (S.Set UUID, S.Set UUID) -> M.Map UUID RepoSize -> M.Ma
accumRepoSizes k (newlocs, removedlocs) sizemap =
let !sizemap' = foldl' (flip $ M.alter $ addKeyRepoSize k) sizemap newlocs
in foldl' (flip $ M.alter $ removeKeyRepoSize k) sizemap' removedlocs
-- 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) =
liftIO $ void $ tryPutMVar startv ()
startLiveUpdate NoLiveUpdate = noop
-- 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
void $ liftIO $ forkIO $ waitstart startv donev h u
return (LiveUpdate startv donev)
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 h u = tryNonAsync (takeMVar startv) >>= \case
Right _ -> do
Db.startingLiveSizeChange h u k sc
waitdone donev h u
Left _ -> noop
{- Wait for endLiveUpdate to be called, or for the LiveUpdate to
- get garbage collected in the case where the change didn't
- actually happen. -}
waitdone donev h u = tryNonAsync (takeMVar donev) >>= \case
-- TODO if succeeded == True, need to update RepoSize db
-- in same transaction as Db.finishedLiveSizeChange
Right (succeeded, u', k', sc')
| u' == u && k' == k && sc' == sc -> done h u
-- This can happen when eg, storing to a cluster
-- causes fanout and so this is called with
-- other UUIDs.
| otherwise -> waitdone donev h u
Left _ -> done h u
done h u = Db.finishedLiveSizeChange h u k sc
finishedLiveUpdate :: LiveUpdate -> Bool -> UUID -> Key -> SizeChange -> IO ()
finishedLiveUpdate (LiveUpdate _startv donev) succeeded u k sc =
putMVar donev (succeeded, u, k, sc)
finishedLiveUpdate NoLiveUpdate _ _ _ _ = noop

View file

@ -18,12 +18,12 @@ import Types.FileMatcher
import qualified Data.Set as S
{- Check if a file is preferred content for the local repository. -}
wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool
wantGet d key file = isPreferredContent Nothing S.empty key file d
wantGet :: LiveUpdate -> Bool -> Maybe Key -> AssociatedFile -> Annex Bool
wantGet lu d key file = isPreferredContent lu Nothing S.empty key file d
{- Check if a file is preferred content for a repository. -}
wantGetBy :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
wantGetBy d key file to = isPreferredContent (Just to) S.empty key file d
wantGetBy :: LiveUpdate -> Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
wantGetBy lu d key file to = isPreferredContent lu (Just to) S.empty key file d
{- Check if a file is not preferred or required content, and can be
- dropped. When a UUID is provided, checks for that repository.
@ -34,20 +34,20 @@ wantGetBy d key file to = isPreferredContent (Just to) S.empty key file d
- that will prevent dropping. When the other associated files are known,
- they can be provided, otherwise this looks them up.
-}
wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> (Maybe [AssociatedFile]) -> Annex Bool
wantDrop d from key file others =
isNothing <$> checkDrop isPreferredContent d from key file others
wantDrop :: LiveUpdate -> Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> (Maybe [AssociatedFile]) -> Annex Bool
wantDrop lu d from key file others =
isNothing <$> checkDrop isPreferredContent lu d from key file others
{- Generalization of wantDrop that can also be used with isRequiredContent.
-
- When the content should not be dropped, returns Just the file that
- the checker matches.
-}
checkDrop :: (Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool) -> Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> (Maybe [AssociatedFile]) -> Annex (Maybe AssociatedFile)
checkDrop checker d from key file others = do
checkDrop :: (LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool) -> LiveUpdate -> Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> (Maybe [AssociatedFile]) -> Annex (Maybe AssociatedFile)
checkDrop checker lu d from key file others = do
u <- maybe getUUID (pure . id) from
let s = S.singleton u
let checker' f = checker (Just u) s key f d
let checker' f = checker lu (Just u) s key f d
ifM (checker' file)
( return (Just file)
, do

View file

@ -214,7 +214,7 @@ onAddFile symlinkssupported f fs =
Database.Keys.removeAssociatedFile oldkey
=<< inRepo (toTopFilePath (toRawFilePath file))
unlessM (inAnnex oldkey) $
logStatus oldkey InfoMissing
logStatus NoLiveUpdate oldkey InfoMissing
addlink file key = do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (toRawFilePath file)
liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key

View file

@ -60,7 +60,7 @@ queueTransfers = queueTransfersMatching (const True)
- condition. Honors preferred content settings. -}
queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant Bool
queueTransfersMatching matching reason schedule k f direction
| direction == Download = ifM (liftAnnex $ wantGet True (Just k) f)
| direction == Download = ifM (liftAnnex $ wantGet NoLiveUpdate True (Just k) f)
( go
, return False
)
@ -89,7 +89,7 @@ queueTransfersMatching matching reason schedule k f direction
- already have it. -}
| otherwise = do
s <- locs
filterM (wantGetBy True (Just k) f . Remote.uuid) $
filterM (wantGetBy NoLiveUpdate True (Just k) f . Remote.uuid) $
filter (\r -> not (inset s r || Remote.readonly r))
(syncDataRemotes st)
where

View file

@ -210,11 +210,11 @@ genTransfer t info = case transferRemote info of
shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
shouldTransfer t info
| transferDirection t == Download =
(not <$> inAnnex key) <&&> wantGet True (Just key) file
(not <$> inAnnex key) <&&> wantGet NoLiveUpdate True (Just key) file
| transferDirection t == Upload = case transferRemote info of
Nothing -> return False
Just r -> notinremote r
<&&> wantGetBy True (Just key) file (Remote.uuid r)
<&&> wantGetBy NoLiveUpdate True (Just key) file (Remote.uuid r)
| otherwise = return False
where
key = transferKey t

View file

@ -77,7 +77,7 @@ expireUnused duration = do
debug ["removing old unused key", serializeKey k]
liftAnnex $ tryNonAsync $ do
lockContentForRemoval k noop removeAnnex
logStatus k InfoMissing
logStatus NoLiveUpdate k InfoMissing
where
boundary = durationToPOSIXTime <$> duration
tooold now (_, mt) = case boundary of

View file

@ -101,7 +101,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
cleanup = liftAnnex $ do
lockContentForRemoval k noop removeAnnex
setUrlMissing k u
logStatus k InfoMissing
logStatus NoLiveUpdate k InfoMissing
{- Called once the download is done.
- Passed an action that can be used to clean up the downloaded file.

View file

@ -21,6 +21,7 @@ import CmdLine.AnnexSetter as ReExported
import CmdLine.GitAnnex.Options as ReExported
import CmdLine.Batch as ReExported
import Options.Applicative as ReExported hiding (command)
import Annex.RepoSize.LiveUpdate as ReExported
import qualified Git
import Annex.Init
import Annex.Startup

View file

@ -95,7 +95,7 @@ seek' o = do
annexdotfiles <- getGitConfigVal annexDotFiles
let gofile includingsmall (si, file) = case largeFilesOverride o of
Nothing -> ifM (pure (annexdotfiles || not (dotfile file))
<&&> (checkFileMatcher largematcher file
<&&> (checkFileMatcher NoLiveUpdate largematcher file
<||> Annex.getRead Annex.force))
( start dr si file addunlockedmatcher
, if includingsmall
@ -267,5 +267,5 @@ cleanup :: Key -> Bool -> CommandCleanup
cleanup key hascontent = do
maybeShowJSON $ JSONChunk [("key", serializeKey key)]
when hascontent $
logStatus key InfoPresent
logStatus NoLiveUpdate key InfoPresent
return True

View file

@ -32,7 +32,7 @@ start = startUnused go (other "bad") (other "tmp")
(ActionItemTreeFile file)
(SeekInput [show n]) $
next $ do
logStatus key InfoPresent
logStatus NoLiveUpdate key InfoPresent
addSymlink file key Nothing
return True

View file

@ -323,7 +323,7 @@ addUrlChecked o url file u checkexistssize key =
Just (exists, samesize, url')
| exists && (samesize || relaxedOption (downloadOptions o)) -> do
setUrlPresent key url'
logChange key u InfoPresent
logChange NoLiveUpdate key u InfoPresent
next $ return True
| otherwise -> do
warning $ UnquotedString $ "while adding a new url to an already annexed file, " ++ if exists
@ -511,7 +511,7 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
createWorkTreeDirectory (P.takeDirectory file)
liftIO $ moveFile tmp file
largematcher <- largeFilesMatcher
large <- checkFileMatcher largematcher file
large <- checkFileMatcher NoLiveUpdate largematcher file
if large
then do
-- Move back to tmp because addAnnexedFile
@ -525,11 +525,11 @@ addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
go = do
maybeShowJSON $ JSONChunk [("key", serializeKey key)]
setUrlPresent key url
logChange key u InfoPresent
logChange NoLiveUpdate key u InfoPresent
ifM (addAnnexedFile addunlockedmatcher file key mtmp)
( do
when (isJust mtmp) $
logStatus key InfoPresent
logStatus NoLiveUpdate key InfoPresent
, maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)) mtmp
)

View file

@ -83,15 +83,17 @@ start o from si file key = start' o from key afile ai si
ai = mkActionItem (key, afile)
start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart
start' o from key afile ai si =
checkDropAuto (autoMode o) from afile key $ \numcopies mincopies ->
stopUnless wantdrop $
start' o from key afile ai si = do
checkDropAuto (autoMode o) from afile key $ \numcopies mincopies -> do
lu <- prepareLiveUpdate remoteuuid key RemovingKey
stopUnless (wantdrop lu) $
case from of
Nothing -> startLocal pcc afile ai si numcopies mincopies key [] ud
Just remote -> startRemote pcc afile ai si numcopies mincopies key ud remote
Nothing -> startLocal lu pcc afile ai si numcopies mincopies key [] ud
Just remote -> startRemote lu pcc afile ai si numcopies mincopies key ud remote
where
wantdrop
| autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile Nothing
remoteuuid = Remote.uuid <$> from
wantdrop lu
| autoMode o = wantDrop lu False remoteuuid (Just key) afile Nothing
| otherwise = return True
pcc = PreferredContentChecked (autoMode o)
ud = case (batchOption o, keyOptions o) of
@ -101,22 +103,22 @@ start' o from key afile ai si =
startKeys :: DropOptions -> Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart
startKeys o from (si, key, ai) = start' o from key (AssociatedFile Nothing) ai si
startLocal :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> DroppingUnused -> CommandStart
startLocal pcc afile ai si numcopies mincopies key preverified ud =
startLocal :: LiveUpdate -> PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> [VerifiedCopy] -> DroppingUnused -> CommandStart
startLocal lu pcc afile ai si numcopies mincopies key preverified ud =
starting "drop" (OnlyActionOn key ai) si $
performLocal pcc key afile numcopies mincopies preverified ud
performLocal lu pcc key afile numcopies mincopies preverified ud
startRemote :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> DroppingUnused -> Remote -> CommandStart
startRemote pcc afile ai si numcopies mincopies key ud remote =
startRemote :: LiveUpdate -> PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> DroppingUnused -> Remote -> CommandStart
startRemote lu pcc afile ai si numcopies mincopies key ud remote =
starting "drop" (OnlyActionOn key ai) si $ do
showAction $ UnquotedString $ "from " ++ Remote.name remote
performRemote pcc key afile numcopies mincopies remote ud
performRemote lu pcc key afile numcopies mincopies remote ud
performLocal :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> DroppingUnused -> CommandPerform
performLocal pcc key afile numcopies mincopies preverified ud = lockContentForRemoval key fallback $ \contentlock -> do
performLocal :: LiveUpdate -> PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> DroppingUnused -> CommandPerform
performLocal lu pcc key afile numcopies mincopies preverified ud = lockContentForRemoval key fallback $ \contentlock -> do
u <- getUUID
(tocheck, verified) <- verifiableCopies key [u]
doDrop pcc u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck
doDrop lu pcc u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck
( \proof -> do
fastDebug "Command.Drop" $ unwords
[ "Dropping from here"
@ -125,7 +127,7 @@ performLocal pcc key afile numcopies mincopies preverified ud = lockContentForRe
]
removeAnnex contentlock
notifyDrop afile True
next $ cleanupLocal key ud
next $ cleanupLocal lu key ud
, do
notifyDrop afile False
stop
@ -136,14 +138,14 @@ performLocal pcc key afile numcopies mincopies preverified ud = lockContentForRe
-- is present, but due to buffering, may find it present for the
-- second file before the first is dropped. If so, nothing remains
-- to be done except for cleaning up.
fallback = next $ cleanupLocal key ud
fallback = next $ cleanupLocal lu key ud
performRemote :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> DroppingUnused -> CommandPerform
performRemote pcc key afile numcopies mincopies remote ud = do
performRemote :: LiveUpdate -> PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> Remote -> DroppingUnused -> CommandPerform
performRemote lu pcc key afile numcopies mincopies remote ud = do
-- Filter the uuid it's being dropped from out of the lists of
-- places assumed to have the key, and places to check.
(tocheck, verified) <- verifiableCopies key [uuid]
doDrop pcc uuid Nothing key afile numcopies mincopies [uuid] verified tocheck
doDrop lu pcc uuid Nothing key afile numcopies mincopies [uuid] verified tocheck
( \proof -> do
fastDebug "Command.Drop" $ unwords
[ "Dropping from remote"
@ -152,21 +154,21 @@ performRemote pcc key afile numcopies mincopies remote ud = do
, show proof
]
ok <- Remote.action (Remote.removeKey remote proof key)
next $ cleanupRemote key remote ud ok
next $ cleanupRemote lu key remote ud ok
, stop
)
where
uuid = Remote.uuid remote
cleanupLocal :: Key -> DroppingUnused -> CommandCleanup
cleanupLocal key ud = do
logStatus key (dropStatus ud)
cleanupLocal :: LiveUpdate -> Key -> DroppingUnused -> CommandCleanup
cleanupLocal lu key ud = do
logStatus lu key (dropStatus ud)
return True
cleanupRemote :: Key -> Remote -> DroppingUnused -> Bool -> CommandCleanup
cleanupRemote key remote ud ok = do
cleanupRemote :: LiveUpdate -> Key -> Remote -> DroppingUnused -> Bool -> CommandCleanup
cleanupRemote lu key remote ud ok = do
when ok $
Remote.logStatus remote key (dropStatus ud)
Remote.logStatus lu remote key (dropStatus ud)
return ok
{- Set when the user explicitly chose to operate on unused content.
@ -189,7 +191,8 @@ dropStatus (DroppingUnused True) = InfoDead
- --force overrides and always allows dropping.
-}
doDrop
:: PreferredContentChecked
:: LiveUpdate
-> PreferredContentChecked
-> UUID
-> Maybe ContentRemovalLock
-> Key
@ -201,10 +204,10 @@ doDrop
-> [UnVerifiedCopy]
-> (Maybe SafeDropProof -> CommandPerform, CommandPerform)
-> CommandPerform
doDrop pcc dropfrom contentlock key afile numcopies mincopies skip preverified check (dropaction, nodropaction) =
doDrop lu pcc dropfrom contentlock key afile numcopies mincopies skip preverified check (dropaction, nodropaction) =
ifM (Annex.getRead Annex.force)
( dropaction Nothing
, ifM (checkRequiredContent pcc dropfrom key afile)
, ifM (checkRequiredContent lu pcc dropfrom key afile)
( verifyEnoughCopiesToDrop nolocmsg key (Just dropfrom)
contentlock numcopies mincopies
skip preverified check
@ -225,10 +228,10 @@ doDrop pcc dropfrom contentlock key afile numcopies mincopies skip preverified c
- providing this avoids that extra work. -}
newtype PreferredContentChecked = PreferredContentChecked Bool
checkRequiredContent :: PreferredContentChecked -> UUID -> Key -> AssociatedFile -> Annex Bool
checkRequiredContent (PreferredContentChecked True) _ _ _ = return True
checkRequiredContent (PreferredContentChecked False) u k afile =
checkDrop isRequiredContent False (Just u) (Just k) afile Nothing >>= \case
checkRequiredContent :: LiveUpdate -> PreferredContentChecked -> UUID -> Key -> AssociatedFile -> Annex Bool
checkRequiredContent _ (PreferredContentChecked True) _ _ _ = return True
checkRequiredContent lu (PreferredContentChecked False) u k afile =
checkDrop isRequiredContent lu False (Just u) (Just k) afile Nothing >>= \case
Nothing -> return True
Just afile' -> do
if afile == afile'

View file

@ -55,5 +55,5 @@ perform key = ifM (inAnnex key)
cleanup :: Key -> CommandCleanup
cleanup key = do
logStatus key InfoMissing
logStatus NoLiveUpdate key InfoMissing
return True

View file

@ -57,7 +57,8 @@ perform :: Maybe Remote -> NumCopies -> MinCopies -> Key -> CommandPerform
perform from numcopies mincopies key = case from of
Just r -> do
showAction $ UnquotedString $ "from " ++ Remote.name r
Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r ud
Command.Drop.performRemote NoLiveUpdate pcc key
(AssociatedFile Nothing) numcopies mincopies r ud
Nothing -> ifM (inAnnex key)
( droplocal
, ifM (objectFileExists key)
@ -71,7 +72,8 @@ perform from numcopies mincopies key = case from of
)
)
where
droplocal = Command.Drop.performLocal pcc key (AssociatedFile Nothing) numcopies mincopies [] ud
droplocal = Command.Drop.performLocal NoLiveUpdate pcc
key (AssociatedFile Nothing) numcopies mincopies [] ud
pcc = Command.Drop.PreferredContentChecked False
ud = Command.Drop.DroppingUnused True

View file

@ -334,12 +334,12 @@ verifyLocationLog key keystatus ai = do
whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $
warning $ "** Despite annex.securehashesonly being set, " <> QuotedPath obj <> " has content present in the annex using an insecure " <> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key))) <> " key"
verifyLocationLog' key ai present u (logChange key u)
verifyLocationLog' key ai present u (logChange NoLiveUpdate key u)
verifyLocationLogRemote :: Key -> ActionItem -> Remote -> Bool -> Annex Bool
verifyLocationLogRemote key ai remote present =
verifyLocationLog' key ai present (Remote.uuid remote)
(Remote.logStatus remote key)
(Remote.logStatus NoLiveUpdate remote key)
verifyLocationLog' :: Key -> ActionItem -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool
verifyLocationLog' key ai present u updatestatus = do
@ -385,7 +385,7 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = case afile of
go requiredlocs = do
presentlocs <- S.fromList <$> loggedLocations key
missinglocs <- filterM
(\u -> isRequiredContent (Just u) S.empty (Just key) afile False)
(\u -> isRequiredContent NoLiveUpdate (Just u) S.empty (Just key) afile False)
(S.toList $ S.difference requiredlocs presentlocs)
if null missinglocs
then return True
@ -641,7 +641,7 @@ badContentRemote remote localcopy key = do
dropped <- tryNonAsync (Remote.removeKey remote Nothing key)
when (isRight dropped) $
Remote.logStatus remote key InfoMissing
Remote.logStatus NoLiveUpdate remote key InfoMissing
return $ case (movedbad, dropped) of
(True, Right ()) -> "moved from " ++ Remote.name remote ++
" to " ++ fromRawFilePath destbad

View file

@ -51,7 +51,6 @@ import qualified Limit
import Messages.JSON (DualDisp(..), ObjectMap(..))
import Annex.BloomFilter
import Annex.RepoSize
import Types.RepoSize
import qualified Command.Unused
import qualified Utility.RawFilePath as R

View file

@ -98,7 +98,7 @@ perform file key = do
)
Nothing -> lostcontent
lostcontent = logStatus key InfoMissing
lostcontent = logStatus NoLiveUpdate key InfoMissing
errorModified :: a
errorModified = giveup "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)"

View file

@ -90,7 +90,7 @@ seek o = do
, liftIO exitFailure
)
where
checkmatcher matcher = checkMatcher' matcher (matchinfo o) S.empty
checkmatcher matcher = checkMatcher' matcher (matchinfo o) NoLiveUpdate S.empty
bail :: String -> IO a
bail s = do

View file

@ -174,7 +174,7 @@ update oldkey newkey =
starting "migrate" ai (SeekInput []) $
ifM (Command.ReKey.linkKey' v oldkey newkey)
( do
logStatus newkey InfoPresent
logStatus NoLiveUpdate newkey InfoPresent
next $ return True
, next $ return False
)

View file

@ -213,7 +213,7 @@ storeReceived f = do
Nothing -> do
warning $ "Received a file " <> QuotedPath (toRawFilePath f) <> " that is not a git-annex key. Deleting this file."
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
Just k -> void $ logStatusAfter k $
Just k -> void $ logStatusAfter NoLiveUpdate k $
getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $
liftIO $ catchBoolIO $ do
R.rename (toRawFilePath f) dest

View file

@ -149,6 +149,6 @@ cleanup file newkey a = do
return (MigrationRecord sha)
)
whenM (inAnnex newkey) $
logStatus newkey InfoPresent
logStatus NoLiveUpdate newkey InfoPresent
a newkeyrec
return True

View file

@ -30,7 +30,7 @@ start (_, key) = fieldTransfer Download key $ \_p -> do
let rsp = RetrievalAllKeysSecure
ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) Nothing go)
( do
logStatus key InfoPresent
logStatus NoLiveUpdate key InfoPresent
_ <- quiesce True
return True
, return False

View file

@ -86,5 +86,5 @@ registerUrl remote key url = do
-- does not have an OtherDownloader, but this command needs to do
-- it for urls claimed by other remotes as well.
case snd (getDownloader url) of
OtherDownloader -> logChange key (Remote.uuid remote) InfoPresent
OtherDownloader -> logChange NoLiveUpdate key (Remote.uuid remote) InfoPresent
_ -> return ()

View file

@ -133,5 +133,5 @@ perform src key = do
cleanup :: Key -> CommandCleanup
cleanup key = do
logStatus key InfoPresent
logStatus NoLiveUpdate key InfoPresent
return True

View file

@ -48,5 +48,5 @@ perform file key = do
cleanup :: Key -> CommandCleanup
cleanup key = do
logStatus key InfoPresent
logStatus NoLiveUpdate key InfoPresent
return True

View file

@ -54,5 +54,5 @@ start si (KeyStatus k u s) = starting "setpresentkey" ai si $ perform k u s
perform :: Key -> UUID -> LogStatus -> CommandPerform
perform k u s = next $ do
logChange k u s
logChange NoLiveUpdate k u s
return True

View file

@ -191,7 +191,7 @@ clean' file mk passthrough discardreststdin emitpointer =
=<< lockDown cfg (fromRawFilePath file)
postingest (Just k, _) = do
logStatus k InfoPresent
logStatus NoLiveUpdate k InfoPresent
return k
postingest _ = giveup "could not add file to the annex"
@ -248,7 +248,7 @@ shouldAnnex file indexmeta moldkey = do
where
go = do
matcher <- largeFilesMatcher
checkFileMatcher' matcher file d
checkFileMatcher' NoLiveUpdate matcher file d
checkwasannexed = pure $ isJust moldkey

View file

@ -298,7 +298,7 @@ test runannex mkr mkk =
Just verifier -> do
loc <- Annex.calcRepo (gitAnnexLocation k)
verifier k loc
get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
get r k = logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case
Right v -> return (True, v)
Left _ -> return (False, UnVerified)
@ -372,13 +372,13 @@ testUnavailable runannex mkr mkk =
, check (`notElem` [Right True, Right False]) "checkPresent" $ \r k ->
Remote.checkPresent r k
, check (== Right False) "retrieveKeyFile" $ \r k ->
logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case
Right v -> return (True, v)
Left _ -> return (False, UnVerified)
, check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of
Nothing -> return False
Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
Just a -> logStatusAfter NoLiveUpdate k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->
unVerified $ isRight
<$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest))
]

View file

@ -54,7 +54,7 @@ toPerform key af remote = go Upload af $
upload' (uuid remote) key af Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case
Right () -> do
Remote.logStatus remote key InfoPresent
Remote.logStatus NoLiveUpdate remote key InfoPresent
return True
Left e -> do
warning (UnquotedString (show e))
@ -63,7 +63,7 @@ toPerform key af remote = go Upload af $
fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
fromPerform key af remote = go Upload af $
download' (uuid remote) key af Nothing stdRetry $ \p ->
logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t ->
logStatusAfter NoLiveUpdate key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t ->
tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case
Right v -> return (True, v)
Left e -> do

View file

@ -46,11 +46,11 @@ start = do
warning (UnquotedString (show e))
return False
Right () -> do
Remote.logStatus remote key InfoPresent
Remote.logStatus NoLiveUpdate remote key InfoPresent
return True
| otherwise = notifyTransfer direction af $
download' (Remote.uuid remote) key af Nothing stdRetry $ \p ->
logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
Left e -> do
warning (UnquotedString (show e))

View file

@ -67,12 +67,12 @@ start = do
warning (UnquotedString (show e))
return False
Right () -> do
Remote.logStatus remote key InfoPresent
Remote.logStatus NoLiveUpdate remote key InfoPresent
return True
runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote =
notifyTransfer Download file $
download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do
logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
Left e -> do
warning (UnquotedString (show e))

View file

@ -6,7 +6,6 @@
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
@ -21,6 +20,7 @@
module Database.RepoSize (
RepoSizeHandle,
getRepoSizeHandle,
openDb,
closeDb,
getRepoSizes,
@ -31,22 +31,20 @@ module Database.RepoSize (
) where
import Annex.Common
import Annex.LockFile
import Types.RepoSize
import Git.Types
import qualified Annex
import Database.RepoSize.Handle
import qualified Database.Handle as H
import Database.Init
import Database.Utility
import Database.Types
import Annex.LockFile
import Git.Types
import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
import qualified System.FilePath.ByteString as P
import qualified Data.Map as M
import qualified Data.Text as T
newtype RepoSizeHandle = RepoSizeHandle (Maybe H.DbHandle)
share [mkPersist sqlSettings, mkMigrate "migrateRepoSizes"] [persistLowerCase|
-- Corresponds to location log information from the git-annex branch.
@ -66,6 +64,15 @@ LiveSizeChanges
UniqueLiveSizeChange repo key
|]
{- Gets a handle to the database. It's cached in Annex state. -}
getRepoSizeHandle :: Annex RepoSizeHandle
getRepoSizeHandle = Annex.getState Annex.reposizehandle >>= \case
Just h -> return h
Nothing -> do
h <- openDb
Annex.changeState $ \s -> s { Annex.reposizehandle = Just h }
return h
{- Opens the database, creating it if it doesn't exist yet.
-
- Multiple readers and writers can have the database open at the same
@ -155,23 +162,24 @@ recordAnnexBranchCommit branchcommitsha = do
deleteWhere ([] :: [Filter AnnexBranch])
void $ insertUniqueFast $ AnnexBranch $ toSSha branchcommitsha
data SizeChange = AddingKey | RemovingKey
{- If there is already a size change for the same UUID and Key, it is
- overwritten with the new size change. -}
startingLiveSizeChange :: UUID -> Key -> SizeChange -> SqlPersistM ()
startingLiveSizeChange u k sc =
void $ upsertBy
startingLiveSizeChange :: RepoSizeHandle -> UUID -> Key -> SizeChange -> IO ()
startingLiveSizeChange (RepoSizeHandle (Just h)) u k sc =
H.commitDb h $ void $ upsertBy
(UniqueLiveSizeChange u k)
(LiveSizeChanges u k sc)
[LiveSizeChangesChange =. sc]
startingLiveSizeChange (RepoSizeHandle Nothing) _ _ _ = noop
finishedLiveSizeChange :: UUID -> Key -> SizeChange -> SqlPersistM ()
finishedLiveSizeChange u k sc = deleteWhere
[ LiveSizeChangesRepo ==. u
, LiveSizeChangesKey ==. k
, LiveSizeChangesChange ==. sc
]
finishedLiveSizeChange :: RepoSizeHandle -> UUID -> Key -> SizeChange -> IO ()
finishedLiveSizeChange (RepoSizeHandle (Just h)) u k sc =
H.commitDb h $ deleteWhere
[ LiveSizeChangesRepo ==. u
, LiveSizeChangesKey ==. k
, LiveSizeChangesChange ==. sc
]
finishedLiveSizeChange (RepoSizeHandle Nothing) _ _ _ = noop
getLiveSizeChanges :: RepoSizeHandle -> IO (M.Map UUID (Key, SizeChange))
getLiveSizeChanges (RepoSizeHandle (Just h)) = H.queryDb h $ do
@ -185,14 +193,3 @@ getLiveSizeChanges (RepoSizeHandle Nothing) = return mempty
getLiveSizeChanges' :: SqlPersistM [Entity LiveSizeChanges]
getLiveSizeChanges' = selectList [] []
instance PersistField SizeChange where
toPersistValue AddingKey = toPersistValue (1 :: Int)
toPersistValue RemovingKey = toPersistValue (-1 :: Int)
fromPersistValue b = fromPersistValue b >>= \case
(1 :: Int) -> Right AddingKey
-1 -> Right RemovingKey
v -> Left $ T.pack $ "bad serialized SizeChange "++ show v
instance PersistFieldSql SizeChange where
sqlType _ = SqlInt32

View file

@ -0,0 +1,14 @@
{- Sqlite database used to track the sizes of repositories.
-
- Copyright 2024 Joey Hess <id@joeyh.name>
-:
- Licensed under the GNU AGPL version 3 or higher.
-}
module Database.RepoSize.Handle where
import qualified Database.Handle as H
-- Contains Nothing if the database was not able to be opened due to
-- permissions.
newtype RepoSizeHandle = RepoSizeHandle (Maybe H.DbHandle)

View file

@ -18,7 +18,6 @@ import Annex.WorkTree
import Annex.UUID
import Annex.Magic
import Annex.RepoSize
import Types.RepoSize
import Logs.MaxSize
import Annex.Link
import Types.Link
@ -67,7 +66,7 @@ getMatcher = run <$> getMatcher'
run matcher i = do
(match, desc) <- runWriterT $
Utility.Matcher.matchMrun' matcher $ \o ->
matchAction o S.empty i
matchAction o NoLiveUpdate S.empty i
explain (mkActionItem i) $ UnquotedString <$>
Utility.Matcher.describeMatchResult matchDesc desc
(if match then "matches:" else "does not match:")
@ -109,7 +108,7 @@ addInclude = addLimit . limitInclude
limitInclude :: MkLimit Annex
limitInclude glob = Right $ MatchFiles
{ matchAction = const $ matchGlobFile glob
{ matchAction = const $ const $ matchGlobFile glob
, matchNeedsFileName = True
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -123,7 +122,7 @@ addExclude = addLimit . limitExclude
limitExclude :: MkLimit Annex
limitExclude glob = Right $ MatchFiles
{ matchAction = const $ not <$$> matchGlobFile glob
{ matchAction = const $ const $ not <$$> matchGlobFile glob
, matchNeedsFileName = True
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -148,7 +147,7 @@ addIncludeSameContent = addLimit . limitIncludeSameContent
limitIncludeSameContent :: MkLimit Annex
limitIncludeSameContent glob = Right $ MatchFiles
{ matchAction = const $ matchSameContentGlob glob
{ matchAction = const $ const $ matchSameContentGlob glob
, matchNeedsFileName = True
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -163,7 +162,7 @@ addExcludeSameContent = addLimit . limitExcludeSameContent
limitExcludeSameContent :: MkLimit Annex
limitExcludeSameContent glob = Right $ MatchFiles
{ matchAction = const $ not <$$> matchSameContentGlob glob
{ matchAction = const $ const $ not <$$> matchSameContentGlob glob
, matchNeedsFileName = True
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -239,7 +238,7 @@ matchMagic
-> MkLimit Annex
matchMagic limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just magic) glob =
Right $ MatchFiles
{ matchAction = const go
{ matchAction = const $ const go
, matchNeedsFileName = False
, matchNeedsFileContent = True
, matchNeedsKey = False
@ -266,7 +265,7 @@ matchMagic limitname _ _ _ Nothing _ =
addUnlocked :: Annex ()
addUnlocked = addLimit $ Right $ MatchFiles
{ matchAction = const $ matchLockStatus False
{ matchAction = const $ const $ matchLockStatus False
, matchNeedsFileName = True
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -276,7 +275,7 @@ addUnlocked = addLimit $ Right $ MatchFiles
addLocked :: Annex ()
addLocked = addLimit $ Right $ MatchFiles
{ matchAction = const $ matchLockStatus True
{ matchAction = const $ const $ matchLockStatus True
, matchNeedsFileName = True
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -311,7 +310,7 @@ addIn s = do
where
(name, date) = separate (== '@') s
use inhere a = Right $ MatchFiles
{ matchAction = checkKey . a
{ matchAction = const $ checkKey . a
, matchNeedsFileName = False
, matchNeedsFileContent = False
, matchNeedsKey = True
@ -339,7 +338,7 @@ addExpectedPresent :: Annex ()
addExpectedPresent = do
hereu <- getUUID
addLimit $ Right $ MatchFiles
{ matchAction = const $ checkKey $ \key -> do
{ matchAction = const $ const $ checkKey $ \key -> do
us <- Remote.keyLocations key
return $ hereu `elem` us
, matchNeedsFileName = False
@ -352,7 +351,7 @@ addExpectedPresent = do
{- Limit to content that is currently present on a uuid. -}
limitPresent :: Maybe UUID -> MatchFiles Annex
limitPresent u = MatchFiles
{ matchAction = const $ checkKey $ \key -> do
{ matchAction = const $ const $ checkKey $ \key -> do
hereu <- getUUID
if u == Just hereu || isNothing u
then inAnnex key
@ -369,7 +368,7 @@ limitPresent u = MatchFiles
{- Limit to content that is in a directory, anywhere in the repository tree -}
limitInDir :: FilePath -> String -> MatchFiles Annex
limitInDir dir desc = MatchFiles
{ matchAction = const go
{ matchAction = const $ const go
, matchNeedsFileName = True
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -400,7 +399,7 @@ limitCopies want = case splitc ':' want of
go num good = case readish num of
Nothing -> Left "bad number for copies"
Just n -> Right $ MatchFiles
{ matchAction = \notpresent -> checkKey $
{ matchAction = const $ \notpresent -> checkKey $
go' n good notpresent
, matchNeedsFileName = False
, matchNeedsFileContent = False
@ -425,7 +424,7 @@ addLackingCopies desc approx = addLimit . limitLackingCopies desc approx
limitLackingCopies :: String -> Bool -> MkLimit Annex
limitLackingCopies desc approx want = case readish want of
Just needed -> Right $ MatchFiles
{ matchAction = \notpresent mi -> flip checkKey mi $
{ matchAction = const $ \notpresent mi -> flip checkKey mi $
go mi needed notpresent
, matchNeedsFileName = False
, matchNeedsFileContent = False
@ -456,7 +455,7 @@ limitLackingCopies desc approx want = case readish want of
-}
limitUnused :: MatchFiles Annex
limitUnused = MatchFiles
{ matchAction = go
{ matchAction = const $ const go
, matchNeedsFileName = True
, matchNeedsFileContent = False
, matchNeedsKey = True
@ -464,9 +463,9 @@ limitUnused = MatchFiles
, matchDesc = matchDescSimple "unused"
}
where
go _ (MatchingFile _) = return False
go _ (MatchingInfo p) = maybe (pure False) isunused (providedKey p)
go _ (MatchingUserInfo p) = do
go (MatchingFile _) = return False
go (MatchingInfo p) = maybe (pure False) isunused (providedKey p)
go (MatchingUserInfo p) = do
k <- getUserInfo (userProvidedKey p)
isunused k
@ -479,7 +478,7 @@ addAnything = addLimit (Right limitAnything)
{- Limit that matches any version of any file or key. -}
limitAnything :: MatchFiles Annex
limitAnything = MatchFiles
{ matchAction = \_ _ -> return True
{ matchAction = \_ _ _ -> return True
, matchNeedsFileName = False
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -494,7 +493,7 @@ addNothing = addLimit (Right limitNothing)
{- Limit that never matches. -}
limitNothing :: MatchFiles Annex
limitNothing = MatchFiles
{ matchAction = \_ _ -> return False
{ matchAction = \_ _ _ -> return False
, matchNeedsFileName = False
, matchNeedsFileContent = False
, matchNeedsKey = False
@ -509,7 +508,7 @@ addInAllGroup groupname = addLimit $ limitInAllGroup groupMap groupname
limitInAllGroup :: Annex GroupMap -> MkLimit Annex
limitInAllGroup getgroupmap groupname = Right $ MatchFiles
{ matchAction = \notpresent mi -> do
{ matchAction = const $ \notpresent mi -> do
m <- getgroupmap
let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m
if S.null want
@ -537,7 +536,7 @@ addOnlyInGroup groupname = addLimit $ limitOnlyInGroup groupMap groupname
limitOnlyInGroup :: Annex GroupMap -> MkLimit Annex
limitOnlyInGroup getgroupmap groupname = Right $ MatchFiles
{ matchAction = \notpresent mi -> do
{ matchAction = const $ \notpresent mi -> do
m <- getgroupmap
let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m
if S.null want
@ -568,12 +567,12 @@ limitBalanced' termname fullybalanced mu groupname = do
else groupname ++ ":1"
let present = limitPresent mu
Right $ MatchFiles
{ matchAction = \a i ->
{ matchAction = \lu a i ->
ifM (Annex.getRead Annex.rebalance)
( matchAction fullybalanced a i
, matchAction present a i <||>
((not <$> matchAction copies a i)
<&&> matchAction fullybalanced a i
( matchAction fullybalanced lu a i
, matchAction present lu a i <||>
((not <$> matchAction copies lu a i)
<&&> matchAction fullybalanced lu a i
)
)
, matchNeedsFileName =
@ -659,7 +658,7 @@ limitFullyBalanced'''
-> Int
-> MkLimit Annex
limitFullyBalanced''' filtercandidates termname mu getgroupmap g n want = Right $ MatchFiles
{ matchAction = const $ checkKey $ \key -> do
{ matchAction = \lu -> const $ checkKey $ \key -> do
gm <- getgroupmap
let groupmembers = fromMaybe S.empty $
M.lookup g (uuidsByGroup gm)
@ -728,7 +727,7 @@ addInBackend = addLimit . limitInBackend
limitInBackend :: MkLimit Annex
limitInBackend name = Right $ MatchFiles
{ matchAction = const $ checkKey check
{ matchAction = const $ const $ checkKey check
, matchNeedsFileName = False
, matchNeedsFileContent = False
, matchNeedsKey = True
@ -745,7 +744,7 @@ addSecureHash = addLimit $ Right limitSecureHash
limitSecureHash :: MatchFiles Annex
limitSecureHash = MatchFiles
{ matchAction = const $ checkKey isCryptographicallySecureKey
{ matchAction = const $ const $ checkKey isCryptographicallySecureKey
, matchNeedsFileName = False
, matchNeedsFileContent = False
, matchNeedsKey = True
@ -764,7 +763,7 @@ limitSize :: LimitBy -> String -> (Maybe Integer -> Maybe Integer -> Bool) -> Mk
limitSize lb desc vs s = case readSize dataUnits s of
Nothing -> Left "bad size"
Just sz -> Right $ MatchFiles
{ matchAction = go sz
{ matchAction = const $ go sz
, matchNeedsFileName = case lb of
LimitAnnexFiles -> False
LimitDiskFiles -> True
@ -796,7 +795,7 @@ limitMetaData :: MkLimit Annex
limitMetaData s = case parseMetaDataMatcher s of
Left e -> Left e
Right (f, matching) -> Right $ MatchFiles
{ matchAction = const $ checkKey (check f matching)
{ matchAction = const $ const $ checkKey (check f matching)
, matchNeedsFileName = False
, matchNeedsFileContent = False
, matchNeedsKey = True
@ -812,7 +811,7 @@ addAccessedWithin :: Duration -> Annex ()
addAccessedWithin duration = do
now <- liftIO getPOSIXTime
addLimit $ Right $ MatchFiles
{ matchAction = const $ checkKey $ check now
{ matchAction = const $ const $ checkKey $ check now
, matchNeedsFileName = False
, matchNeedsFileContent = False
, matchNeedsKey = False

View file

@ -16,23 +16,23 @@ import qualified Remote
addWantGet :: Annex ()
addWantGet = addPreferredContentLimit "want-get" $
checkWant $ wantGet False Nothing
checkWant $ wantGet NoLiveUpdate False Nothing
addWantGetBy :: String -> Annex ()
addWantGetBy name = do
u <- Remote.nameToUUID name
addPreferredContentLimit "want-get-by" $ checkWant $ \af ->
wantGetBy False Nothing af u
wantGetBy NoLiveUpdate False Nothing af u
addWantDrop :: Annex ()
addWantDrop = addPreferredContentLimit "want-drop" $ checkWant $ \af ->
wantDrop False Nothing Nothing af (Just [])
wantDrop NoLiveUpdate False Nothing Nothing af (Just [])
addWantDropBy :: String -> Annex ()
addWantDropBy name = do
u <- Remote.nameToUUID name
addPreferredContentLimit "want-drop-by" $ checkWant $ \af ->
wantDrop False (Just u) Nothing af (Just [])
wantDrop NoLiveUpdate False (Just u) Nothing af (Just [])
addPreferredContentLimit :: String -> (MatchInfo -> Annex Bool) -> Annex ()
addPreferredContentLimit desc a = do
@ -41,7 +41,7 @@ addPreferredContentLimit desc a = do
nk <- introspectPreferredRequiredContent matchNeedsKey Nothing
nl <- introspectPreferredRequiredContent matchNeedsLocationLog Nothing
addLimit $ Right $ MatchFiles
{ matchAction = const a
{ matchAction = const $ const a
, matchNeedsFileName = nfn
, matchNeedsFileContent = nfc
, matchNeedsKey = nk

View file

@ -58,17 +58,17 @@ import qualified Data.Map as M
import qualified Data.Set as S
{- Log a change in the presence of a key's value in current repository. -}
logStatus :: Key -> LogStatus -> Annex ()
logStatus key s = do
logStatus :: LiveUpdate -> Key -> LogStatus -> Annex ()
logStatus lu key s = do
u <- getUUID
logChange key u s
logChange lu key u s
{- Run an action that gets the content of a key, and update the log
- when it succeeds. -}
logStatusAfter :: Key -> Annex Bool -> Annex Bool
logStatusAfter key a = ifM a
logStatusAfter :: LiveUpdate -> Key -> Annex Bool -> Annex Bool
logStatusAfter lu key a = ifM a
( do
logStatus key InfoPresent
logStatus lu key InfoPresent
return True
, return False
)
@ -79,8 +79,8 @@ logStatusAfter key a = ifM a
- logged to contain a key, loading the log will include the cluster's
- UUID.
-}
logChange :: Key -> UUID -> LogStatus -> Annex ()
logChange key u@(UUID _) s
logChange :: LiveUpdate -> Key -> UUID -> LogStatus -> Annex ()
logChange lu key u@(UUID _) s
| isClusterUUID u = noop
| otherwise = do
config <- Annex.getGitConfig
@ -90,8 +90,8 @@ logChange key u@(UUID _) s
s
(LogInfo (fromUUID u))
when changed $
updateRepoSize u key s
logChange _ NoUUID _ = noop
updateRepoSize lu u key s
logChange _ _ NoUUID _ = noop
{- Returns a list of repository UUIDs that, according to the log, have
- the value of a key. -}
@ -181,7 +181,7 @@ setDead key = do
Unknown -> CandidateVectorClock 0
addLog' (Annex.Branch.RegardingUUID [u]) logfile InfoDead
(info l) c
updateRepoSize u key InfoDead
updateRepoSize NoLiveUpdate u key InfoDead
data Unchecked a = Unchecked (Annex (Maybe a))

View file

@ -13,7 +13,6 @@ module Logs.MaxSize (
import qualified Annex
import Annex.Common
import Types.RepoSize
import Logs
import Logs.UUIDBased
import Logs.MapLog

View file

@ -48,19 +48,19 @@ import Limit
{- Checks if a file is preferred content (or required content) for the
- specified repository (or the current repository if none is specified). -}
isPreferredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
isPreferredContent :: LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
isPreferredContent = checkMap preferredContentMap
isRequiredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
isRequiredContent :: LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
isRequiredContent = checkMap requiredContentMap
checkMap :: Annex (FileMatcherMap Annex) -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
checkMap getmap mu notpresent mkey afile d = do
checkMap :: Annex (FileMatcherMap Annex) -> LiveUpdate -> Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
checkMap getmap lu mu notpresent mkey afile d = do
u <- maybe getUUID return mu
m <- getmap
case M.lookup u m of
Nothing -> return d
Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d)
Just matcher -> checkMatcher matcher mkey afile lu notpresent (return d) (return d)
{- Checks if the preferred or required content for the specified repository
- (or the current repository if none is specified) contains any terms

View file

@ -80,7 +80,7 @@ setUrlPresent key url = do
-- in the web.
case snd (getDownloader url) of
OtherDownloader -> return ()
_ -> logChange key webUUID InfoPresent
_ -> logChange NoLiveUpdate key webUUID InfoPresent
setUrlMissing :: Key -> URLString -> Annex ()
setUrlMissing key url = do
@ -94,7 +94,7 @@ setUrlMissing key url = do
-- for the key are web urls, the key must not be present
-- in the web.
when (isweb url && null (filter isweb $ filter (/= url) us)) $
logChange key webUUID InfoMissing
logChange NoLiveUpdate key webUUID InfoMissing
where
isweb u = case snd (getDownloader u) of
OtherDownloader -> False

View file

@ -80,7 +80,7 @@ runLocal runst runner a = case a of
iv <- startVerifyKeyContentIncrementally DefaultVerify k
let runtransfer ti =
Right <$> transfer download' k af Nothing (\p ->
logStatusAfter k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp ->
logStatusAfter NoLiveUpdate k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp ->
storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti)
let fallback = return $ Left $
ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"
@ -121,7 +121,8 @@ runLocal runst runner a = case a of
Right (Left e) -> return $ Left e
Right (Right ok) -> runner (next ok)
SetPresent k u next -> do
v <- tryNonAsync $ logChange k u InfoPresent
-- FIXME: Can a live update be done here?
v <- tryNonAsync $ logChange NoLiveUpdate k u InfoPresent
case v of
Left e -> return $ Left $ ProtoFailureException e
Right () -> runner next
@ -132,7 +133,8 @@ runLocal runst runner a = case a of
Right result -> runner (next result)
RemoveContent k mts next -> do
let cleanup = do
logStatus k InfoMissing
-- FIXME: Can a live update be done here?
logStatus NoLiveUpdate k InfoMissing
return True
let checkts = case mts of
Nothing -> return True

View file

@ -425,8 +425,8 @@ forceTrust level remotename = do
- in the local repo, not on the remote. The process of transferring the
- key to the remote, or removing the key from it *may* log the change
- on the remote, but this cannot always be relied on. -}
logStatus :: Remote -> Key -> LogStatus -> Annex ()
logStatus remote key = logChange key (uuid remote)
logStatus :: LiveUpdate -> Remote -> Key -> LogStatus -> Annex ()
logStatus lu remote key = logChange lu key (uuid remote)
{- Orders remotes by cost, with ones with the lowest cost grouped together. -}
byCost :: [Remote] -> [[Remote]]

View file

@ -495,7 +495,7 @@ dropKey' repo r st@(State connpool duc _ _ _) proof key
ifM (Annex.Content.inAnnex key)
( do
let cleanup = do
logStatus key InfoMissing
logStatus NoLiveUpdate key InfoMissing
return True
Annex.Content.lockContentForRemoval key cleanup $ \lock ->
ifM (liftIO $ checkSafeDropProofEndTime proof)
@ -509,7 +509,7 @@ dropKey' repo r st@(State connpool duc _ _ _) proof key
unless proofunexpired
safeDropProofExpired
storefanout = P2PHelper.storeFanout key InfoMissing (uuid r) . map fromB64UUID
storefanout = P2PHelper.storeFanout NoLiveUpdate key InfoMissing (uuid r) . map fromB64UUID
lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
lockKey r st key callback = do
@ -667,7 +667,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
let checksuccess = liftIO checkio >>= \case
Just err -> giveup err
Nothing -> return True
logStatusAfter key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest ->
logStatusAfter NoLiveUpdate key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest ->
metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' ->
copier object (fromRawFilePath dest) key p' checksuccess verify
)
@ -695,7 +695,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
PutOffsetResultAlreadyHavePlus fanoutuuids ->
storefanout fanoutuuids
storefanout = P2PHelper.storeFanout key InfoPresent (uuid r) . map fromB64UUID
storefanout = P2PHelper.storeFanout NoLiveUpdate key InfoPresent (uuid r) . map fromB64UUID
fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
fsckOnRemote r params

View file

@ -43,15 +43,15 @@ store remoteuuid gc runner k af o p = do
metered (Just p) sizer bwlimit $ \_ p' ->
runner (P2P.put k af p') >>= \case
Just (Just fanoutuuids) ->
storeFanout k InfoPresent remoteuuid fanoutuuids
storeFanout NoLiveUpdate k InfoPresent remoteuuid fanoutuuids
Just Nothing -> giveup "Transfer failed"
Nothing -> remoteUnavail
storeFanout :: Key -> LogStatus -> UUID -> [UUID] -> Annex ()
storeFanout k logstatus remoteuuid us =
storeFanout :: LiveUpdate -> Key -> LogStatus -> UUID -> [UUID] -> Annex ()
storeFanout lu k logstatus remoteuuid us =
forM_ us $ \u ->
when (u /= remoteuuid) $
logChange k u logstatus
logChange lu k u logstatus
retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieve gc runner k af dest p verifyconfig = do
@ -66,10 +66,10 @@ retrieve gc runner k af dest p verifyconfig = do
remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Maybe SafeDropProof -> Key -> Annex ()
remove remoteuuid runner proof k = runner (P2P.remove proof k) >>= \case
Just (Right True, alsoremoveduuids) ->
storeFanout k InfoMissing remoteuuid
storeFanout NoLiveUpdate k InfoMissing remoteuuid
(fromMaybe [] alsoremoveduuids)
Just (Right False, alsoremoveduuids) -> do
storeFanout k InfoMissing remoteuuid
storeFanout NoLiveUpdate k InfoMissing remoteuuid
(fromMaybe [] alsoremoveduuids)
giveup "removing content from remote failed"
Just (Left err, _) -> do

View file

@ -11,6 +11,7 @@ import Types.UUID (UUID)
import Types.Key (Key)
import Types.Link (LinkType)
import Types.Mime
import Types.RepoSize (LiveUpdate)
import Utility.Matcher (Matcher, Token, MatchDesc)
import Utility.FileSize
import Utility.FileSystemEncoding
@ -85,7 +86,7 @@ type MkLimit a = String -> Either String (MatchFiles a)
type AssumeNotPresent = S.Set UUID
data MatchFiles a = MatchFiles
{ matchAction :: AssumeNotPresent -> MatchInfo -> a Bool
{ matchAction :: LiveUpdate -> AssumeNotPresent -> MatchInfo -> a Bool
, matchNeedsFileName :: Bool
-- ^ does the matchAction need a filename in order to match?
, matchNeedsFileContent :: Bool

View file

@ -5,10 +5,17 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module Types.RepoSize where
import Types.UUID
import Types.Key
import Control.Concurrent
import Database.Persist.Sql hiding (Key)
import qualified Data.Text as T
-- The current size of a repo.
newtype RepoSize = RepoSize { fromRepoSize :: Integer }
deriving (Show, Eq, Ord, Num)
@ -16,3 +23,35 @@ newtype RepoSize = RepoSize { fromRepoSize :: Integer }
-- The maximum size of a repo.
newtype MaxSize = MaxSize { fromMaxSize :: Integer }
deriving (Show, Eq, Ord)
-- Used when an action is in progress that will change the current size of
-- a repository.
--
-- The live update has been recorded as starting, and filling the MVar with
-- the correct UUID, Key, and SizeChange will record the live update
-- as complete. The Bool should be True when the action successfully
-- added/removed the key from the repository.
--
-- If the MVar gets garbage collected before it is filled, the live update
-- will be removed.
--
-- This allows other concurrent changes to the same repository take
-- the changes to its size into account. If NoLiveUpdate is used, it
-- prevents that.
data LiveUpdate
= LiveUpdate (MVar ()) (MVar (Bool, UUID, Key, SizeChange))
| NoLiveUpdate
data SizeChange = AddingKey | RemovingKey
deriving (Show, Eq)
instance PersistField SizeChange where
toPersistValue AddingKey = toPersistValue (1 :: Int)
toPersistValue RemovingKey = toPersistValue (-1 :: Int)
fromPersistValue b = fromPersistValue b >>= \case
(1 :: Int) -> Right AddingKey
-1 -> Right RemovingKey
v -> Left $ T.pack $ "bad serialized SizeChange "++ show v
instance PersistFieldSql SizeChange where
sqlType _ = SqlInt32

View file

@ -154,7 +154,7 @@ upgradeDirectWorkTree = do
locs <- Direct.associatedFiles k
unlessM (anyM (Direct.goodContent k) locs) $ do
u <- getUUID
logChange k u InfoMissing
logChange NoLiveUpdate k u InfoMissing
)
writepointer f k = liftIO $ do

View file

@ -35,10 +35,6 @@ Planned schedule of work:
May not be a bug, needs reproducing and analysis.
* Check if reposizes updates works when using `git-annex transferrer`.
Eg, does the location log update happen in the parent process or in
the transferrer process?
* Concurrency issues with RepoSizes calculation and balanced content:
* What if 2 concurrent threads are considering sending two different
@ -146,6 +142,12 @@ Planned schedule of work:
also be done by just repeatedly touching a file named with the processes's
pid in it, to avoid sqlite overhead.
* Check all uses of NoLiveUpdate to see if a live update can be started and
performed there. There is one in Annex.Cluster in particular that needs a
live update
* Check for TODO XXX markers
* `git-annex info` in the limitedcalc path in cachedAllRepoData
double-counts redundant information from the journal due to using
overLocationLogs. In the other path it does not, and this should be fixed

View file

@ -786,6 +786,7 @@ Executable git-annex
Database.Queue
Database.RawFilePath
Database.RepoSize
Database.RepoSize.Handle
Database.Types
Database.Utility
Git