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:
parent
4885073377
commit
c3d40b9ec3
58 changed files with 363 additions and 247 deletions
5
Annex.hs
5
Annex.hs
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
}
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
||||
|
|
|
@ -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'
|
||||
|
|
|
@ -55,5 +55,5 @@ perform key = ifM (inAnnex key)
|
|||
|
||||
cleanup :: Key -> CommandCleanup
|
||||
cleanup key = do
|
||||
logStatus key InfoMissing
|
||||
logStatus NoLiveUpdate key InfoMissing
|
||||
return True
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -133,5 +133,5 @@ perform src key = do
|
|||
|
||||
cleanup :: Key -> CommandCleanup
|
||||
cleanup key = do
|
||||
logStatus key InfoPresent
|
||||
logStatus NoLiveUpdate key InfoPresent
|
||||
return True
|
||||
|
|
|
@ -48,5 +48,5 @@ perform file key = do
|
|||
|
||||
cleanup :: Key -> CommandCleanup
|
||||
cleanup key = do
|
||||
logStatus key InfoPresent
|
||||
logStatus NoLiveUpdate key InfoPresent
|
||||
return True
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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))
|
||||
]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
14
Database/RepoSize/Handle.hs
Normal file
14
Database/RepoSize/Handle.hs
Normal 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)
|
67
Limit.hs
67
Limit.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -13,7 +13,6 @@ module Logs.MaxSize (
|
|||
|
||||
import qualified Annex
|
||||
import Annex.Common
|
||||
import Types.RepoSize
|
||||
import Logs
|
||||
import Logs.UUIDBased
|
||||
import Logs.MapLog
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -786,6 +786,7 @@ Executable git-annex
|
|||
Database.Queue
|
||||
Database.RawFilePath
|
||||
Database.RepoSize
|
||||
Database.RepoSize.Handle
|
||||
Database.Types
|
||||
Database.Utility
|
||||
Git
|
||||
|
|
Loading…
Reference in a new issue