git-annex 8.20210903 → 8.20211011
raw patch · 57 files changed
+759/−322 lines, 57 files
Files
- Annex/CatFile.hs +37/−15
- Annex/CopyFile.hs +20/−6
- Annex/Export.hs +3/−2
- Annex/Import.hs +178/−50
- Annex/StallDetection.hs +1/−1
- Annex/Transfer.hs +10/−15
- Annex/YoutubeDl.hs +1/−1
- Assistant/Threads/Watcher.hs +6/−6
- Assistant/TransferSlots.hs +2/−2
- Backend.hs +1/−10
- Backend/External.hs +2/−1
- Backend/Hash.hs +7/−6
- Backend/Utilities.hs +5/−4
- Backend/WORM.hs +4/−2
- Build/Configure.hs +1/−0
- CHANGELOG +23/−0
- Command/Add.hs +1/−1
- Command/Find.hs +2/−1
- Command/Import.hs +3/−3
- Command/Smudge.hs +10/−7
- Command/Sync.hs +12/−10
- Crypto.hs +2/−1
- Database/Benchmark.hs +2/−1
- Git.hs +1/−1
- Git/CatFile.hs +37/−20
- Git/Ref.hs +18/−11
- Git/Tree.hs +25/−18
- Key.hs +3/−2
- Messages/Progress.hs +21/−13
- Messages/Serialized.hs +1/−1
- Remote/Adb.hs +3/−2
- Remote/Borg.hs +54/−26
- Remote/Directory.hs +3/−2
- Remote/External/Types.hs +2/−1
- Remote/Git.hs +6/−3
- Remote/GitLFS.hs +2/−1
- Remote/Glacier.hs +1/−1
- Remote/Helper/P2P.hs +8/−6
- Remote/Helper/Special.hs +3/−2
- Remote/Helper/ThirdPartyPopulated.hs +3/−4
- Remote/P2P.hs +2/−2
- Remote/S3.hs +4/−2
- Test.hs +28/−0
- Types/CatFileHandles.hs +13/−5
- Types/Export.hs +13/−8
- Types/GitConfig.hs +9/−7
- Types/Import.hs +33/−1
- Types/Key.hs +8/−7
- Types/Remote.hs +2/−2
- Types/StallDetection.hs +20/−12
- Upgrade/V1.hs +5/−4
- Utility/CopyFile.hs +8/−2
- Utility/Metered.hs +48/−4
- Utility/Path.hs +19/−2
- doc/git-annex-unused.mdwn +10/−4
- doc/git-annex.mdwn +12/−0
- git-annex.cabal +1/−1
Annex/CatFile.hs view
@@ -1,6 +1,6 @@ {- git cat-file interface, with handle automatically stored in the Annex monad -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - 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
Annex/CopyFile.hs view
@@ -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 ) )
Annex/Export.hs view
@@ -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?
Annex/Import.hs view
@@ -1,6 +1,6 @@ {- git-annex import from remotes -- - Copyright 2019-2020 Joey Hess <id@joeyh.name>+ - Copyright 2019-2021 Joey Hess <id@joeyh.name> - - 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 $
Annex/StallDetection.hs view
@@ -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
Annex/Transfer.hs view
@@ -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
Annex/YoutubeDl.hs view
@@ -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 })
Assistant/Threads/Watcher.hs view
@@ -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) ->
Assistant/TransferSlots.hs view
@@ -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:",
Backend.hs view
@@ -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
Backend/External.hs view
@@ -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
Backend/Hash.hs view
@@ -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
Backend/Utilities.hs view
@@ -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) }
Backend/WORM.hs view
@@ -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
Build/Configure.hs view
@@ -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"
CHANGELOG view
@@ -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 <id@joeyh.name> 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
Command/Add.hs view
@@ -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
Command/Find.hs view
@@ -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)
Command/Import.hs view
@@ -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
Command/Smudge.hs view
@@ -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
Command/Sync.hs view
@@ -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
Crypto.hs view
@@ -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) }
Database/Benchmark.hs view
@@ -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" }
Git.hs view
@@ -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
Git/CatFile.hs view
@@ -1,6 +1,6 @@ {- git cat-file interface -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - 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
Git/Ref.hs view
@@ -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. -}
Git/Tree.hs view
@@ -1,6 +1,6 @@ {- git trees -- - Copyright 2016-2019 Joey Hess <id@joeyh.name>+ - Copyright 2016-2021 Joey Hess <id@joeyh.name> - - 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)
Key.hs view
@@ -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
Messages/Progress.hs view
@@ -1,6 +1,6 @@ {- git-annex progress output -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name> - - 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. -}
Messages/Serialized.hs view
@@ -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)
Remote/Adb.hs view
@@ -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
Remote/Borg.hs view
@@ -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) ]
Remote/Directory.hs view
@@ -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
Remote/External/Types.hs view
@@ -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))
Remote/Git.hs view
@@ -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
Remote/GitLFS.hs view
@@ -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
Remote/Glacier.hs view
@@ -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
Remote/Helper/P2P.hs view
@@ -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"
Remote/Helper/Special.hs view
@@ -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
Remote/Helper/ThirdPartyPopulated.hs view
@@ -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
Remote/P2P.hs view
@@ -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
Remote/S3.hs view
@@ -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
Test.hs view
@@ -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
Types/CatFileHandles.hs view
@@ -1,6 +1,6 @@ {- git-cat file handles pools -- - Copyright 2020 Joey Hess <id@joeyh.name>+ - Copyright 2020-2021 Joey Hess <id@joeyh.name> - - 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
Types/Export.hs view
@@ -1,6 +1,6 @@ {- git-annex export types -- - Copyright 2017 Joey Hess <id@joeyh.name>+ - Copyright 2017-2021 Joey Hess <id@joeyh.name> - - 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
Types/GitConfig.hs view
@@ -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
Types/Import.hs view
@@ -1,6 +1,6 @@ {- git-annex import types -- - Copyright 2019 Joey Hess <id@joeyh.name>+ - Copyright 2019-2021 Joey Hess <id@joeyh.name> - - 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
Types/Key.hs view
@@ -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
Types/Remote.hs view
@@ -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,
Types/StallDetection.hs view
@@ -1,4 +1,4 @@-{- types for stall detection+{- types for stall detection and banwdith rates - - Copyright 2020-2021 Joey Hess <id@joeyh.name> -@@ -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)
Upgrade/V1.hs view
@@ -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 ++ ")"
Utility/CopyFile.hs view
@@ -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 ->
Utility/Metered.hs view
@@ -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
Utility/Path.hs view
@@ -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
doc/git-annex-unused.mdwn view
@@ -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.
doc/git-annex.mdwn view
@@ -1384,6 +1384,18 @@ When making multiple retries of the same transfer, the delay doubles after each retry. (default 1) +* `remote.<name>.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.<name>.annex-stalldetecton`, `annex.stalldetection` Configuring this lets stalled or too-slow transfers be detected, and
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20210903+Version: 8.20211011 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>