diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface, with handle automatically stored in the Annex monad - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -58,7 +58,7 @@ liftIO $ Git.CatFile.catObject h ref catObjectMetaData :: Git.Ref -> Annex (Maybe (Sha, Integer, ObjectType)) -catObjectMetaData ref = withCatFileHandle $ \h -> +catObjectMetaData ref = withCatFileMetaDataHandle $ \h -> liftIO $ Git.CatFile.catObjectMetaData h ref catTree :: Git.Ref -> Annex [(FilePath, FileMode)] @@ -77,32 +77,50 @@ - for each. That is selected by setting GIT_INDEX_FILE in the gitEnv - before running this. -} withCatFileHandle :: (Git.CatFile.CatFileHandle -> Annex a) -> Annex a -withCatFileHandle a = do +withCatFileHandle = withCatFileHandle' + Git.CatFile.catFileStart + catFileMap + (\v m -> v { catFileMap = m }) + +withCatFileMetaDataHandle :: (Git.CatFile.CatFileMetaDataHandle -> Annex a) -> Annex a +withCatFileMetaDataHandle = withCatFileHandle' + Git.CatFile.catFileMetaDataStart + catFileMetaDataMap + (\v m -> v { catFileMetaDataMap = m }) + +withCatFileHandle' + :: (Repo -> IO hdl) + -> (CatMap -> M.Map FilePath (ResourcePool hdl)) + -> (CatMap -> M.Map FilePath (ResourcePool hdl) -> CatMap) + -> (hdl -> Annex a) + -> Annex a +withCatFileHandle' startcat get set a = do cfh <- Annex.getState Annex.catfilehandles indexfile <- fromMaybe "" . maybe Nothing (lookup indexEnv) <$> fromRepo gitEnv p <- case cfh of - CatFileHandlesNonConcurrent m -> case M.lookup indexfile m of + CatFileHandlesNonConcurrent m -> case M.lookup indexfile (get m) of Just p -> return p Nothing -> do p <- mkResourcePoolNonConcurrent startcatfile - let !m' = M.insert indexfile p m - Annex.changeState $ \s -> s { Annex.catfilehandles = CatFileHandlesNonConcurrent m' } + let !m' = set m (M.insert indexfile p (get m)) + Annex.changeState $ \s -> s + { Annex.catfilehandles = CatFileHandlesNonConcurrent m' } return p CatFileHandlesPool tm -> do m <- liftIO $ atomically $ takeTMVar tm - case M.lookup indexfile m of + case M.lookup indexfile (get m) of Just p -> do liftIO $ atomically $ putTMVar tm m return p Nothing -> do p <- mkResourcePool maxCatFiles - let !m' = M.insert indexfile p m + let !m' = set m (M.insert indexfile p (get m)) liftIO $ atomically $ putTMVar tm m' return p withResourcePool p startcatfile a where - startcatfile = inRepo Git.CatFile.catFileStart + startcatfile = inRepo startcat {- A lot of git cat-file processes are unlikely to improve concurrency, - because a query to them takes only a little bit of CPU, and tends to be @@ -124,12 +142,14 @@ cfh <- Annex.getState Annex.catfilehandles m <- case cfh of CatFileHandlesNonConcurrent m -> do - Annex.changeState $ \s -> s { Annex.catfilehandles = CatFileHandlesNonConcurrent M.empty } + Annex.changeState $ \s -> s { Annex.catfilehandles = CatFileHandlesNonConcurrent emptyCatMap } return m CatFileHandlesPool tm -> - liftIO $ atomically $ swapTMVar tm M.empty - liftIO $ forM_ (M.elems m) $ \p -> + liftIO $ atomically $ swapTMVar tm emptyCatMap + liftIO $ forM_ (M.elems (catFileMap m)) $ \p -> freeResourcePool p Git.CatFile.catFileStop + liftIO $ forM_ (M.elems (catFileMetaDataMap m)) $ \p -> + freeResourcePool p Git.CatFile.catFileMetaDataStop {- From ref to a symlink or a pointer file, get the key. -} catKey :: Ref -> Annex (Maybe Key) @@ -178,11 +198,12 @@ catKeyFile :: RawFilePath -> Annex (Maybe Key) catKeyFile f = ifM (Annex.getState Annex.daemon) ( catKeyFileHEAD f - , catKey =<< liftIO (Git.Ref.fileRef f) + , maybe (pure Nothing) catKey =<< inRepo (Git.Ref.fileRef f) ) catKeyFileHEAD :: RawFilePath -> Annex (Maybe Key) -catKeyFileHEAD f = catKey =<< liftIO (Git.Ref.fileFromRef Git.Ref.headRef f) +catKeyFileHEAD f = maybe (pure Nothing) catKey + =<< inRepo (Git.Ref.fileFromRef Git.Ref.headRef f) {- Look in the original branch from whence an adjusted branch is based - to find the file. But only when the adjustment hides some files. -} @@ -195,5 +216,6 @@ hiddenCat :: (Ref -> Annex (Maybe a)) -> RawFilePath -> CurrBranch -> Annex (Maybe a) hiddenCat a f (Just origbranch, Just adj) | adjustmentHidesFiles adj = - a =<< liftIO (Git.Ref.fileFromRef origbranch f) + maybe (pure Nothing) a + =<< inRepo (Git.Ref.fileFromRef origbranch f) hiddenCat _ _ _ = return Nothing diff --git a/Annex/CopyFile.hs b/Annex/CopyFile.hs --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -27,18 +27,32 @@ newCopyCoWTried :: IO CopyCoWTried newCopyCoWTried = CopyCoWTried <$> newEmptyMVar -{- Copies a file is copy-on-write is supported. Otherwise, returns False. -} +{- Copies a file is copy-on-write is supported. Otherwise, returns False. + - + - The destination file must not exist yet, or it will fail to make a CoW copy, + - and will return false. + -} tryCopyCoW :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> IO Bool tryCopyCoW (CopyCoWTried copycowtried) src dest meterupdate = -- If multiple threads reach this at the same time, they -- will both try CoW, which is acceptable. ifM (isEmptyMVar copycowtried) - ( do - ok <- docopycow - void $ tryPutMVar copycowtried ok - return ok + -- If dest exists, don't try CoW, since it would + -- have to be deleted first. + ( ifM (doesFileExist dest) + ( return False + , do + ok <- docopycow + void $ tryPutMVar copycowtried ok + return ok + ) , ifM (readMVar copycowtried) - ( docopycow + ( do + -- CoW is known to work, so delete + -- dest if it exists in order to do a fast + -- CoW copy. + void $ tryIO $ removeFile dest + docopycow , return False ) ) diff --git a/Annex/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -18,6 +18,7 @@ import Messages import Data.Maybe +import qualified Data.ByteString.Short as S (fromShort, toShort) -- From a sha pointing to the content of a file to the key -- to use to export it. When the file is annexed, it's the annexed key. @@ -39,7 +40,7 @@ -- only checksum the content. gitShaKey :: Git.Sha -> Key gitShaKey (Git.Ref s) = mkKey $ \kd -> kd - { keyName = s + { keyName = S.toShort s , keyVariety = OtherKey "GIT" } @@ -47,7 +48,7 @@ keyGitSha :: Key -> Maybe Git.Sha keyGitSha k | fromKey keyVariety k == OtherKey "GIT" = - Just (Git.Ref (fromKey keyName k)) + Just (Git.Ref (S.fromShort (fromKey keyName k))) | otherwise = Nothing -- Is a key storing a git sha, and not used for an annexed file? diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -1,6 +1,6 @@ {- git-annex import from remotes - - - Copyright 2019-2020 Joey Hess + - Copyright 2019-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -98,7 +98,7 @@ :: Remote -> ImportTreeConfig -> ImportCommitConfig - -> ImportableContents (Either Sha Key) + -> ImportableContentsChunkable Annex (Either Sha Key) -> Annex (Maybe Ref) buildImportCommit remote importtreeconfig importcommitconfig importable = case importCommitTracking importcommitconfig of @@ -123,7 +123,7 @@ recordImportTree :: Remote -> ImportTreeConfig - -> ImportableContents (Either Sha Key) + -> ImportableContentsChunkable Annex (Either Sha Key) -> Annex (History Sha, Annex ()) recordImportTree remote importtreeconfig importable = do imported@(History finaltree _) <- buildImportTrees basetree subdir importable @@ -264,25 +264,75 @@ buildImportTrees :: Ref -> Maybe TopFilePath + -> ImportableContentsChunkable Annex (Either Sha Key) + -> Annex (History Sha) +buildImportTrees basetree msubdir (ImportableContentsComplete importable) = do + repo <- Annex.gitRepo + withMkTreeHandle repo $ buildImportTrees' basetree msubdir importable +buildImportTrees basetree msubdir importable@(ImportableContentsChunked {}) = do + repo <- Annex.gitRepo + withMkTreeHandle repo $ \hdl -> + History + <$> go hdl + <*> buildImportTreesHistory basetree msubdir + (importableHistoryComplete importable) hdl + where + go hdl = do + tree <- gochunks [] (importableContentsChunk importable) hdl + importtree <- liftIO $ recordTree' hdl tree + graftImportTree basetree msubdir importtree hdl + + gochunks l c hdl = do + let subdir = importChunkSubDir $ importableContentsSubDir c + -- Full directory prefix where the sub tree is located. + let fullprefix = asTopFilePath $ case msubdir of + Nothing -> subdir + Just d -> getTopFilePath d Posix. subdir + Tree ts <- convertImportTree (Just fullprefix) $ + map (\(p, i) -> (mkImportLocation p, i)) + (importableContentsSubTree c) + -- Record this subtree before getting next chunk, this + -- avoids buffering all the chunks into memory. + tc <- liftIO $ recordSubTree hdl $ + NewSubTree (asTopFilePath subdir) ts + importableContentsNextChunk c >>= \case + Nothing -> return (Tree (tc:l)) + Just c' -> gochunks (tc:l) c' hdl + +buildImportTrees' + :: Ref + -> Maybe TopFilePath -> ImportableContents (Either Sha Key) + -> MkTreeHandle -> Annex (History Sha) -buildImportTrees basetree msubdir importable = History - <$> (buildtree (importableContents importable) =<< Annex.gitRepo) - <*> buildhistory +buildImportTrees' basetree msubdir importable hdl = History + <$> buildImportTree basetree msubdir (importableContents importable) hdl + <*> buildImportTreesHistory basetree msubdir (importableHistory importable) hdl + +buildImportTree + :: Ref + -> Maybe TopFilePath + -> [(ImportLocation, Either Sha Key)] + -> MkTreeHandle + -> Annex Sha +buildImportTree basetree msubdir ls hdl = do + importtree <- liftIO . recordTree' hdl =<< convertImportTree msubdir ls + graftImportTree basetree msubdir importtree hdl + +graftImportTree + :: Ref + -> Maybe TopFilePath + -> Sha + -> MkTreeHandle + -> Annex Sha +graftImportTree basetree msubdir tree hdl = case msubdir of + Nothing -> return tree + Just subdir -> inRepo $ \repo -> + graftTree' tree subdir basetree repo hdl + +convertImportTree :: Maybe TopFilePath -> [(ImportLocation, Either Sha Key)] -> Annex Tree +convertImportTree msubdir ls = treeItemsToTree <$> mapM mktreeitem ls where - buildhistory = S.fromList - <$> mapM (buildImportTrees basetree msubdir) - (importableHistory importable) - - buildtree ls repo = withMkTreeHandle repo $ \hdl -> do - importtree <- liftIO . recordTree' hdl - . treeItemsToTree - =<< mapM mktreeitem ls - case msubdir of - Nothing -> return importtree - Just subdir -> liftIO $ - graftTree' importtree subdir basetree repo hdl - mktreeitem (loc, v) = case v of Right k -> do relf <- fromRepo $ fromTopFilePath topf @@ -297,6 +347,15 @@ topf = asTopFilePath $ maybe lf (\sd -> getTopFilePath sd P. lf) msubdir +buildImportTreesHistory + :: Ref + -> Maybe TopFilePath + -> [ImportableContents (Either Sha Key)] + -> MkTreeHandle + -> Annex (S.Set (History Sha)) +buildImportTreesHistory basetree msubdir history hdl = S.fromList + <$> mapM (\ic -> buildImportTrees' basetree msubdir ic hdl) history + canImportKeys :: Remote -> Bool -> Bool canImportKeys remote importcontent = importcontent || isJust (Remote.importKey ia) @@ -324,8 +383,8 @@ -> ImportTreeConfig -> Bool -> Bool - -> ImportableContents (ContentIdentifier, ByteSize) - -> Annex (Maybe (ImportableContents (Either Sha Key))) + -> ImportableContentsChunkable Annex (ContentIdentifier, ByteSize) + -> Annex (Maybe (ImportableContentsChunkable Annex (Either Sha Key))) importKeys remote importtreeconfig importcontent thirdpartypopulated importablecontents = do unless (canImportKeys remote importcontent) $ giveup "This remote does not support importing without downloading content." @@ -339,40 +398,82 @@ -- When concurrency is enabled, this set is needed to -- avoid two threads both importing the same content identifier. importing <- liftIO $ newTVarIO S.empty - withExclusiveLock gitAnnexContentIdentifierLock $ - bracket CIDDb.openDb CIDDb.closeDb $ \db -> do - CIDDb.needsUpdateFromLog db - >>= maybe noop (CIDDb.updateFromLog db) - (run (go False cidmap importing importablecontents db)) + withciddb $ \db -> do + CIDDb.needsUpdateFromLog db + >>= maybe noop (CIDDb.updateFromLog db) + (prepclock (run cidmap importing db)) where -- When not importing content, reuse the same vector -- clock for all state that's recorded. This can save -- a little bit of disk space. Individual file downloads -- while downloading take too long for this optimisation -- to be safe to do. - run a + prepclock a | importcontent = a | otherwise = reuseVectorClockWhile a - go oldversion cidmap importing (ImportableContents l h) db = do + withciddb = withExclusiveLock gitAnnexContentIdentifierLock . + bracket CIDDb.openDb CIDDb.closeDb + + run cidmap importing db = do largematcher <- largeFilesMatcher + case importablecontents of + ImportableContentsComplete ic -> + go False largematcher cidmap importing db ic >>= return . \case + Nothing -> Nothing + Just v -> Just $ ImportableContentsComplete v + ImportableContentsChunked {} -> do + c <- gochunked db (importableContentsChunk importablecontents) + gohistory largematcher cidmap importing db (importableHistoryComplete importablecontents) >>= return . \case + Nothing -> Nothing + Just h -> Just $ ImportableContentsChunked + { importableContentsChunk = c + , importableHistoryComplete = h + } + + go oldversion largematcher cidmap importing db (ImportableContents l h) = do jobs <- forM l $ \i -> if thirdpartypopulated - then thirdpartypopulatedimport cidmap db i + then Left <$> thirdpartypopulatedimport db i else startimport cidmap importing db i oldversion largematcher l' <- liftIO $ forM jobs $ either pure (atomically . takeTMVar) if any isNothing l' then return Nothing - else do - h' <- mapM (\ic -> go True cidmap importing ic db) h - if any isNothing h' - then return Nothing - else return $ Just $ - ImportableContents - (catMaybes l') - (catMaybes h') + else gohistory largematcher cidmap importing db h >>= return . \case + Nothing -> Nothing + Just h' -> Just $ ImportableContents (catMaybes l') h' + gohistory largematcher cidmap importing db h = do + h' <- mapM (go True largematcher cidmap importing db) h + if any isNothing h' + then return Nothing + else return $ Just $ catMaybes h' + + gochunked db c + -- Downloading cannot be done when chunked, since only + -- the first chunk is processed before returning. + | importcontent = error "importKeys does not support downloading chunked import" + -- Chunked import is currently only used by thirdpartypopulated + -- remotes. + | not thirdpartypopulated = error "importKeys does not support chunked import when not thirdpartypopulated" + | otherwise = do + l <- forM (importableContentsSubTree c) $ \(loc, i) -> do + let loc' = importableContentsChunkFullLocation (importableContentsSubDir c) loc + thirdpartypopulatedimport db (loc', i) >>= return . \case + Just (_loc, k) -> Just (loc, k) + Nothing -> Nothing + return $ ImportableContentsChunk + { importableContentsSubDir = importableContentsSubDir c + , importableContentsSubTree = catMaybes l + , importableContentsNextChunk = + importableContentsNextChunk c >>= \case + Nothing -> return Nothing + Just c' -> withciddb $ \db' -> + prepclock $ + Just <$> gochunked db' c' + } + waitstart importing cid = liftIO $ atomically $ do s <- readTVar importing if S.member cid s @@ -418,19 +519,19 @@ importaction return (Right job) - thirdpartypopulatedimport cidmap db (loc, (cid, sz)) = + thirdpartypopulatedimport db (loc, (cid, sz)) = case Remote.importKey ia of - Nothing -> return $ Left Nothing + Nothing -> return Nothing Just importkey -> tryNonAsync (importkey loc cid sz nullMeterUpdate) >>= \case Right (Just k) -> do - recordcidkey cidmap db cid k - logChange k (Remote.uuid remote) InfoPresent - return $ Left $ Just (loc, Right k) - Right Nothing -> return $ Left Nothing + recordcidkey' db cid k + logChange k (Remote.uuid remote) InfoPresent + return $ Just (loc, Right k) + Right Nothing -> return Nothing Left e -> do warning (show e) - return $ Left Nothing + return Nothing importordownload cidmap db (loc, (cid, sz)) largematcher= do f <- locworktreefile loc @@ -461,8 +562,9 @@ , providedMimeEncoding = Nothing , providedLinkType = Nothing } + let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote) islargefile <- checkMatcher' matcher mi mempty - metered Nothing sz $ const $ if islargefile + metered Nothing sz bwlimit $ const $ if islargefile then doimportlarge importkey cidmap db loc cid sz f else doimportsmall cidmap db loc cid sz @@ -557,11 +659,12 @@ Left e -> do warning (show e) return Nothing + let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote) checkDiskSpaceToGet tmpkey Nothing $ notifyTransfer Download af $ download' (Remote.uuid remote) tmpkey af Nothing stdRetry $ \p -> withTmp tmpkey $ \tmpfile -> - metered (Just p) tmpkey $ + metered (Just p) tmpkey bwlimit $ const (rundownload tmpfile) where tmpkey = importKey cid sz @@ -601,6 +704,8 @@ recordcidkey cidmap db cid k = do liftIO $ atomically $ modifyTVar' cidmap $ M.insert cid k + recordcidkey' db cid k + recordcidkey' db cid k = do liftIO $ CIDDb.recordContentIdentifier db rs cid k CIDLog.recordContentIdentifier rs cid k @@ -673,18 +778,38 @@ - Throws exception if unable to contact the remote. - Returns Nothing when there is no change since last time. -} -getImportableContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> FileMatcher Annex -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +getImportableContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> FileMatcher Annex -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) getImportableContents r importtreeconfig ci matcher = do Remote.listImportableContents (Remote.importActions r) >>= \case - Just importable -> do - dbhandle <- Export.openDb (Remote.uuid r) - Just <$> filterunwanted dbhandle importable + Just (ImportableContentsComplete ic) -> do + dbhandle <- opendbhandle + Just . ImportableContentsComplete + <$> filterunwanted dbhandle ic + Just (c@(ImportableContentsChunked {})) -> do + dbhandle <- opendbhandle + Just <$> filterunwantedchunked dbhandle c Nothing -> return Nothing where filterunwanted dbhandle ic = ImportableContents <$> filterM (wanted dbhandle) (importableContents ic) <*> mapM (filterunwanted dbhandle) (importableHistory ic) + filterunwantedchunked dbhandle c = ImportableContentsChunked + <$> filterunwantedchunk dbhandle (importableContentsChunk c) + <*> mapM (filterunwanted dbhandle) (importableHistoryComplete c) + + filterunwantedchunk dbhandle c = ImportableContentsChunk + <$> pure (importableContentsSubDir c) + <*> filterM (wantedunder dbhandle (importableContentsSubDir c)) + (importableContentsSubTree c) + <*> pure ( + importableContentsNextChunk c >>= \case + Nothing -> return Nothing + Just c' -> Just <$> filterunwantedchunk dbhandle c' + ) + + opendbhandle = Export.openDb (Remote.uuid r) + wanted dbhandle (loc, (_cid, sz)) | ingitdir = pure False | otherwise = @@ -695,6 +820,9 @@ matches = matchesImportLocation matcher loc sz isknown = isKnownImportLocation dbhandle loc notignored = notIgnoredImportLocation importtreeconfig ci loc + + wantedunder dbhandle root (loc, v) = + wanted dbhandle (importableContentsChunkFullLocation root loc, v) isKnownImportLocation :: Export.ExportHandle -> ImportLocation -> Annex Bool isKnownImportLocation dbhandle loc = liftIO $ diff --git a/Annex/StallDetection.hs b/Annex/StallDetection.hs --- a/Annex/StallDetection.hs +++ b/Annex/StallDetection.hs @@ -22,7 +22,7 @@ detectStalls :: (Monad m, MonadIO m) => Maybe StallDetection -> TVar (Maybe BytesProcessed) -> m () -> m () detectStalls Nothing _ _ = noop detectStalls (Just StallDetectionDisabled) _ _ = noop -detectStalls (Just (StallDetection minsz duration)) metervar onstall = +detectStalls (Just (StallDetection (BwRate minsz duration))) metervar onstall = detectStalls' minsz duration metervar onstall Nothing detectStalls (Just ProbeStallDetection) metervar onstall = do -- Only do stall detection once the progress is confirmed to be diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -19,7 +19,6 @@ noRetry, stdRetry, pickRemote, - stallDetection, ) where import Annex.Common @@ -55,10 +54,11 @@ -- Upload, supporting canceling detected stalls. upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool -upload r key f d witness = stallDetection r >>= \case - Nothing -> go (Just ProbeStallDetection) - Just StallDetectionDisabled -> go Nothing - Just sd -> runTransferrer sd r key f d Upload witness +upload r key f d witness = + case remoteAnnexStallDetection (Remote.gitconfig r) of + Nothing -> go (Just ProbeStallDetection) + Just StallDetectionDisabled -> go Nothing + Just sd -> runTransferrer sd r key f d Upload witness where go sd = upload' (Remote.uuid r) key f sd d (action . Remote.storeKey r key f) witness @@ -73,10 +73,11 @@ -- Download, supporting canceling detected stalls. download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool -download r key f d witness = logStatusAfter key $ stallDetection r >>= \case - Nothing -> go (Just ProbeStallDetection) - Just StallDetectionDisabled -> go Nothing - Just sd -> runTransferrer sd r key f d Download witness +download r key f d witness = logStatusAfter key $ + case remoteAnnexStallDetection (Remote.gitconfig r) of + Nothing -> go (Just ProbeStallDetection) + Just StallDetectionDisabled -> go Nothing + Just sd -> runTransferrer sd r key f d Download witness where go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f $ \dest -> download' (Remote.uuid r) key f sd d (go' dest) witness @@ -400,9 +401,3 @@ lessActiveFirst active a b | Remote.cost a == Remote.cost b = comparing (`M.lookup` active) a b | otherwise = comparing Remote.cost a b - -stallDetection :: Remote -> Annex (Maybe StallDetection) -stallDetection r = maybe globalcfg (pure . Just) remotecfg - where - globalcfg = annexStallDetection <$> Annex.getGitConfig - remotecfg = remoteAnnexStallDetection $ Remote.gitconfig r diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -96,7 +96,7 @@ -- with the size, which is why it's important the -- meter is passed into commandMeter' let unknownsize = Nothing :: Maybe FileSize - ok <- metered (Just p) unknownsize $ \meter meterupdate -> + ok <- metered (Just p) unknownsize Nothing $ \meter meterupdate -> liftIO $ commandMeter' parseYoutubeDlProgress oh (Just meter) meterupdate cmd opts (\pr -> pr { cwd = Just workdir }) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -89,7 +89,7 @@ runWatcher = do startup <- asIO1 startupScan symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig - addhook <- hook $ onAddUnlocked symlinkssupported + addhook <- hook $ onAddFile symlinkssupported delhook <- hook onDel addsymlinkhook <- hook onAddSymlink deldirhook <- hook onDelDir @@ -194,11 +194,11 @@ shouldRestage :: DaemonStatus -> Bool shouldRestage ds = scanComplete ds || forceRestage ds -onAddUnlocked :: Bool -> Handler -onAddUnlocked symlinkssupported f fs = do +onAddFile :: Bool -> Handler +onAddFile symlinkssupported f fs = do mk <- liftIO $ isPointerFile $ toRawFilePath f case mk of - Nothing -> onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported f fs + Nothing -> onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported f fs Just k -> addlink f k where addassociatedfile key file = @@ -222,14 +222,14 @@ liftAnnex $ stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key madeChange file $ LinkChange (Just key) -onAddUnlocked' +onAddFile' :: (Key -> FilePath -> Annex ()) -> (Key -> FilePath -> Annex ()) -> (FilePath -> Key -> Assistant (Maybe Change)) -> (Key -> FilePath -> FileStatus -> Annex Bool) -> Bool -> Handler -onAddUnlocked' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do +onAddFile' contentchanged addassociatedfile addlink samefilestatus symlinkssupported file fs = do v <- liftAnnex $ catKeyFile (toRawFilePath file) case (v, fs) of (Just key, Just filestatus) -> diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -24,7 +24,6 @@ import Assistant.Alert.Utility import Assistant.Commits import Assistant.Drop -import Annex.Transfer (stallDetection) import Types.Transfer import Logs.Transfer import Logs.Location @@ -126,7 +125,8 @@ ( do debug [ "Transferring:" , describeTransfer t info ] notifyTransfer - sd <- liftAnnex $ stallDetection remote + let sd = remoteAnnexStallDetection + (Remote.gitconfig remote) return $ Just (t, info, go remote sd) , do debug [ "Skipping unnecessary transfer:", diff --git a/Backend.hs b/Backend.hs --- a/Backend.hs +++ b/Backend.hs @@ -33,7 +33,6 @@ import qualified Backend.External import qualified Data.Map as M -import qualified Data.ByteString.Char8 as S8 {- Build-in backends. Does not include externals. -} builtinList :: [Backend] @@ -61,17 +60,9 @@ case B.genKey b of Just a -> do k <- a source meterupdate - return (makesane k, b) + return (k, b) Nothing -> giveup $ "Cannot generate a key for backend " ++ decodeBS (formatKeyVariety (B.backendVariety b)) - where - -- keyNames should not contain newline characters. - makesane k = alterKey k $ \d -> d - { keyName = S8.map fixbadchar (fromKey keyName k) - } - fixbadchar c - | c == '\n' = '_' - | otherwise = c getBackend :: FilePath -> Key -> Annex (Maybe Backend) getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case diff --git a/Backend/External.hs b/Backend/External.hs --- a/Backend/External.hs +++ b/Backend/External.hs @@ -20,6 +20,7 @@ import qualified Utility.SimpleProtocol as Proto import qualified Data.ByteString as S +import qualified Data.ByteString.Short as S (toShort, fromShort) import qualified Data.Map.Strict as M import Data.Char import Control.Concurrent @@ -285,7 +286,7 @@ -- The extension can be easily removed, because the protocol -- documentation does not allow '.' to be used in the keyName, -- so the first one is the extension. - { keyName = S.takeWhile (/= dot) (keyName d) + { keyName = S.toShort (S.takeWhile (/= dot) (S.fromShort (keyName d))) , keyVariety = setHasExt (HasExt False) (keyVariety d) } where diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -24,6 +24,7 @@ import qualified Utility.RawFilePath as R import qualified Data.ByteString as S +import qualified Data.ByteString.Short as S (toShort, fromShort) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Control.DeepSeq @@ -106,7 +107,7 @@ filesize <- liftIO $ getFileSize file s <- hashFile hash file meterupdate return $ mkKey $ \k -> k - { keyName = encodeBS s + { keyName = S.toShort (encodeBS s) , keyVariety = hashKeyVariety hash (HasExt False) , keySize = Just filesize } @@ -160,7 +161,7 @@ needsUpgrade key = or [ "\\" `S8.isPrefixOf` keyHash key , S.any (not . validInExtension) (snd $ splitKeyNameExtension key) - , not (hasExt (fromKey keyVariety key)) && keyHash key /= fromKey keyName key + , not (hasExt (fromKey keyVariety key)) && keyHash key /= S.fromShort (fromKey keyName key) ] trivialMigrate :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key) @@ -171,14 +172,14 @@ trivialMigrate' oldkey newbackend afile maxextlen {- Fast migration from hashE to hash backend. -} | migratable && hasExt oldvariety = Just $ alterKey oldkey $ \d -> d - { keyName = keyHash oldkey + { keyName = S.toShort (keyHash oldkey) , keyVariety = newvariety } {- Fast migration from hash to hashE backend. -} | migratable && hasExt newvariety = case afile of AssociatedFile Nothing -> Nothing AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d - { keyName = keyHash oldkey + { keyName = S.toShort $ keyHash oldkey <> selectExtension maxextlen file , keyVariety = newvariety } @@ -186,9 +187,9 @@ - non-extension preserving key, with an extension - in its keyName. -} | newvariety == oldvariety && not (hasExt oldvariety) && - keyHash oldkey /= fromKey keyName oldkey = + keyHash oldkey /= S.fromShort (fromKey keyName oldkey) = Just $ alterKey oldkey $ \d -> d - { keyName = keyHash oldkey + { keyName = S.toShort (keyHash oldkey) } | otherwise = Nothing where diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -16,6 +16,7 @@ import Types.KeySource import qualified Data.ByteString as S +import qualified Data.ByteString.Short as S (ShortByteString, toShort) import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P import Data.Char @@ -25,13 +26,13 @@ - If it's not too long, the full string is used as the keyName. - Otherwise, it's truncated, and its md5 is prepended to ensure a unique - key. -} -genKeyName :: String -> S.ByteString +genKeyName :: String -> S.ShortByteString genKeyName s -- Avoid making keys longer than the length of a SHA256 checksum. - | bytelen > sha256len = encodeBS $ + | bytelen > sha256len = S.toShort $ encodeBS $ truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++ show (md5 bl) - | otherwise = encodeBS s' + | otherwise = S.toShort $ encodeBS s' where s' = preSanitizeKeyName s bl = encodeBL s @@ -47,7 +48,7 @@ maxlen <- annexMaxExtensionLength <$> Annex.getGitConfig let ext = selectExtension maxlen (keyFilename source) return $ alterKey k $ \d -> d - { keyName = keyName d <> ext + { keyName = keyName d <> S.toShort ext , keyVariety = sethasext (keyVariety d) } diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -17,6 +17,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Utility.RawFilePath as R +import qualified Data.ByteString.Short as S (toShort, fromShort) backends :: [Backend] backends = [backend] @@ -53,12 +54,13 @@ {- Old WORM keys could contain spaces and carriage returns, - and can be upgraded to remove them. -} needsUpgrade :: Key -> Bool -needsUpgrade key = any (`S8.elem` fromKey keyName key) [' ', '\r'] +needsUpgrade key = + any (`S8.elem` S.fromShort (fromKey keyName key)) [' ', '\r'] removeProblemChars :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key) removeProblemChars oldkey newbackend _ | migratable = return $ Just $ alterKey oldkey $ \d -> d - { keyName = encodeBS $ reSanitizeKeyName $ decodeBS $ keyName d } + { keyName = S.toShort $ encodeBS $ reSanitizeKeyName $ decodeBS $ S.fromShort $ keyName d } | otherwise = return Nothing where migratable = oldvariety == newvariety diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -30,6 +30,7 @@ , TestCase "rsync" $ testCmd "rsync" "rsync --version >/dev/null" , TestCase "curl" $ testCmd "curl" "curl --version >/dev/null" , TestCase "bup" $ testCmd "bup" "bup --version >/dev/null" + , TestCase "borg" $ testCmd "borg" "borg --version >/dev/null" , TestCase "nice" $ testCmd "nice" "nice true >/dev/null" , TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null" , TestCase "nocache" $ testCmd "nocache" "nocache true >/dev/null" diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,26 @@ +git-annex (8.20211011) upstream; urgency=medium + + * Added annex.bwlimit and remote.name.annex-bwlimit config to limit + the bandwidth of transfers. It works for git remotes and many + but not all special remotes. + * Bug fix: Git configs such as annex.verify were incorrectly overriding + per-remote git configs such as remote.name.annex-verify. + (Reversion in version 4.20130323) + * borg: Significantly improved memory use when a borg repository + contains many archives. + * borg: Avoid trying to extract xattrs, ACLS, and bsdflags when + retrieving from a borg repository. + * Sped up git-annex smudge --clean by 25%. + * Resume where it left off when copying a file to/from a local git remote + was interrupted. + * sync --content: Avoid a redundant checksum of a file that was + incrementally verified, when used on NTFS and perhaps other filesystems. + * reinject: Fix crash when reinjecting a file from outside the repository. + (Reversion in version 8.20210621) + * Avoid cursor jitter when updating progress display. + + -- Joey Hess Mon, 11 Oct 2021 12:52:14 -0400 + git-annex (8.20210903) upstream; urgency=medium * Deal with clock skew, both forwards and backwards, when logging diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -192,7 +192,7 @@ } ld <- lockDown cfg (fromRawFilePath file) let sizer = keySource <$> ld - v <- metered Nothing sizer $ \_meter meterupdate -> + v <- metered Nothing sizer Nothing $ \_meter meterupdate -> ingestAdd (checkGitIgnoreOption o) meterupdate ld finish v where diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -10,6 +10,7 @@ import Data.Default import qualified Data.Map as M import qualified Data.ByteString as S +import qualified Data.ByteString.Short as S (fromShort) import qualified Data.ByteString.Char8 as S8 import Command @@ -100,7 +101,7 @@ , ("backend", decodeBS $ formatKeyVariety $ fromKey keyVariety key) , ("bytesize", size show) , ("humansize", size $ roughSize storageUnits True) - , ("keyname", decodeBS $ fromKey keyName key) + , ("keyname", decodeBS $ S.fromShort $ fromKey keyName key) , ("hashdirlower", fromRawFilePath $ hashDirLower def key) , ("hashdirmixed", fromRawFilePath $ hashDirMixed def key) , ("mtime", whenavail show $ fromKey keyMtime key) diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -346,7 +346,7 @@ fromtrackingbranch a = inRepo $ a (fromRemoteTrackingBranch tb) -listContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart +listContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> TVar (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, Remote.ByteSize))) -> CommandStart listContents remote importtreeconfig ci tvar = starting "list" ai si $ listContents' remote importtreeconfig ci $ \importable -> do liftIO $ atomically $ writeTVar tvar importable @@ -355,7 +355,7 @@ ai = ActionItemOther (Just (Remote.name remote)) si = SeekInput [] -listContents' :: Remote -> ImportTreeConfig -> CheckGitIgnore -> (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize)) -> Annex a) -> Annex a +listContents' :: Remote -> ImportTreeConfig -> CheckGitIgnore -> (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, Remote.ByteSize)) -> Annex a) -> Annex a listContents' remote importtreeconfig ci a = makeImportMatcher remote >>= \case Right matcher -> tryNonAsync (getImportableContents remote importtreeconfig ci matcher) >>= \case @@ -368,7 +368,7 @@ , err ] -commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents (Either Sha Key) -> CommandStart +commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContentsChunkable Annex (Either Sha Key) -> CommandStart commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = starting "update" ai si $ do importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -30,6 +30,7 @@ import Utility.InodeCache import Config.GitConfig import qualified Types.Backend +import qualified Annex.BranchState import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -87,6 +88,7 @@ -- injested content if so. Otherwise, the original content. clean :: RawFilePath -> CommandStart clean file = do + Annex.BranchState.disableUpdate -- optimisation b <- liftIO $ L.hGetContents stdin ifM fileoutsiderepo ( liftIO $ L.hPut stdout b @@ -103,13 +105,14 @@ addingExistingLink file k $ do getMoveRaceRecovery k file liftIO $ L.hPut stdout b - Nothing -> do - fileref <- liftIO $ Git.Ref.fileRef file - indexmeta <- catObjectMetaData fileref - oldkey <- case indexmeta of - Just (_, sz, _) -> catKey' fileref sz - Nothing -> return Nothing - go' b indexmeta oldkey + Nothing -> inRepo (Git.Ref.fileRef file) >>= \case + Just fileref -> do + indexmeta <- catObjectMetaData fileref + oldkey <- case indexmeta of + Just (_, sz, _) -> catKey' fileref sz + Nothing -> return Nothing + go' b indexmeta oldkey + Nothing -> liftIO $ L.hPut stdout b go' b indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) ( do -- Before git 2.5, failing to consume all stdin here diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -809,10 +809,11 @@ let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs got <- anyM id =<< handleget have inhere - putrs <- handleput lack + let inhere' = inhere || got + putrs <- handleput lack inhere' u <- getUUID - let locs' = concat [if inhere || got then [u] else [], putrs, locs] + let locs' = concat [if inhere' then [u] else [], putrs, locs] -- To handle --all, a bloom filter is populated with all the keys -- of files in the working tree in the first pass. On the second @@ -855,14 +856,15 @@ | Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False | isThirdPartyPopulated r = return False | otherwise = wantSend True (Just k) af (Remote.uuid r) - handleput lack = catMaybes <$> ifM (inAnnex k) - ( forM lack $ \r -> - ifM (wantput r <&&> put r) - ( return (Just (Remote.uuid r)) - , return Nothing - ) - , return [] - ) + handleput lack inhere + | inhere = catMaybes <$> + ( forM lack $ \r -> + ifM (wantput r <&&> put r) + ( return (Just (Remote.uuid r)) + , return Nothing + ) + ) + | otherwise = return [] put dest = includeCommandAction $ Command.Move.toStart' dest Command.Move.RemoveNever af k ai si diff --git a/Crypto.hs b/Crypto.hs --- a/Crypto.hs +++ b/Crypto.hs @@ -47,6 +47,7 @@ import Types.Remote import Types.Key import Annex.SpecialRemote.Config +import qualified Data.ByteString.Short as S (toShort) {- The beginning of a Cipher is used for MAC'ing; the remainder is used - as the GPG symmetric encryption passphrase when using the hybrid @@ -163,7 +164,7 @@ - on content. It does need to be repeatable. -} encryptKey :: Mac -> Cipher -> EncKey encryptKey mac c k = mkKey $ \d -> d - { keyName = encodeBS (macWithCipher mac c (serializeKey k)) + { keyName = S.toShort $ encodeBS $ macWithCipher mac c (serializeKey k) , keyVariety = OtherKey $ encryptedBackendNamePrefix <> encodeBS (showMac mac) } diff --git a/Database/Benchmark.hs b/Database/Benchmark.hs --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -22,6 +22,7 @@ import Utility.DataUnits import Criterion.Main +import qualified Data.ByteString.Short as S (toShort) import qualified Data.ByteString.Char8 as B8 import System.Random import Control.Concurrent @@ -87,7 +88,7 @@ keyN :: Integer -> Key keyN n = mkKey $ \k -> k - { keyName = B8.pack $ "key" ++ show n + { keyName = S.toShort (B8.pack $ "key" ++ show n) , keyVariety = OtherKey "BENCH" } diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -71,7 +71,7 @@ repoLocation Repo { location = Unknown } = error "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - - it's the gitdit, and for URL repositories, is the path on the remote + - it's the gitdir, and for URL repositories, is the path on the remote - host. -} repoPath :: Repo -> RawFilePath repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -1,6 +1,6 @@ {- git cat-file interface - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,9 +10,13 @@ module Git.CatFile ( CatFileHandle, + CatFileMetaDataHandle, catFileStart, + catFileMetaDataStart, catFileStart', + catFileMetaDataStart', catFileStop, + catFileMetaDataStop, catFile, catFileDetails, catTree, @@ -55,32 +59,45 @@ data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle - , checkFileProcess :: CoProcess.CoProcessHandle - , gitRepo :: Repo + , catFileGitRepo :: Repo } +data CatFileMetaDataHandle = CatFileMetaDataHandle + { checkFileProcess :: CoProcess.CoProcessHandle + , checkFileGitRepo :: Repo + } + catFileStart :: Repo -> IO CatFileHandle catFileStart = catFileStart' True catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle - <$> startp "--batch" - <*> startp ("--batch-check=" ++ batchFormat) + <$> startcat restartable repo "--batch" <*> pure repo - where - startp p = gitCoProcessStart restartable - [ Param "cat-file" - , Param p - ] repo +catFileMetaDataStart :: Repo -> IO CatFileMetaDataHandle +catFileMetaDataStart = catFileMetaDataStart' True + +catFileMetaDataStart' :: Bool -> Repo -> IO CatFileMetaDataHandle +catFileMetaDataStart' restartable repo = CatFileMetaDataHandle + <$> startcat restartable repo ("--batch-check=" ++ batchFormat) + <*> pure repo + batchFormat :: String batchFormat = "%(objectname) %(objecttype) %(objectsize)" +startcat :: Bool -> Repo -> String -> IO CoProcess.CoProcessHandle +startcat restartable repo p = gitCoProcessStart restartable + [ Param "cat-file" + , Param p + ] repo + catFileStop :: CatFileHandle -> IO () -catFileStop h = do - CoProcess.stop (catFileProcess h) - CoProcess.stop (checkFileProcess h) +catFileStop = CoProcess.stop . catFileProcess +catFileMetaDataStop :: CatFileMetaDataHandle -> IO () +catFileMetaDataStop = CoProcess.stop . checkFileProcess + {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString catFile h branch file = catObject h $ @@ -106,16 +123,16 @@ Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) where -- Slow fallback path for filenames containing newlines. - newlinefallback = queryObjectType object (gitRepo h) >>= \case + newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case Nothing -> return Nothing - Just objtype -> queryContent object (gitRepo h) >>= \case + Just objtype -> queryContent object (catFileGitRepo h) >>= \case Nothing -> return Nothing Just content -> do -- only the --batch interface allows getting -- the sha, so have to re-hash the object sha <- hashObject' objtype (flip L.hPut content) - (gitRepo h) + (catFileGitRepo h) return (Just (content, sha, objtype)) readObjectContent :: Handle -> ParsedResp -> IO L.ByteString @@ -131,7 +148,7 @@ readObjectContent _ DNE = error "internal" {- Gets the size and type of an object, without reading its content. -} -catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) +catObjectMetaData :: CatFileMetaDataHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do resp <- S8.hGetLine from case parseResp object resp of @@ -142,9 +159,9 @@ where -- Slow fallback path for filenames containing newlines. newlinefallback = do - sha <- Git.Ref.sha object (gitRepo h) - sz <- querySize object (gitRepo h) - objtype <- queryObjectType object (gitRepo h) + sha <- Git.Ref.sha object (checkFileGitRepo h) + sz <- querySize object (checkFileGitRepo h) + objtype <- queryObjectType object (checkFileGitRepo h) return $ (,,) <$> sha <*> sz <*> objtype data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -64,17 +64,21 @@ {- A Ref that can be used to refer to a file in the repository, as staged - in the index. + - + - If the input file is located outside the repository, returns Nothing. -} -fileRef :: RawFilePath -> IO Ref -fileRef f = do +fileRef :: RawFilePath -> Repo -> IO (Maybe Ref) +fileRef f repo = do -- The filename could be absolute, or contain eg "../repo/file", -- neither of which work in a ref, so convert it to a minimal -- relative path. f' <- relPathCwdToFile f - -- Prefixing the file with ./ makes this work even when in a - -- subdirectory of a repo. Eg, ./foo in directory bar refers - -- to bar/foo, not to foo in the top of the repository. - return $ Ref $ ":./" <> toInternalGitPath f' + return $ if repoPath repo `dirContains` f' + -- Prefixing the file with ./ makes this work even when in a + -- subdirectory of a repo. Eg, ./foo in directory bar refers + -- to bar/foo, not to foo in the top of the repository. + then Just $ Ref $ ":./" <> toInternalGitPath f' + else Nothing {- A Ref that can be used to refer to a file in a particular branch. -} branchFileRef :: Branch -> RawFilePath -> Ref @@ -85,11 +89,14 @@ dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS d {- A Ref that can be used to refer to a file in the repository as it - - appears in a given Ref. -} -fileFromRef :: Ref -> RawFilePath -> IO Ref -fileFromRef r f = do - (Ref fr) <- fileRef f - return (Ref (fromRef' r <> fr)) + - appears in a given Ref. + - + - If the file path is located outside the repository, returns Nothing. + -} +fileFromRef :: Ref -> RawFilePath -> Repo -> IO (Maybe Ref) +fileFromRef r f repo = fileRef f repo >>= return . \case + Just (Ref fr) -> Just (Ref (fromRef' r <> fr)) + Nothing -> Nothing {- Checks if a ref exists. Note that it must be fully qualified, - eg refs/heads/master rather than master. -} diff --git a/Git/Tree.hs b/Git/Tree.hs --- a/Git/Tree.hs +++ b/Git/Tree.hs @@ -1,6 +1,6 @@ {- git trees - - - Copyright 2016-2019 Joey Hess + - Copyright 2016-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -13,6 +13,7 @@ getTree, recordTree, recordTree', + recordSubTree, TreeItem(..), treeItemsToTree, treeItemToLsTreeItem, @@ -21,6 +22,7 @@ graftTree, graftTree', withMkTreeHandle, + MkTreeHandle, treeMode, ) where @@ -32,12 +34,14 @@ import Git.Sha import qualified Git.LsTree as LsTree import qualified Utility.CoProcess as CoProcess +import qualified System.FilePath.ByteString as P import Numeric import System.Posix.Types import Control.Monad.IO.Class import qualified Data.Set as S import qualified Data.Map as M +import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S8 newtype Tree = Tree [TreeContent] @@ -162,10 +166,10 @@ Just (NewSubTree d l) -> go (addsubtree idir m (NewSubTree d (c:l))) is _ -> - go (addsubtree idir m (NewSubTree (asTopFilePath (toRawFilePath idir)) [c])) is + go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is where p = gitPath i - idir = takeDirectory p + idir = P.takeDirectory p c = treeItemToTreeContent i addsubtree d m t @@ -175,10 +179,10 @@ Just (NewSubTree d' l) -> let l' = filter (\ti -> gitPath ti /= d) l in addsubtree parent m' (NewSubTree d' (t:l')) - _ -> addsubtree parent m' (NewSubTree (asTopFilePath (toRawFilePath parent)) [t]) + _ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t]) | otherwise = M.insert d t m where - parent = takeDirectory d + parent = P.takeDirectory d {- Flattens the top N levels of a Tree. -} flattenTree :: Int -> Tree -> Tree @@ -263,9 +267,9 @@ addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere return (addoldnew l' addunderhere') - removeset = S.fromList $ map (normalise . gitPath) removefiles - removed (TreeBlob f _ _) = S.member (normalise (gitPath f)) removeset - removed (TreeCommit f _ _) = S.member (normalise (gitPath f)) removeset + removeset = S.fromList $ map (P.normalise . gitPath) removefiles + removed (TreeBlob f _ _) = S.member (P.normalise (gitPath f)) removeset + removed (TreeCommit f _ _) = S.member (P.normalise (gitPath f)) removeset removed (RecordedSubTree _ _ _) = False removed (NewSubTree _ _) = False @@ -281,7 +285,7 @@ addoldnew' (M.delete k oldm) ns Nothing -> n : addoldnew' oldm ns addoldnew' oldm [] = M.elems oldm - mkk = normalise . gitPath + mkk = P.normalise . gitPath {- Grafts subtree into the basetree at the specified location, replacing - anything that the basetree already had at that location. @@ -338,14 +342,14 @@ | d == graftloc = graftin' [] | otherwise = NewSubTree d [graftin' rest] - subdirs = splitDirectories $ gitPath graftloc + subdirs = P.splitDirectories $ gitPath graftloc -- For a graftloc of "foo/bar/baz", this generates -- ["foo", "foo/bar", "foo/bar/baz"] - graftdirs = map (asTopFilePath . toInternalGitPath . encodeBS) $ + graftdirs = map (asTopFilePath . toInternalGitPath) $ mkpaths [] subdirs mkpaths _ [] = [] - mkpaths base (d:rest) = (joinPath base d) : mkpaths (base ++ [d]) rest + mkpaths base (d:rest) = (P.joinPath base P. d) : mkpaths (base ++ [d]) rest {- Assumes the list is ordered, with tree objects coming right before their - contents. -} @@ -374,13 +378,16 @@ parseerr = Left class GitPath t where - gitPath :: t -> FilePath + gitPath :: t -> RawFilePath -instance GitPath FilePath where +instance GitPath RawFilePath where gitPath = id +instance GitPath FilePath where + gitPath = toRawFilePath + instance GitPath TopFilePath where - gitPath = fromRawFilePath . getTopFilePath + gitPath = getTopFilePath instance GitPath TreeItem where gitPath (TreeItem f _ _) = gitPath f @@ -398,10 +405,10 @@ inTopTree = inTree "." inTree :: (GitPath t, GitPath f) => t -> f -> Bool -inTree t f = gitPath t == takeDirectory (gitPath f) +inTree t f = gitPath t == P.takeDirectory (gitPath f) beneathSubTree :: (GitPath t, GitPath f) => t -> f -> Bool -beneathSubTree t f = prefix `isPrefixOf` normalise (gitPath f) +beneathSubTree t f = prefix `B.isPrefixOf` P.normalise (gitPath f) where tp = gitPath t - prefix = if null tp then tp else addTrailingPathSeparator (normalise tp) + prefix = if B.null tp then tp else P.addTrailingPathSeparator (P.normalise tp) diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -31,6 +31,7 @@ import qualified Data.Text as T import qualified Data.ByteString as S +import qualified Data.ByteString.Short as S (toShort, fromShort) import qualified Data.Attoparsec.ByteString as A import Common @@ -62,7 +63,7 @@ serializeKey = decodeBS . serializeKey' serializeKey' :: Key -> S.ByteString -serializeKey' = keySerialization +serializeKey' = S.fromShort . keySerialization deserializeKey :: String -> Maybe Key deserializeKey = deserializeKey' . encodeBS @@ -72,7 +73,7 @@ instance Arbitrary KeyData where arbitrary = Key - <$> (encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t")) + <$> (S.toShort . encodeBS <$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t")) <*> (parseKeyVariety . encodeBS <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND <*> ((abs <$>) <$> arbitrary) -- size cannot be negative <*> ((abs . fromInteger <$>) <$> arbitrary) -- mtime cannot be negative diff --git a/Messages/Progress.hs b/Messages/Progress.hs --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -1,6 +1,6 @@ {- git-annex progress output - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -18,6 +18,7 @@ import Types.Messages import Types.Key import Types.KeySource +import Types.StallDetection (BwRate(..)) import Utility.InodeCache import qualified Messages.JSON as JSON import Messages.Concurrent @@ -72,11 +73,12 @@ :: MeterSize sizer => Maybe MeterUpdate -> sizer + -> Maybe BwRate -> (Meter -> MeterUpdate -> Annex a) -> Annex a -metered othermeter sizer a = withMessageState $ \st -> do +metered othermeterupdate sizer bwlimit a = withMessageState $ \st -> do sz <- getMeterSize sizer - metered' st setclear othermeter sz showOutput a + metered' st setclear othermeterupdate sz bwlimit showOutput a where setclear c = Annex.changeState $ \st -> st { Annex.output = (Annex.output st) { clearProgressMeter = c } } @@ -90,11 +92,12 @@ -- NormalOutput. -> Maybe MeterUpdate -> Maybe TotalSize + -> Maybe BwRate -> m () -- ^ this should run showOutput -> (Meter -> MeterUpdate -> m a) -> m a -metered' st setclear othermeter msize showoutput a = go st +metered' st setclear othermeterupdate msize bwlimit showoutput a = go st where go (MessageState { outputType = QuietOutput }) = nometer go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do @@ -105,7 +108,7 @@ setclear clear m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $ updateMeter meter - r <- a meter (combinemeter m) + r <- a meter =<< mkmeterupdate m setclear noop liftIO clear return r @@ -116,7 +119,7 @@ in Regions.setConsoleRegion r ('\n' : s) m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $ updateMeter meter - a meter (combinemeter m) + a meter =<< mkmeterupdate m go (MessageState { outputType = JSONOutput jsonoptions }) | jsonProgress jsonoptions = do let buf = jsonBuffer st @@ -124,7 +127,7 @@ JSON.progress buf msize' (meterBytesProcessed new) m <- liftIO $ rateLimitMeterUpdate jsonratelimit meter $ updateMeter meter - a meter (combinemeter m) + a meter =<< mkmeterupdate m | otherwise = nometer go (MessageState { outputType = SerializedOutput h _ }) = do liftIO $ outputSerialized h BeginProgressMeter @@ -144,16 +147,21 @@ meterBytesProcessed new m <- liftIO $ rateLimitMeterUpdate minratelimit meter $ updateMeter meter - a meter (combinemeter m) + (a meter =<< mkmeterupdate m) `finally` (liftIO $ outputSerialized h EndProgressMeter) nometer = do dummymeter <- liftIO $ mkMeter Nothing $ \_ _ _ _ -> return () - a dummymeter (combinemeter (const noop)) + a dummymeter =<< mkmeterupdate (const noop) - combinemeter m = case othermeter of - Nothing -> m - Just om -> combineMeterUpdate m om + mkmeterupdate m = + let mu = case othermeterupdate of + Nothing -> m + Just om -> combineMeterUpdate m om + in case bwlimit of + Nothing -> return mu + Just (BwRate sz duration) -> liftIO $ + bwLimitMeterUpdate sz duration mu consoleratelimit = 0.2 @@ -164,7 +172,7 @@ {- Poll file size to display meter. -} meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a meteredFile file combinemeterupdate key a = - metered combinemeterupdate key $ \_ p -> + metered combinemeterupdate key Nothing $ \_ p -> watchFileSize file p a {- Progress dots. -} diff --git a/Messages/Serialized.hs b/Messages/Serialized.hs --- a/Messages/Serialized.hs +++ b/Messages/Serialized.hs @@ -68,7 +68,7 @@ let setclear = const noop -- Display a progress meter while running, until -- the meter ends or a final value is returned. - metered' ost setclear Nothing Nothing (runannex showOutput) + metered' ost setclear Nothing Nothing Nothing (runannex showOutput) (\meter meterupdate -> loop (Just (meter, meterupdate))) >>= \case Right r -> return (Right r) diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -288,9 +288,10 @@ , File newloc ] -listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsM serial adir = adbfind >>= \case - Just ls -> return $ Just $ ImportableContents (mapMaybe mk ls) [] + Just ls -> return $ Just $ ImportableContentsComplete $ + ImportableContents (mapMaybe mk ls) [] Nothing -> giveup "adb find failed" where adbfind = adbShell serial diff --git a/Remote/Borg.hs b/Remote/Borg.hs --- a/Remote/Borg.hs +++ b/Remote/Borg.hs @@ -162,20 +162,21 @@ | borgLocal r && not (null p) = Just p | otherwise = Nothing -listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsM u borgrepo c = prompt $ do imported <- getImported u ls <- withborglist (locBorgRepo borgrepo) Nothing formatarchivelist $ \as -> forM (filter (not . S.null) as) $ \archivename -> - case M.lookup archivename imported of - Just getfast -> return $ Left (archivename, getfast) - Nothing -> Right <$> + return $ case M.lookup archivename imported of + Just getlist -> Left (archivename, getlist) + Nothing -> let archive = borgArchive borgrepo archivename - in withborglist archive subdir formatfilelist $ + getlist = withborglist archive subdir formatfilelist $ liftIO . evaluate . force . parsefilelist archivename + in Right (archivename, getlist) if all isLeft ls && M.null (M.difference imported (M.fromList (lefts ls))) then return Nothing -- unchanged since last time, avoid work - else Just . mkimportablecontents <$> mapM (either snd pure) ls + else Just <$> mkimportablecontents (map (either id id) ls) where withborglist what addparam format a = do environ <- liftIO getEnvironment @@ -210,7 +211,7 @@ parsefilelist archivename (bsz:f:extra:rest) = case readMaybe (fromRawFilePath bsz) of Nothing -> parsefilelist archivename rest Just sz -> - let loc = genImportLocation archivename f + let loc = genImportLocation f -- borg list reports hard links as 0 byte files, -- with the extra field set to " link to ". -- When the annex object is a hard link to @@ -234,12 +235,27 @@ -- importableHistory is not used for retrieval, so is not -- populated with old archives. Instead, a tree of archives - -- is constructed, by genImportLocation including the archive - -- name in the ImportLocation. - mkimportablecontents l = ImportableContents - { importableContents = concat l - , importableHistory = [] - } + -- is constructed, with a subtree for each archive. + mkimportablecontents [] = return $ ImportableContentsComplete $ + ImportableContents + { importableContents = [] + , importableHistory = [] + } + mkimportablecontents (l:ls) = ImportableContentsChunked + <$> mkimportablecontentschunk l ls + <*> pure [] + + mkimportablecontentschunk (archivename, getlist) rest = do + l <- getlist + return $ ImportableContentsChunk + { importableContentsSubDir = + genImportChunkSubDir archivename + , importableContentsSubTree = l + , importableContentsNextChunk = case rest of + (getlist':rest') -> Just + <$> mkimportablecontentschunk getlist' rest' + [] -> return Nothing + } -- We do not need a ContentIdentifier in order to retrieve a file from -- borg; the ImportLocation contains all that's needed. So, this is left @@ -247,16 +263,21 @@ borgContentIdentifier :: ContentIdentifier borgContentIdentifier = ContentIdentifier mempty +-- Convert a path file a borg archive to a path that can be used as an +-- ImportLocation. The archive name gets used as a subdirectory, +-- which this path is inside. +-- -- Borg does not allow / in the name of an archive, so the archive -- name will always be the first directory in the ImportLocation. -- --- Paths in a borg archive are always relative, not absolute, so the use of --- to combine the archive name with the path will always work. -genImportLocation :: BorgArchiveName -> RawFilePath -> ImportLocation -genImportLocation archivename p = - ThirdPartyPopulated.mkThirdPartyImportLocation $ - archivename P. p +-- This scheme also relies on the fact that paths in a borg archive are +-- always relative, not absolute. +genImportLocation :: RawFilePath -> RawFilePath +genImportLocation = fromImportLocation . ThirdPartyPopulated.mkThirdPartyImportLocation +genImportChunkSubDir :: BorgArchiveName -> ImportChunkSubDir +genImportChunkSubDir = ImportChunkSubDir . fromImportLocation . ThirdPartyPopulated.mkThirdPartyImportLocation + extractImportLocation :: ImportLocation -> (BorgArchiveName, RawFilePath) extractImportLocation loc = go $ P.splitDirectories $ ThirdPartyPopulated.fromThirdPartyImportLocation loc @@ -269,7 +290,7 @@ -- last imported tree. And the contents of those archives can be retrieved -- by listing the subtree recursively, which will likely be quite a lot -- faster than running borg. -getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(ImportLocation, (ContentIdentifier, ByteSize))])) +getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(RawFilePath, (ContentIdentifier, ByteSize))])) getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u) where go t = M.fromList . mapMaybe mk @@ -278,21 +299,19 @@ mk ti | toTreeItemType (LsTree.mode ti) == Just TreeSubtree = Just ( getTopFilePath (LsTree.file ti) - , getcontents - (getTopFilePath (LsTree.file ti)) - (LsTree.sha ti) + , getcontents (LsTree.sha ti) ) | otherwise = Nothing - getcontents archivename t = mapMaybe (mkcontents archivename) + getcontents t = mapMaybe mkcontents <$> inRepo (LsTree.lsTreeStrict LsTree.LsTreeRecursive (LsTree.LsTreeLong False) t) - mkcontents archivename ti = do + mkcontents ti = do let f = ThirdPartyPopulated.fromThirdPartyImportLocation $ mkImportLocation $ getTopFilePath $ LsTree.file ti k <- fileKey (P.takeFileName f) return - ( genImportLocation archivename f + ( genImportLocation f , ( borgContentIdentifier -- defaulting to 0 size is ok, this size @@ -360,6 +379,15 @@ absborgrepo <- absBorgRepo borgrepo let p = proc "borg" $ toCommand [ Param "extract" + -- git-annex object files do not need any + -- xattrs or ACLs, and trying to extract + -- any that are set from the backup can lead + -- to problems when doing a retrieve from a + -- different OS than the one where the backup was + -- made. + , Param "--noxattrs" + , Param "--noacls" + , Param "--nobsdflags" , Param (borgArchive absborgrepo archivename) , File (fromRawFilePath archivefile) ] diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -351,11 +351,12 @@ mkExportLocation loc' in go (upFrom loc') =<< tryIO (removeDirectory p) -listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsM dir = liftIO $ do l <- dirContentsRecursive (fromRawFilePath dir) l' <- mapM (go . toRawFilePath) l - return $ Just $ ImportableContents (catMaybes l') [] + return $ Just $ ImportableContentsComplete $ + ImportableContents (catMaybes l') [] where go f = do st <- R.getFileStatus f diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -60,6 +60,7 @@ import Network.URI import Data.Char import Text.Read +import qualified Data.ByteString.Short as S (fromShort) data External = External { externalType :: ExternalType @@ -138,7 +139,7 @@ mkSafeKey :: Key -> Either String SafeKey mkSafeKey k - | any isSpace (decodeBS $ fromKey keyName k) = Left $ concat + | any isSpace (decodeBS $ S.fromShort $ fromKey keyName k) = Left $ concat [ "Sorry, this file cannot be stored on an external special remote because its key's name contains a space. " , "To avoid this problem, you can run: git-annex migrate --backend=" , decodeBS (formatKeyVariety (fromKey keyVariety k)) diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -550,6 +550,7 @@ | not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do u <- getUUID hardlink <- wantHardLink + let bwlimit = remoteAnnexBwLimit (gitconfig r) -- run copy from perspective of remote onLocalFast st $ Annex.Content.prepSendAnnex' key >>= \case Just (object, check) -> do @@ -559,7 +560,7 @@ copier <- mkFileCopier hardlink st (ok, v) <- runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> - metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> + metered (Just (combineMeterUpdate p meterupdate)) key bwlimit $ \_ p' -> copier object dest key p' checksuccess vc if ok then return v @@ -572,6 +573,7 @@ then return v else giveup "failed to retrieve content from remote" else P2PHelper.retrieve + (gitconfig r) (\p -> Ssh.runProto r connpool (return (False, UnVerified)) (fallback p)) key file dest meterupdate vc | otherwise = giveup "copying from non-ssh, non-http remote not supported" @@ -680,7 +682,7 @@ , giveup "remote does not have expected annex.uuid value" ) | Git.repoIsSsh repo = commitOnCleanup repo r st $ - P2PHelper.store + P2PHelper.store (gitconfig r) (Ssh.runProto r connpool (return False) . copyremotefallback) key file meterupdate @@ -694,6 +696,7 @@ checkio <- Annex.withCurrentState check u <- getUUID hardlink <- wantHardLink + let bwlimit = remoteAnnexBwLimit (gitconfig r) -- run copy from perspective of remote res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) ( return True @@ -705,7 +708,7 @@ Just err -> giveup err Nothing -> return True res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> - metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> + metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' -> copier object (fromRawFilePath dest) key p' checksuccess verify Annex.Content.saveState True return res diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -56,6 +56,7 @@ import Network.HTTP.Client hiding (port) import qualified Data.Map as M import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as S (fromShort) import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Control.Concurrent.MSemN as MSemN @@ -374,7 +375,7 @@ extractKeySha256 k = case fromKey keyVariety k of SHA2Key (HashSize 256) (HasExt hasext) | hasext -> eitherToMaybe $ E.decodeUtf8' (keyHash k) - | otherwise -> eitherToMaybe $ E.decodeUtf8' (fromKey keyName k) + | otherwise -> eitherToMaybe $ E.decodeUtf8' $ S.fromShort (fromKey keyName k) _ -> Nothing -- The size of an encrypted key is the size of the input data, but we need diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -178,7 +178,7 @@ retrieve :: Remote -> Retriever retrieve = byteRetriever . retrieve' -retrieve' :: Remote -> Key -> (L.ByteString -> Annex a) -> Annex a +retrieve' :: forall a. Remote -> Key -> (L.ByteString -> Annex a) -> Annex a retrieve' r k sink = go =<< glacierEnv c gc u where c = config r diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -31,19 +31,21 @@ -- the pool when done. type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a -store :: (MeterUpdate -> ProtoRunner Bool) -> Key -> AssociatedFile -> MeterUpdate -> Annex () -store runner k af p = do +store :: RemoteGitConfig -> (MeterUpdate -> ProtoRunner Bool) -> Key -> AssociatedFile -> MeterUpdate -> Annex () +store gc runner k af p = do let sizer = KeySizer k (fmap (toRawFilePath . fst) <$> prepSendAnnex k) - metered (Just p) sizer $ \_ p' -> + let bwlimit = remoteAnnexBwLimit gc + metered (Just p) sizer bwlimit $ \_ p' -> runner p' (P2P.put k af p') >>= \case Just True -> return () Just False -> giveup "Transfer failed" Nothing -> remoteUnavail -retrieve :: (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification -retrieve runner k af dest p verifyconfig = do +retrieve :: RemoteGitConfig -> (MeterUpdate -> ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification +retrieve gc runner k af dest p verifyconfig = do iv <- startVerifyKeyContentIncrementally verifyconfig k - metered (Just p) k $ \m p' -> + let bwlimit = remoteAnnexBwLimit gc + metered (Just p) k bwlimit $ \m p' -> runner p' (P2P.get dest k iv af m p') >>= \case Just (True, v) -> return v Just (False, _) -> giveup "Transfer failed" diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -261,8 +261,9 @@ chunkconfig = chunkConfig cfg displayprogress p k srcfile a - | displayProgress cfg = - metered (Just p) (KeySizer k (pure (fmap toRawFilePath srcfile))) (const a) + | displayProgress cfg = do + let bwlimit = remoteAnnexBwLimit (gitconfig baser) + metered (Just p) (KeySizer k (pure (fmap toRawFilePath srcfile))) bwlimit (const a) | otherwise = a p withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a diff --git a/Remote/Helper/ThirdPartyPopulated.hs b/Remote/Helper/ThirdPartyPopulated.hs --- a/Remote/Helper/ThirdPartyPopulated.hs +++ b/Remote/Helper/ThirdPartyPopulated.hs @@ -47,10 +47,10 @@ -- find only those ImportLocations that are annex object files. -- All other ImportLocations are ignored. importKey :: ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) -importKey loc _cid sz _ = return $ importKey' loc (Just sz) +importKey loc _cid sz _ = return $ importKey' (fromImportLocation loc) (Just sz) -importKey' :: ImportLocation -> Maybe ByteSize -> Maybe Key -importKey' loc msz = case fileKey f of +importKey' :: RawFilePath -> Maybe ByteSize -> Maybe Key +importKey' p msz = case fileKey f of Just k -- Annex objects always are in a subdirectory with the same -- name as the filename. If this is not the case for the file @@ -82,5 +82,4 @@ _ -> Just k Nothing -> Nothing where - p = fromImportLocation loc f = P.takeFileName p diff --git a/Remote/P2P.hs b/Remote/P2P.hs --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -55,8 +55,8 @@ { uuid = u , cost = cst , name = Git.repoDescribe r - , storeKey = store (const protorunner) - , retrieveKeyFile = retrieve (const protorunner) + , storeKey = store gc (const protorunner) + , retrieveKeyFile = retrieve gc (const protorunner) , retrieveKeyFileCheap = Nothing , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = remove protorunner diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -549,13 +549,15 @@ srcobject = T.pack $ bucketExportLocation info src dstobject = T.pack $ bucketExportLocation info dest -listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsS3 hv r info = withS3Handle hv $ \case Nothing -> giveup $ needS3Creds (uuid r) Just h -> Just <$> go h where - go h = liftIO $ runResourceT $ extractFromResourceT =<< startlist h + go h = do + ic <- liftIO $ runResourceT $ extractFromResourceT =<< startlist h + return (ImportableContentsComplete ic) startlist h | versioning info = do diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -378,6 +378,7 @@ , testCase "directory remote" test_directory_remote , testCase "rsync remote" test_rsync_remote , testCase "bup remote" test_bup_remote + , testCase "borg remote" test_borg_remote , testCase "crypto" test_crypto , testCase "preferred content" test_preferred_content , testCase "required_content" test_required_content @@ -1783,6 +1784,33 @@ annexed_present annexedfile git_annex "move" [annexedfile, "--from", "foo"] "move --from bup remote" annexed_present annexedfile + +test_borg_remote :: Assertion +test_borg_remote = when BuildInfo.borg $ do + borgdirparent <- fromRawFilePath <$> (absPath . toRawFilePath =<< tmprepodir) + let borgdir = borgdirparent "borgrepo" + intmpclonerepo $ do + testProcess "borg" ["init", borgdir, "-e", "none"] (== True) "borg init" + testProcess "borg" ["create", borgdir++"::backup1", "."] (== True) "borg create" + + git_annex "initremote" (words $ "borg type=borg borgrepo="++borgdir) "initremote" + git_annex "sync" ["borg"] "sync borg" + git_annex_expectoutput "find" ["--in=borg"] [] + + git_annex "get" [annexedfile] "get of file" + annexed_present annexedfile + git_annex_expectoutput "find" ["--in=borg"] [] + + testProcess "borg" ["create", borgdir++"::backup2", "."] (== True) "borg create" + git_annex "sync" ["borg"] "sync borg after getting file" + git_annex_expectoutput "find" ["--in=borg"] [annexedfile] + + git "remote" ["rm", "origin"] "remote rm" + git_annex_shouldfail "drop" [annexedfile] + "drop from borg succeeded, but it should be untrusted by default" + git_annex "enableremote" ["borg", "appendonly=yes"] "enableremote appendonly" + git_annex "drop" [annexedfile] "drop from borg (appendonly)" + git_annex "get" [annexedfile, "--from=borg"] "get from borg" -- gpg is not a build dependency, so only test when it's available test_crypto :: Assertion diff --git a/Types/CatFileHandles.hs b/Types/CatFileHandles.hs --- a/Types/CatFileHandles.hs +++ b/Types/CatFileHandles.hs @@ -1,6 +1,6 @@ {- git-cat file handles pools - - - Copyright 2020 Joey Hess + - Copyright 2020-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,22 +9,30 @@ CatFileHandles(..), catFileHandlesNonConcurrent, catFileHandlesPool, + CatMap(..), + emptyCatMap, ) where import Control.Concurrent.STM import qualified Data.Map as M import Utility.ResourcePool -import Git.CatFile (CatFileHandle) +import Git.CatFile (CatFileHandle, CatFileMetaDataHandle) data CatFileHandles = CatFileHandlesNonConcurrent CatMap | CatFileHandlesPool (TMVar CatMap) -type CatMap = M.Map FilePath (ResourcePool CatFileHandle) +data CatMap = CatMap + { catFileMap :: M.Map FilePath (ResourcePool CatFileHandle) + , catFileMetaDataMap :: M.Map FilePath (ResourcePool CatFileMetaDataHandle) + } +emptyCatMap :: CatMap +emptyCatMap = CatMap M.empty M.empty + catFileHandlesNonConcurrent :: CatFileHandles -catFileHandlesNonConcurrent = CatFileHandlesNonConcurrent M.empty +catFileHandlesNonConcurrent = CatFileHandlesNonConcurrent emptyCatMap catFileHandlesPool :: IO CatFileHandles -catFileHandlesPool = CatFileHandlesPool <$> newTMVarIO M.empty +catFileHandlesPool = CatFileHandlesPool <$> newTMVarIO emptyCatMap diff --git a/Types/Export.hs b/Types/Export.hs --- a/Types/Export.hs +++ b/Types/Export.hs @@ -1,6 +1,6 @@ {- git-annex export types - - - Copyright 2017 Joey Hess + - Copyright 2017-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,23 +21,28 @@ import Utility.Split import Utility.FileSystemEncoding +import Data.ByteString.Short as S import qualified System.FilePath.Posix as Posix import GHC.Generics import Control.DeepSeq --- A location on a remote that a key can be exported to. --- The RawFilePath will be relative to the top of the remote, --- and uses unix-style path separators. -newtype ExportLocation = ExportLocation RawFilePath +-- A location such as a path on a remote, that a key can be exported to. +-- The path is relative to the top of the remote, and uses unix-style +-- path separators. +-- +-- This uses a ShortByteString to avoid problems with ByteString getting +-- PINNED in memory which caused memory fragmentation and excessive memory +-- use. +newtype ExportLocation = ExportLocation S.ShortByteString deriving (Show, Eq, Generic) instance NFData ExportLocation mkExportLocation :: RawFilePath -> ExportLocation -mkExportLocation = ExportLocation . toInternalGitPath +mkExportLocation = ExportLocation . S.toShort . toInternalGitPath fromExportLocation :: ExportLocation -> RawFilePath -fromExportLocation (ExportLocation f) = f +fromExportLocation (ExportLocation f) = S.fromShort f newtype ExportDirectory = ExportDirectory RawFilePath deriving (Show, Eq) @@ -58,4 +63,4 @@ subs ps (d:ds) = (d:ps) : subs (d:ps) ds dirs = map Posix.dropTrailingPathSeparator $ - dropFromEnd 1 $ Posix.splitPath $ decodeBS f + dropFromEnd 1 $ Posix.splitPath $ decodeBS $ S.fromShort f diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -123,7 +123,6 @@ , annexRetry :: Maybe Integer , annexForwardRetry :: Maybe Integer , annexRetryDelay :: Maybe Seconds - , annexStallDetection :: Maybe StallDetection , annexAllowedUrlSchemes :: S.Set Scheme , annexAllowedIPAddresses :: String , annexAllowUnverifiedDownloads :: Bool @@ -217,9 +216,6 @@ , annexForwardRetry = getmayberead (annexConfig "forward-retry") , annexRetryDelay = Seconds <$> getmayberead (annexConfig "retrydelay") - , annexStallDetection = - either (const Nothing) id . parseStallDetection - =<< getmaybe (annexConfig "stalldetection") , annexAllowedUrlSchemes = S.fromList $ map mkScheme $ maybe ["http", "https", "ftp"] words $ getmaybe (annexConfig "security.allowed-url-schemes") @@ -343,6 +339,7 @@ , remoteAnnexForwardRetry :: Maybe Integer , remoteAnnexRetryDelay :: Maybe Seconds , remoteAnnexStallDetection :: Maybe StallDetection + , remoteAnnexBwLimit :: Maybe BwRate , remoteAnnexAllowUnverifiedDownloads :: Bool , remoteAnnexConfigUUID :: Maybe UUID @@ -408,8 +405,11 @@ , remoteAnnexRetryDelay = Seconds <$> getmayberead "retrydelay" , remoteAnnexStallDetection = - either (const Nothing) id . parseStallDetection + either (const Nothing) Just . parseStallDetection =<< getmaybe "stalldetection" + , remoteAnnexBwLimit = do + sz <- readSize dataUnits =<< getmaybe "bwlimit" + return (BwRate sz (Duration 1)) , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe ("security-allow-unverified-downloads") , remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid" @@ -440,8 +440,10 @@ getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k getmayberead k = readish =<< getmaybe k getmaybe = fmap fromConfigValue . getmaybe' - getmaybe' k = mplus (Git.Config.getMaybe (annexConfig k) r) - (Git.Config.getMaybe (remoteAnnexConfig remotename k) r) + getmaybe' k = + Git.Config.getMaybe (remoteAnnexConfig remotename k) r + <|> + Git.Config.getMaybe (annexConfig k) r getoptions k = fromMaybe [] $ words <$> getmaybe k notempty :: Maybe String -> Maybe String diff --git a/Types/Import.hs b/Types/Import.hs --- a/Types/Import.hs +++ b/Types/Import.hs @@ -1,6 +1,6 @@ {- git-annex import types - - - Copyright 2019 Joey Hess + - Copyright 2019-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -13,6 +13,7 @@ import Data.Char import Control.DeepSeq import GHC.Generics +import qualified System.FilePath.Posix.ByteString as Posix import Types.Export import Utility.QuickCheck @@ -69,3 +70,34 @@ deriving (Show, Generic) instance NFData info => NFData (ImportableContents info) + +{- ImportableContents, but it can be chunked into subtrees to avoid + - all needing to fit in memory at the same time. -} +data ImportableContentsChunkable m info + = ImportableContentsComplete (ImportableContents info) + -- ^ Used when not chunking + | ImportableContentsChunked + { importableContentsChunk :: ImportableContentsChunk m info + , importableHistoryComplete :: [ImportableContents info] + -- ^ Chunking the history is not supported + } + +{- A chunk of ImportableContents, which is the entire content of a subtree + - of the main tree. Nested subtrees are not allowed. -} +data ImportableContentsChunk m info = ImportableContentsChunk + { importableContentsSubDir :: ImportChunkSubDir + , importableContentsSubTree :: [(RawFilePath, info)] + -- ^ locations are relative to importableContentsSubDir + , importableContentsNextChunk :: m (Maybe (ImportableContentsChunk m info)) + -- ^ Continuation to get the next chunk. + -- Returns Nothing when there are no more chunks. + } + +newtype ImportChunkSubDir = ImportChunkSubDir { importChunkSubDir :: RawFilePath } + +importableContentsChunkFullLocation + :: ImportChunkSubDir + -> RawFilePath + -> ImportLocation +importableContentsChunkFullLocation (ImportChunkSubDir root) loc = + mkImportLocation $ Posix.combine root loc diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -29,6 +29,7 @@ ) where import qualified Data.ByteString as S +import qualified Data.ByteString.Short as S (ShortByteString, toShort, fromShort) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder @@ -49,7 +50,7 @@ {- A Key has a unique name, which is derived from a particular backend, - and may contain other optional metadata. -} data KeyData = Key - { keyName :: S.ByteString + { keyName :: S.ShortByteString , keyVariety :: KeyVariety , keySize :: Maybe Integer , keyMtime :: Maybe EpochTime @@ -66,7 +67,7 @@ -} data Key = MkKey { keyData :: KeyData - , keySerialization :: S.ByteString + , keySerialization :: S.ShortByteString } deriving (Show, Generic) instance Eq Key where @@ -111,8 +112,8 @@ fieldSep :: Char fieldSep = '-' -mkKeySerialization :: KeyData -> S.ByteString -mkKeySerialization = L.toStrict +mkKeySerialization :: KeyData -> S.ShortByteString +mkKeySerialization = S.toShort . L.toStrict . toLazyByteStringWith (safeStrategy 128 smallChunkSize) L.empty . buildKeyData @@ -127,7 +128,7 @@ <> 'm' ?: (integerDec . (\(CTime t) -> fromIntegral t) <$> keyMtime k) <> 'S' ?: (integerDec <$> keyChunkSize k) <> 'C' ?: (integerDec <$> keyChunkNum k) - <> sepbefore (sepbefore (byteString (keyName k))) + <> sepbefore (sepbefore (shortByteString (keyName k))) where sepbefore s = char7 fieldSep <> s c ?: (Just b) = sepbefore (char7 c <> b) @@ -156,7 +157,7 @@ if validKeyName v n then let d = Key - { keyName = n + { keyName = S.toShort n , keyVariety = v , keySize = s , keyMtime = m @@ -195,7 +196,7 @@ - keyName minus extension, and the extension (including leading dot). -} splitKeyNameExtension :: Key -> (S.ByteString, S.ByteString) -splitKeyNameExtension = splitKeyNameExtension' . keyName . keyData +splitKeyNameExtension = splitKeyNameExtension' . S.fromShort . keyName . keyData splitKeyNameExtension' :: S.ByteString -> (S.ByteString, S.ByteString) splitKeyNameExtension' keyname = S8.span (/= '.') keyname diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -309,7 +309,7 @@ -- -- Throws exception on failure to access the remote. -- May return Nothing when the remote is unchanged since last time. - { listImportableContents :: a (Maybe (ImportableContents (ContentIdentifier, ByteSize))) + { listImportableContents :: a (Maybe (ImportableContentsChunkable a (ContentIdentifier, ByteSize))) -- Generates a Key (of any type) for the file stored on the -- remote at the ImportLocation. Does not download the file -- from the remote. @@ -322,7 +322,7 @@ -- since the ContentIdentifier was generated. -- -- When it returns nothing, the file at the ImportLocation - -- not by included in the imported tree. + -- will not be included in the imported tree. -- -- When the remote is thirdPartyPopulated, this should check if the -- file stored on the remote is the content of an annex object, diff --git a/Types/StallDetection.hs b/Types/StallDetection.hs --- a/Types/StallDetection.hs +++ b/Types/StallDetection.hs @@ -1,4 +1,4 @@ -{- types for stall detection +{- types for stall detection and banwdith rates - - Copyright 2020-2021 Joey Hess - @@ -13,7 +13,7 @@ import Git.Config data StallDetection - = StallDetection ByteSize Duration + = StallDetection BwRate -- ^ Unless the given number of bytes have been sent over the given -- amount of time, there's a stall. | ProbeStallDetection @@ -22,21 +22,29 @@ | StallDetectionDisabled deriving (Show) +data BwRate = BwRate ByteSize Duration + deriving (Show) + -- Parse eg, "0KiB/60s" -- -- Also, it can be set to "true" (or other git config equivilants) -- to enable ProbeStallDetection. -- And "false" (and other git config equivilants) explicitly -- disable stall detection. -parseStallDetection :: String -> Either String (Maybe StallDetection) +parseStallDetection :: String -> Either String StallDetection parseStallDetection s = case isTrueFalse s of Nothing -> do - let (bs, ds) = separate (== '/') s - b <- maybe - (Left $ "Unable to parse stall detection amount " ++ bs) - Right - (readSize dataUnits bs) - d <- parseDuration ds - return (Just (StallDetection b d)) - Just True -> Right (Just ProbeStallDetection) - Just False -> Right (Just StallDetectionDisabled) + v <- parseBwRate s + Right (StallDetection v) + Just True -> Right ProbeStallDetection + Just False -> Right StallDetectionDisabled + +parseBwRate :: String -> Either String BwRate +parseBwRate s = do + let (bs, ds) = separate (== '/') s + b <- maybe + (Left $ "Unable to parse bandwidth amount " ++ bs) + Right + (readSize dataUnits bs) + d <- parseDuration ds + Right (BwRate b d) diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -12,6 +12,7 @@ import Data.Default import Data.ByteString.Builder import qualified Data.ByteString as S +import qualified Data.ByteString.Short as S (toShort, fromShort) import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P @@ -138,7 +139,7 @@ where len = length l - 4 k = readKey1 (take len l) - sane = (not . S.null $ fromKey keyName k) && (not . S.null $ formatKeyVariety $ fromKey keyVariety k) + sane = (not . S.null $ S.fromShort $ fromKey keyName k) && (not . S.null $ formatKeyVariety $ fromKey keyVariety k) -- WORM backend keys: "WORM:mtime:size:filename" -- all the rest: "backend:key" @@ -150,7 +151,7 @@ readKey1 v | mixup = fromJust $ deserializeKey $ intercalate ":" $ Prelude.tail bits | otherwise = mkKey $ \d -> d - { keyName = encodeBS n + { keyName = S.toShort (encodeBS n) , keyVariety = parseKeyVariety (encodeBS b) , keySize = s , keyMtime = t @@ -175,7 +176,7 @@ showifhere Nothing = "" showifhere (Just x) = show x b = decodeBS $ formatKeyVariety v - n = fromKey keyName k + n = S.fromShort $ fromKey keyName k v = fromKey keyVariety k s = fromKey keySize k t = fromKey keyMtime k @@ -212,7 +213,7 @@ where k = fileKey1 l bname = decodeBS (formatKeyVariety (fromKey keyVariety k)) - kname = decodeBS (fromKey keyName k) + kname = decodeBS (S.fromShort (fromKey keyName k)) skip = "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")" diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -56,11 +56,17 @@ | otherwise = copyMetaDataParams meta {- When a filesystem supports CoW (and cp does), uses it to make - - an efficient copy of a file. Otherwise, returns False. -} + - an efficient copy of a file. Otherwise, returns False. + - + - The dest file must not exist yet, or it will fail to make a CoW copy, + - and will return False. + - + - Note that in coreutil 9.0, cp uses CoW by default, without needing an + - option. This code is only needed to support older versions. + -} copyCoW :: CopyMetaData -> FilePath -> FilePath -> IO Bool copyCoW meta src dest | BuildInfo.cp_reflink_supported = do - void $ tryIO $ removeFile dest -- When CoW is not supported, cp will complain to stderr, -- so have to discard its stderr. ok <- catchBoolIO $ withNullHandle $ \nullh -> diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -37,6 +37,7 @@ demeterCommandEnv, avoidProgress, rateLimitMeterUpdate, + bwLimitMeterUpdate, Meter, mkMeter, setMeterTotalSize, @@ -51,6 +52,7 @@ import Utility.DataUnits import Utility.HumanTime import Utility.SimpleProtocol as Proto +import Utility.ThreadScheduler import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -380,6 +382,46 @@ meterupdate n else putMVar lastupdate prev +-- | Bandwidth limiting by inserting a delay at the point that a meter is +-- updated. +-- +-- This will only work when the actions that use bandwidth are run in the +-- same process and thread as the call to the MeterUpdate. +-- +-- For example, if the desired bandwidth is 100kb/s, and over the past +-- 1/10th of a second, 30kb was sent, then the current bandwidth is +-- 300kb/s, 3x as fast as desired. So, after getting the next chunk, +-- pause for twice as long as it took to get it. +bwLimitMeterUpdate :: ByteSize -> Duration -> MeterUpdate -> IO MeterUpdate +bwLimitMeterUpdate bwlimit duration meterupdate + | bwlimit <= 0 = return meterupdate + | otherwise = do + nowtime <- getPOSIXTime + mv <- newMVar (nowtime, Nothing) + return (mu mv) + where + mu mv n@(BytesProcessed i) = do + endtime <- getPOSIXTime + (starttime, mprevi) <- takeMVar mv + + case mprevi of + Just previ -> do + let runtime = endtime - starttime + let currbw = fromIntegral (i - previ) / runtime + let pausescale = if currbw > bwlimit' + then (currbw / bwlimit') - 1 + else 0 + unboundDelay (floor (runtime * pausescale * msecs)) + Nothing -> return () + + meterupdate n + + nowtime <- getPOSIXTime + putMVar mv (nowtime, Just i) + + bwlimit' = fromIntegral (bwlimit * durationSeconds duration) + msecs = fromIntegral oneSecond + data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter data MeterState = MeterState @@ -417,12 +459,14 @@ -- | Display meter to a Handle. displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter displayMeterHandle h rendermeter v msize old new = do + olds <- takeMVar v let s = rendermeter msize old new - olds <- swapMVar v s + let padding = replicate (length olds - length s) ' ' + let s' = s <> padding + putMVar v s' -- Avoid writing when the rendered meter has not changed. - when (olds /= s) $ do - let padding = replicate (length olds - length s) ' ' - hPutStr h ('\r':s ++ padding) + when (olds /= s') $ do + hPutStr h ('\r':s') hFlush h -- | Clear meter displayed by displayMeterHandle. May be called before diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -95,12 +95,29 @@ dirContains :: RawFilePath -> RawFilePath -> Bool dirContains a b = a == b || a' == b' - || (addTrailingPathSeparator a') `B.isPrefixOf` b' - || a' == "." && normalise ("." b') == b' + || (a'' `B.isPrefixOf` b' && avoiddotdotb) + || a' == "." && normalise ("." b') == b' && nodotdot b' where a' = norm a + a'' = addTrailingPathSeparator a' b' = norm b norm = normalise . simplifyPath + + {- This handles the case where a is ".." and b is "../..", + - which is not inside a. Similarly, "../.." does not contain + - "../../../". Due to the use of norm, cases like + - "../../foo/../../" get converted to eg "../../.." and + - so do not need to be handled specially here. + - + - When this is called, we already know that + - a'' is a prefix of b', so all that needs to be done is drop + - that prefix, and check if the next path component is ".." + -} + avoiddotdotb = nodotdot $ B.drop (B.length a'') b' + + nodotdot p = all + (\s -> dropTrailingPathSeparator s /= "..") + (splitPath p) {- Given an original list of paths, and an expanded list derived from it, - which may be arbitrarily reordered, generates a list of lists, where diff --git a/doc/git-annex-unused.mdwn b/doc/git-annex-unused.mdwn --- a/doc/git-annex-unused.mdwn +++ b/doc/git-annex-unused.mdwn @@ -40,6 +40,8 @@ is not in the specified refs (and not used by the index) will then be considered unused. + See REFSPEC FORMAT below for details of the format of this setting. + The git configuration annex.used-refspec can be used to configure this in a more permanent fashion. @@ -47,13 +49,17 @@ # REFSPEC FORMAT -The refspec format for --used-refspec is a colon-separated list of -additions and removals of refs. For example: +The refspec format for --used-refspec and annex.used-refspec is +a colon-separated list of additions and removals of refs. +A somewhat contrived example: - +refs/heads/*:+HEAD^:+refs/tags/*:-refs/tags/old-tag + +refs/heads/*:+HEAD^:+refs/tags/*:-refs/tags/old-tag:reflog This adds all refs/heads/ refs, as well as the previous version -of HEAD. It also adds all tags, except for old-tag. +of HEAD. It also adds all tags, except for old-tag. And it adds +all refs from the reflog. + +The default behavior is equivilant to `--used-refspec=+refs/*:+HEAD` The refspec is processed by starting with an empty set of refs, and walking the list in order from left to right. diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1384,6 +1384,18 @@ When making multiple retries of the same transfer, the delay doubles after each retry. (default 1) +* `remote..annex-bwlimit`, `annex.bwlimit` + + This can be used to limit how much bandwidth is used for a transfer + from or to a remote. + + For example, to limit transfers to 1 mebibyte per second: + `git config annex.bwlimit "1MiB"` + + This will work with many remotes, including git remotes, but not + for remotes where the transfer is run by a separate program than + git-annex. + * `remote..annex-stalldetecton`, `annex.stalldetection` Configuring this lets stalled or too-slow transfers be detected, and diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 8.20210903 +Version: 8.20211011 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess