git-annex 8.20210714 → 8.20210803
raw patch · 58 files changed
+989/−421 lines, 58 files
Files
- Annex/AdjustedBranch.hs +3/−3
- Annex/AutoMerge.hs +7/−5
- Annex/Content.hs +41/−12
- Annex/Content/Presence.hs +17/−86
- Annex/Content/Presence/LowLevel.hs +36/−0
- Annex/CopyFile.hs +0/−1
- Annex/Init.hs +11/−9
- Annex/InodeSentinal.hs +16/−3
- Annex/Locations.hs +27/−22
- Annex/ReplaceFile.hs +8/−3
- Annex/Verify.hs +90/−1
- Annex/WorkTree.hs +8/−83
- Assistant/MakeRepo.hs +3/−3
- Assistant/Sync.hs +16/−12
- Assistant/Threads/Merger.hs +4/−1
- Backend.hs +0/−18
- CHANGELOG +31/−0
- CmdLine/GitAnnex.hs +2/−0
- Command/ConfigList.hs +1/−1
- Command/Fix.hs +2/−2
- Command/Fsck.hs +48/−24
- Command/Init.hs +1/−1
- Command/Lock.hs +4/−2
- Command/Merge.hs +32/−17
- Command/PostReceive.hs +2/−1
- Command/Reinit.hs +1/−1
- Command/Reinject.hs +1/−1
- Command/Smudge.hs +1/−1
- Command/Sync.hs +60/−29
- Command/TestRemote.hs +1/−1
- Command/Unlock.hs +1/−1
- Command/Unused.hs +1/−1
- Command/Upgrade.hs +1/−1
- Command/WhereUsed.hs +163/−0
- Database/Keys.hs +21/−15
- Database/Keys/Handle.hs +0/−4
- Git/Branch.hs +14/−5
- Git/DiffTree.hs +6/−1
- Git/Merge.hs +9/−3
- Messages.hs +10/−6
- P2P/Annex.hs +1/−2
- Remote/Borg.hs +24/−12
- Remote/Git.hs +16/−6
- Remote/Helper/ExportImport.hs +1/−1
- Remote/Helper/P2P.hs +1/−1
- Test.hs +1/−1
- Test/Framework.hs +1/−0
- Upgrade/V5.hs +1/−1
- Utility/HumanNumber.hs +7/−3
- Utility/Process/Transcript.hs +1/−1
- doc/git-annex-filter-branch.mdwn +151/−0
- doc/git-annex-import.mdwn +9/−11
- doc/git-annex-merge.mdwn +6/−1
- doc/git-annex-sync.mdwn +5/−0
- doc/git-annex-unused.mdwn +2/−0
- doc/git-annex-whereused.mdwn +53/−0
- doc/git-annex.mdwn +4/−0
- git-annex.cabal +5/−1
Annex/AdjustedBranch.hs view
@@ -362,9 +362,9 @@ commitForAdjustedBranch :: [CommandParam] -> Annex () commitForAdjustedBranch ps = do cmode <- annexCommitMode <$> Annex.getGitConfig- void $ inRepo $ Git.Branch.commitCommand cmode $- [ Param "--quiet"- , Param "--allow-empty"+ let cquiet = Git.Branch.CommitQuiet True+ void $ inRepo $ Git.Branch.commitCommand cmode cquiet $+ [ Param "--allow-empty" , Param "-m" , Param "commit before entering adjusted branch" ] ++ ps
Annex/AutoMerge.hs view
@@ -352,11 +352,13 @@ | otherwise = go fs commitResolvedMerge :: Git.Branch.CommitMode -> Annex Bool-commitResolvedMerge commitmode = inRepo $ Git.Branch.commitCommand commitmode- [ Param "--no-verify"- , Param "-m"- , Param "git-annex automatic merge conflict fix"- ]+commitResolvedMerge commitmode = do+ commitquiet <- Git.Branch.CommitQuiet <$> commandProgressDisabled+ inRepo $ Git.Branch.commitCommand commitmode commitquiet+ [ Param "--no-verify"+ , Param "-m"+ , Param "git-annex automatic merge conflict fix"+ ] type InodeMap = M.Map (Either FilePath InodeCacheKey) FilePath
Annex/Content.hs view
@@ -29,6 +29,7 @@ populatePointerFile, linkToAnnex, linkFromAnnex,+ linkFromAnnex', LinkAnnexResult(..), unlinkAnnex, checkedCopyFile,@@ -50,6 +51,7 @@ pruneTmpWorkDirBefore, isUnmodified, isUnmodifiedCheap,+ verifyKeyContentPostRetrieval, verifyKeyContent, VerifyConfig(..), Verification(..),@@ -64,6 +66,7 @@ import Annex.Content.Presence import Annex.Content.LowLevel import Annex.Content.PointerFile+import Annex.Verify import qualified Git import qualified Annex import qualified Annex.Queue@@ -77,6 +80,7 @@ import Annex.LockPool import Annex.UUID import Annex.InodeSentinal+import Annex.ReplaceFile import Annex.AdjustedBranch (adjustedBranchRefresh) import Messages.Progress import Types.Remote (RetrievalSecurityPolicy(..))@@ -227,7 +231,7 @@ _ -> MustVerify else verification if ok- then ifM (verifyKeyContent rsp v verification' key tmpfile)+ then ifM (verifyKeyContentPostRetrieval rsp v verification' key tmpfile) ( pruneTmpWorkDirBefore tmpfile (moveAnnex key af) , do warning "verification of content failed"@@ -250,7 +254,7 @@ -- RetrievalSecurityPolicy would cause verification to always fail. checkallowed a = case rsp of RetrievalAllKeysSecure -> a- RetrievalVerifiableKeysSecure -> ifM (Backend.isVerifiable key)+ RetrievalVerifiableKeysSecure -> ifM (isVerifiable key) ( a , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) ( a@@ -345,8 +349,11 @@ fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key unless (null fs) $ do+ destic <- withTSDelta $+ liftIO . genInodeCache dest ics <- mapM (populatePointerFile (Restage True) key dest) fs- Database.Keys.storeInodeCaches' key [dest] (catMaybes ics)+ Database.Keys.addInodeCaches key+ (catMaybes (destic:ics)) ) alreadyhave = liftIO $ R.removeLink src @@ -367,6 +374,7 @@ return False data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop+ deriving (Eq) {- Populates the annex object file by hard linking or copying a source - file to it. -}@@ -378,9 +386,23 @@ , return LinkAnnexFailed ) -{- Makes a destination file be a link or copy from the annex object. -}+{- Makes a destination file be a link or copy from the annex object.+ -+ - linkAnnex stats the file after copying it to add to the inode+ - cache. But dest may be a file in the working tree, which could+ - get modified immediately after being populated. To avoid such a+ - race, call linkAnnex on a temporary file and move it into place+ - afterwards. Note that a consequence of this is that, if the file+ - already exists, it will be overwritten.+ -} linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult-linkFromAnnex key dest destmode = do+linkFromAnnex key dest destmode =+ replaceFile' (const noop) (fromRawFilePath dest) (== LinkAnnexOk) $ \tmp ->+ linkFromAnnex' key (toRawFilePath tmp) destmode++{- This is only safe to use when dest is not a worktree file. -}+linkFromAnnex' :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult+linkFromAnnex' key dest destmode = do src <- calcRepo (gitAnnexLocation key) srcic <- withTSDelta (liftIO . genInodeCache src) linkAnnex From key src srcic dest destmode@@ -471,19 +493,26 @@ -} prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool)) prepSendAnnex key = withObjectLoc key $ \f -> do+ let retval c = return $ Just (fromRawFilePath f, sameInodeCache f c) cache <- Database.Keys.getInodeCaches key- cache' <- if null cache+ if null cache -- Since no inode cache is in the database, this -- object is not currently unlocked. But that could -- change while the transfer is in progress, so -- generate an inode cache for the starting -- content.- then maybeToList <$>- withTSDelta (liftIO . genInodeCache f)- else pure cache- return $ if null cache'- then Nothing- else Just (fromRawFilePath f, sameInodeCache f cache')+ then maybe (return Nothing) (retval . (:[]))+ =<< withTSDelta (liftIO . genInodeCache f)+ -- Verify that the object is not modified. Usually this+ -- only has to check the inode cache, but if the cache+ -- is somehow stale, it will fall back to verifying its+ -- content.+ else withTSDelta (liftIO . genInodeCache f) >>= \case+ Just fc -> ifM (isUnmodified' key f fc cache)+ ( retval (fc:cache)+ , return Nothing+ )+ Nothing -> return Nothing prepSendAnnex' :: Key -> Annex (Maybe (FilePath, Annex (Maybe String))) prepSendAnnex' key = prepSendAnnex key >>= \case
Annex/Content/Presence.hs view
@@ -1,6 +1,6 @@ {- git-annex object content presence -- - 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. -}@@ -15,28 +15,18 @@ objectFileExists, withObjectLoc, isUnmodified,+ isUnmodified', isUnmodifiedCheap,- verifyKeyContent,- VerifyConfig(..),- Verification(..),- unVerified,- warnUnverifiableInsecure, contentLockFile, ) where +import Annex.Content.Presence.LowLevel import Annex.Common import qualified Annex-import Annex.Verify import Annex.LockPool-import Annex.WorkerPool-import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..))-import qualified Types.Backend-import qualified Backend import qualified Database.Keys-import Types.Key import Annex.InodeSentinal import Utility.InodeCache-import Types.WorkerPool import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS@@ -145,29 +135,22 @@ - The cheaper way is to see if the InodeCache for the key matches the - file. -} isUnmodified :: Key -> RawFilePath -> Annex Bool-isUnmodified key f = go =<< geti- where- go Nothing = return False- go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc- expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f)- ( do- -- The file could have been modified while it was- -- being verified. Detect that.- ifM (geti >>= maybe (return False) (compareInodeCaches fc))- ( do- -- Update the InodeCache to avoid- -- performing this expensive check again.- Database.Keys.addInodeCaches key [fc]- return True- , return False- )- , return False- )- geti = withTSDelta (liftIO . genInodeCache f)+isUnmodified key f = + withTSDelta (liftIO . genInodeCache f) >>= \case+ Just fc -> do+ ic <- Database.Keys.getInodeCaches key+ isUnmodified' key f fc ic+ Nothing -> return False +isUnmodified' :: Key -> RawFilePath -> InodeCache -> [InodeCache] -> Annex Bool+isUnmodified' = isUnmodifiedLowLevel Database.Keys.addInodeCaches+ {- Cheap check if a file contains the unmodified content of the key, - only checking the InodeCache of the key. -+ - When the InodeCache is stale, this may incorrectly report that a file is+ - modified.+ - - Note that, on systems not supporting high-resolution mtimes, - this may report a false positive when repeated edits are made to a file - within a small time window (eg 1 second).@@ -177,57 +160,5 @@ =<< withTSDelta (liftIO . genInodeCache f) isUnmodifiedCheap' :: Key -> InodeCache -> Annex Bool-isUnmodifiedCheap' key fc = - anyM (compareInodeCaches fc) =<< Database.Keys.getInodeCaches key--{- Verifies that a file is the expected content of a key.- -- - Configuration can prevent verification, for either a- - particular remote or always, unless the RetrievalSecurityPolicy- - requires verification.- -- - Most keys have a known size, and if so, the file size is checked.- -- - When the key's backend allows verifying the content (via checksum),- - it is checked. - -- - If the RetrievalSecurityPolicy requires verification and the key's- - backend doesn't support it, the verification will fail.- -}-verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool-verifyKeyContent rsp v verification k f = case (rsp, verification) of- (_, Verified) -> return True- (RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k)- ( verify- , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)- ( verify- , warnUnverifiableInsecure k >> return False- )- )- (_, UnVerified) -> ifM (shouldVerify v)- ( verify- , return True- )- (_, MustVerify) -> verify- where- verify = enteringStage VerifyStage $ verifysize <&&> verifycontent- verifysize = case fromKey keySize k of- Nothing -> return True- Just size -> do- size' <- liftIO $ catchDefaultIO 0 $ getFileSize f- return (size' == size)- verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case- Nothing -> return True- Just b -> case Types.Backend.verifyKeyContent b of- Nothing -> return True- Just verifier -> verifier k f--warnUnverifiableInsecure :: Key -> Annex ()-warnUnverifiableInsecure k = warning $ unwords- [ "Getting " ++ kv ++ " keys with this remote is not secure;"- , "the content cannot be verified to be correct."- , "(Use annex.security.allow-unverified-downloads to bypass"- , "this safety check.)"- ]- where- kv = decodeBS (formatKeyVariety (fromKey keyVariety k))+isUnmodifiedCheap' key fc = isUnmodifiedCheapLowLevel fc+ =<< Database.Keys.getInodeCaches key
+ Annex/Content/Presence/LowLevel.hs view
@@ -0,0 +1,36 @@+{- git-annex object content presence, low-level functions+ -+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.Content.Presence.LowLevel where++import Annex.Common+import Annex.Verify+import Annex.InodeSentinal+import Utility.InodeCache++isUnmodifiedLowLevel :: (Key -> [InodeCache] -> Annex ()) -> Key -> RawFilePath -> InodeCache -> [InodeCache] -> Annex Bool+isUnmodifiedLowLevel addinodecaches key f fc ic =+ isUnmodifiedCheapLowLevel fc ic <||> expensivecheck+ where+ expensivecheck = ifM (verifyKeyContent key f)+ ( do+ -- The file could have been modified while it was+ -- being verified. Detect that.+ ifM (geti >>= maybe (return False) (compareInodeCaches fc))+ ( do+ -- Update the InodeCache to avoid+ -- performing this expensive check again.+ addinodecaches key [fc]+ return True+ , return False+ )+ , return False+ )+ geti = withTSDelta (liftIO . genInodeCache f)++isUnmodifiedCheapLowLevel :: InodeCache -> [InodeCache] -> Annex Bool+isUnmodifiedCheapLowLevel fc ic = anyM (compareInodeCaches fc) ic
Annex/CopyFile.hs view
@@ -16,7 +16,6 @@ import Utility.FileMode import Utility.Touch import Types.Backend-import Backend import Annex.Verify import Control.Concurrent
Annex/Init.hs view
@@ -96,8 +96,8 @@ Right username -> [username, at, hostname, ":", reldir] Left _ -> [hostname, ":", reldir] -initialize :: Maybe String -> Maybe RepoVersion -> Annex ()-initialize mdescription mversion = checkInitializeAllowed $ do+initialize :: Bool -> Maybe String -> Maybe RepoVersion -> Annex ()+initialize autoinit mdescription mversion = checkInitializeAllowed $ do {- Has to come before any commits are made as the shared - clone heuristic expects no local objects. -} sharedclone <- checkSharedClone@@ -107,10 +107,10 @@ ensureCommit $ Annex.Branch.create prepUUID- initialize' mversion+ initialize' autoinit mversion initSharedClone sharedclone-+ u <- getUUID {- Avoid overwriting existing description with a default - description. -}@@ -119,8 +119,8 @@ -- Everything except for uuid setup, shared clone setup, and initial -- description.-initialize' :: Maybe RepoVersion -> Annex ()-initialize' mversion = checkInitializeAllowed $ do+initialize' :: Bool -> Maybe RepoVersion -> Annex ()+initialize' autoinit mversion = checkInitializeAllowed $ do checkLockSupport checkFifoSupport checkCrippledFileSystem@@ -135,9 +135,11 @@ then configureSmudgeFilter else deconfigureSmudgeFilter unlessM isBareRepo $ do- scanAnnexedFiles True hookWrite postCheckoutHook hookWrite postMergeHook+ unless autoinit $+ scanAnnexedFiles+ AdjustedBranch.checkAdjustedClone >>= \case AdjustedBranch.InAdjustedClone -> return () AdjustedBranch.NotInAdjustedClone ->@@ -198,7 +200,7 @@ where needsinit = ifM autoInitializeAllowed ( do- initialize Nothing Nothing+ initialize True Nothing Nothing autoEnableSpecialRemotes , giveup "First run: git-annex init" )@@ -232,7 +234,7 @@ where needsinit = whenM (initializeAllowed <&&> autoInitializeAllowed) $ do- initialize Nothing Nothing+ initialize True Nothing Nothing autoEnableSpecialRemotes {- Checks if a repository is initialized. Does not check version for ugrade. -}
Annex/InodeSentinal.hs view
@@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module Annex.InodeSentinal where @@ -30,11 +31,23 @@ {- Checks if one of the provided old InodeCache matches the current - version of a file. -} sameInodeCache :: RawFilePath -> [InodeCache] -> Annex Bool-sameInodeCache _ [] = return False+sameInodeCache file [] = do+ fastDebug "Annex.InodeSentinal" $+ fromRawFilePath file ++ " inode cache empty"+ return False sameInodeCache file old = go =<< withTSDelta (liftIO . genInodeCache file) where- go Nothing = return False- go (Just curr) = elemInodeCaches curr old+ go Nothing = do+ fastDebug "Annex.InodeSentinal" $+ fromRawFilePath file ++ " not present, cannot compare with inode cache"+ return False+ go (Just curr) = ifM (elemInodeCaches curr old)+ ( return True+ , do+ fastDebug "Annex.InodeSentinal" $+ fromRawFilePath file ++ " (" ++ show curr ++ ") does not match inode cache (" ++ show old ++ ")"+ return False+ ) elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool elemInodeCaches _ [] = return False
Annex/Locations.hs view
@@ -1,6 +1,6 @@ {- git-annex file locations -- - 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. -}@@ -22,7 +22,8 @@ gitAnnexContentLock, gitAnnexInodeSentinal, gitAnnexInodeSentinalCache,- annexLocations,+ annexLocationsBare,+ annexLocationsNonBare, gitAnnexDir, gitAnnexObjectDir, gitAnnexTmpOtherDir,@@ -134,14 +135,21 @@ objectDir' :: RawFilePath objectDir' = P.addTrailingPathSeparator $ annexDir P.</> "objects" -{- Annexed file's possible locations relative to the .git directory.- - There are two different possibilities, using different hashes.+{- Annexed file's possible locations relative to the .git directory+ - in a non-bare repository. -- - Also, some repositories have a Difference in hash directory depth.- -}-annexLocations :: GitConfig -> Key -> [RawFilePath]-annexLocations config key = map (annexLocation config key) dirHashes+ - Normally it is hashDirMixed. However, it's always possible that a+ - bare repository was converted to non-bare, or that the cripped+ - filesystem setting changed, so still need to check both. -}+annexLocationsNonBare :: GitConfig -> Key -> [RawFilePath]+annexLocationsNonBare config key = + map (annexLocation config key) [hashDirMixed, hashDirLower] +{- Annexed file's possible locations relative to a bare repository. -}+annexLocationsBare :: GitConfig -> Key -> [RawFilePath]+annexLocationsBare config key = + map (annexLocation config key) [hashDirLower, hashDirMixed]+ annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> RawFilePath annexLocation config key hasher = objectDir' P.</> keyPath key (hasher $ objectHashLevels config) @@ -171,23 +179,20 @@ gitAnnexLocation' key r config crippled symlinkssupported checker gitdir {- Bare repositories default to hashDirLower for new - content, as it's more portable. But check all locations. -}- | Git.repoIsLocalBare r = checkall+ | Git.repoIsLocalBare r = checkall annexLocationsBare+ {- If the repository is configured to only use lower, no need+ - to check both. -} | hasDifference ObjectHashLower (annexDifferences config) = only hashDirLower- {- Repositories on crippled filesystems use hashDirLower- - for new content, unless symlinks are supported too.- - Then hashDirMixed is used. But, the content could be- - in either location so check both. -}+ {- Repositories on crippled filesystems use same layout as bare+ - repos for new content, unless symlinks are supported too. -} | crippled = if symlinkssupported- then check $ map inrepo $ reverse $ annexLocations config key- else checkall- {- Regular repositories only use hashDirMixed, so- - don't need to do any work to check if the file is- - present. -}- | otherwise = only hashDirMixed+ then checkall annexLocationsNonBare+ else checkall annexLocationsBare+ | otherwise = checkall annexLocationsNonBare where only = return . inrepo . annexLocation config key- checkall = check $ map inrepo $ annexLocations config key+ checkall f = check $ map inrepo $ f config key inrepo d = gitdir P.</> d check locs@(l:_) = fromMaybe l <$> firstM checker locs@@ -621,8 +626,8 @@ {- All possibile locations to store a key in a special remote - using different directory hashes. -- - This is compatible with the annexLocations, for interoperability between- - special remotes and git-annex repos.+ - This is compatible with the annexLocationsNonBare and annexLocationsBare,+ - for interoperability between special remotes and git-annex repos. -} keyPaths :: Key -> [RawFilePath] keyPaths key = map (\h -> keyPath key (h def)) dirHashes
Annex/ReplaceFile.hs view
@@ -1,6 +1,6 @@ {- git-annex file replacing -- - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ - Copyright 2013-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -12,6 +12,7 @@ replaceGitDirFile, replaceWorkTreeFile, replaceFile,+ replaceFile', ) where import Annex.Common@@ -54,7 +55,10 @@ - fails, and can create any parent directory structure needed. -} replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (FilePath -> Annex a) -> Annex a-replaceFile createdirectory file action = withOtherTmp $ \othertmpdir -> do+replaceFile createdirectory file action = replaceFile' createdirectory file (const True) action++replaceFile' :: (RawFilePath -> Annex ()) -> FilePath -> (a -> Bool) -> (FilePath -> Annex a) -> Annex a+replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -> do let othertmpdir' = fromRawFilePath othertmpdir #ifndef mingw32_HOST_OS -- Use part of the filename as the template for the temp@@ -70,7 +74,8 @@ withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do let tmpfile = tmpdir </> basetmp r <- action tmpfile- replaceFileFrom tmpfile file createdirectory+ when (checkres r) $+ replaceFileFrom tmpfile file createdirectory return r replaceFileFrom :: FilePath -> FilePath -> (RawFilePath -> Annex ()) -> Annex ()
Annex/Verify.hs view
@@ -5,11 +5,29 @@ - Licensed under the GNU AGPL version 3 or higher. -} -module Annex.Verify where+module Annex.Verify (+ VerifyConfig(..),+ shouldVerify,+ verifyKeyContentPostRetrieval,+ verifyKeyContent,+ Verification(..),+ unVerified,+ warnUnverifiableInsecure,+ isVerifiable,+ startVerifyKeyContentIncrementally,+ IncrementalVerifier(..),+) where import Annex.Common import qualified Annex import qualified Types.Remote+import qualified Types.Backend+import Types.Backend (IncrementalVerifier(..))+import qualified Backend+import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..))+import Annex.WorkerPool+import Types.WorkerPool+import Types.Key data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify @@ -23,3 +41,74 @@ -- Export remotes are not key/value stores, so always verify -- content from them even when verification is disabled. <||> Types.Remote.isExportSupported r++{- Verifies that a file is the expected content of a key.+ -+ - Configuration can prevent verification, for either a+ - particular remote or always, unless the RetrievalSecurityPolicy+ - requires verification.+ -+ - Most keys have a known size, and if so, the file size is checked.+ -+ - When the key's backend allows verifying the content (via checksum),+ - it is checked. + -+ - If the RetrievalSecurityPolicy requires verification and the key's+ - backend doesn't support it, the verification will fail.+ -}+verifyKeyContentPostRetrieval :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool+verifyKeyContentPostRetrieval rsp v verification k f = case (rsp, verification) of+ (_, Verified) -> return True+ (RetrievalVerifiableKeysSecure, _) -> ifM (isVerifiable k)+ ( verify+ , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig)+ ( verify+ , warnUnverifiableInsecure k >> return False+ )+ )+ (_, UnVerified) -> ifM (shouldVerify v)+ ( verify+ , return True+ )+ (_, MustVerify) -> verify+ where+ verify = enteringStage VerifyStage $ verifyKeyContent k f++verifyKeyContent :: Key -> RawFilePath -> Annex Bool+verifyKeyContent k f = verifysize <&&> verifycontent+ where+ verifysize = case fromKey keySize k of+ Nothing -> return True+ Just size -> do+ size' <- liftIO $ catchDefaultIO 0 $ getFileSize f+ return (size' == size)+ verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case+ Nothing -> return True+ Just b -> case Types.Backend.verifyKeyContent b of+ Nothing -> return True+ Just verifier -> verifier k f++warnUnverifiableInsecure :: Key -> Annex ()+warnUnverifiableInsecure k = warning $ unwords+ [ "Getting " ++ kv ++ " keys with this remote is not secure;"+ , "the content cannot be verified to be correct."+ , "(Use annex.security.allow-unverified-downloads to bypass"+ , "this safety check.)"+ ]+ where+ kv = decodeBS (formatKeyVariety (fromKey keyVariety k))++isVerifiable :: Key -> Annex Bool+isVerifiable k = maybe False (isJust . Types.Backend.verifyKeyContent) + <$> Backend.maybeLookupBackendVariety (fromKey keyVariety k)++startVerifyKeyContentIncrementally :: VerifyConfig -> Key -> Annex (Maybe IncrementalVerifier)+startVerifyKeyContentIncrementally verifyconfig k = + ifM (shouldVerify verifyconfig)+ ( Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case+ Just b -> case Types.Backend.verifyKeyContentIncrementally b of+ Just v -> Just <$> v k+ Nothing -> return Nothing+ Nothing -> return Nothing+ , return Nothing+ )
Annex/WorkTree.hs view
@@ -8,25 +8,11 @@ module Annex.WorkTree where import Annex.Common-import qualified Annex import Annex.Link import Annex.CatFile-import Annex.Content-import Annex.ReplaceFile import Annex.CurrentBranch-import Annex.InodeSentinal-import Utility.InodeCache-import Git.FilePath-import Git.CatFile-import qualified Git.Ref-import qualified Git.LsTree-import qualified Git.Types import qualified Database.Keys-import Config-import qualified Utility.RawFilePath as R -import qualified Data.ByteString.Lazy as L- {- Looks up the key corresponding to an annexed file in the work tree, - by examining what the file links to. -@@ -69,74 +55,13 @@ {- Find all annexed files and update the keys database for them. - - - This is expensive, and so normally the associated files are updated- - incrementally when changes are noticed. So, this only needs to be done- - when initializing/upgrading a repository.+ - Normally the keys database is updated incrementally when it's being+ - opened, and changes are noticed. Calling this explicitly allows+ - running the update at an earlier point. -- - Also, the content for an unlocked file may already be present as- - an annex object. If so, populate the pointer file with it.- - But if worktree file does not have a pointer file's content, it is left- - as-is.+ - All that needs to be done is to open the database,+ - that will result in Database.Keys.reconcileStaged+ - running, and doing the work. -}-scanAnnexedFiles :: Bool -> Annex ()-scanAnnexedFiles initscan = do- -- This gets the keys database populated with all annexed files,- -- by running Database.Keys.reconcileStaged.- Database.Keys.runWriter (const noop)- -- The above tries to populate pointer files, but one thing it- -- is not able to handle is populating a pointer file when the- -- annex object file already exists, but its inode is not yet- -- cached and annex.thin is set. So, the rest of this makes- -- another pass over the tree to do that.- whenM- ( pure initscan- <&&> annexThin <$> Annex.getGitConfig- <&&> inRepo Git.Ref.headExists- <&&> not <$> isBareRepo- ) $ do- g <- Annex.gitRepo- (l, cleanup) <- inRepo $ Git.LsTree.lsTree- Git.LsTree.LsTreeRecursive- (Git.LsTree.LsTreeLong True)- Git.Ref.headRef- catObjectStreamLsTree l want g go- liftIO $ void cleanup- where- -- Want to process symlinks, and regular files.- want i = case Git.Types.toTreeItemType (Git.LsTree.mode i) of- Just Git.Types.TreeSymlink -> Just (i, False)- Just Git.Types.TreeFile -> checkfilesize i- Just Git.Types.TreeExecutable -> checkfilesize i- _ -> Nothing- - -- Avoid processing files that are too large to be pointer files.- checkfilesize i = case Git.LsTree.size i of- Just n | n < maxPointerSz -> Just (i, True)- _ -> Nothing- - go getnext = liftIO getnext >>= \case- Just ((i, isregfile), Just c) -> do- maybe noop (add i isregfile)- (parseLinkTargetOrPointer (L.toStrict c))- go getnext- _ -> return ()- - add i isregfile k = do- let tf = Git.LsTree.file i- whenM (pure isregfile <&&> inAnnex k) $ do- f <- fromRepo $ fromTopFilePath tf- liftIO (isPointerFile f) >>= \case- Just k' | k' == k -> do- destmode <- liftIO $ catchMaybeIO $- fileMode <$> R.getFileStatus f- ic <- replaceWorkTreeFile (fromRawFilePath f) $ \tmp -> do- let tmp' = toRawFilePath tmp- linkFromAnnex k tmp' destmode >>= \case- LinkAnnexOk -> - withTSDelta (liftIO . genInodeCache tmp')- LinkAnnexNoop -> return Nothing- LinkAnnexFailed -> liftIO $ do- writePointerFile tmp' k destmode- return Nothing- maybe noop (restagePointerFile (Restage True) f) ic- _ -> noop+scanAnnexedFiles :: Annex ()+scanAnnexedFiles = Database.Keys.runWriter (const noop)
Assistant/MakeRepo.hs view
@@ -60,8 +60,8 @@ unlessM (Git.Config.isBare <$> gitRepo) $ do cmode <- annexCommitMode <$> Annex.getGitConfig void $ inRepo $ Git.Branch.commitCommand cmode- [ Param "--quiet"- , Param "--allow-empty"+ (Git.Branch.CommitQuiet True)+ [ Param "--allow-empty" , Param "-m" , Param "created repository" ]@@ -85,7 +85,7 @@ initRepo' :: Maybe String -> Maybe StandardGroup -> Annex () initRepo' desc mgroup = unlessM isInitialized $ do- initialize desc Nothing+ initialize False desc Nothing u <- getUUID maybe noop (defaultStandardGroup u) mgroup {- Ensure branch gets committed right away so it is
Assistant/Sync.hs view
@@ -21,6 +21,7 @@ import qualified Git.Command import qualified Remote import qualified Types.Remote as Remote+import qualified Annex import qualified Annex.Branch import Remote.List.Util import Annex.UUID@@ -125,25 +126,26 @@ pushToRemotes' :: UTCTime -> [Remote] -> Assistant [Remote] pushToRemotes' now remotes = do- (g, branch, u) <- liftAnnex $ do+ (g, branch, u, ms) <- liftAnnex $ do Annex.Branch.commit =<< Annex.Branch.commitMessage- (,,)+ (,,,) <$> gitRepo <*> getCurrentBranch <*> getUUID- ret <- go True branch g u remotes+ <*> Annex.getState Annex.output+ ret <- go ms True branch g u remotes return ret where- go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do- go _ _ _ _ [] = return [] -- no remotes, so nothing to do- go shouldretry currbranch@(Just branch, _) g u rs = do+ go _ _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do+ go _ _ _ _ _ [] = return [] -- no remotes, so nothing to do+ go ms shouldretry currbranch@(Just branch, _) g u rs = do debug ["pushing to", show rs]- (succeeded, failed) <- parallelPush g rs (push branch)+ (succeeded, failed) <- parallelPush g rs (push ms branch) updatemap succeeded [] if null failed then return [] else if shouldretry- then retry currbranch g u failed+ then retry ms currbranch g u failed else fallback branch g u failed updatemap succeeded failed = do@@ -153,10 +155,10 @@ M.difference m (makemap succeeded) makemap l = M.fromList $ zip l (repeat now) - retry currbranch g u rs = do+ retry ms currbranch g u rs = do debug ["trying manual pull to resolve failed pushes"] void $ manualPull currbranch rs- go False currbranch g u rs+ go ms False currbranch g u rs fallback branch g u rs = do debug ["fallback pushing to", show rs]@@ -164,7 +166,7 @@ updatemap succeeded failed return failed - push branch remote = Command.Sync.pushBranch remote (Just branch)+ push ms branch remote = Command.Sync.pushBranch remote (Just branch) ms parallelPush :: Git.Repo -> [Remote] -> (Remote -> Git.Repo -> IO Bool)-> Assistant ([Remote], [Remote]) parallelPush g rs a = do@@ -211,6 +213,8 @@ manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool) manualPull currentbranch remotes = do g <- liftAnnex gitRepo+ -- Allow merging unrelated histories.+ mc <- liftAnnex $ Command.Sync.mergeConfig True failed <- forM remotes $ \r -> if wantpull $ Remote.gitconfig r then do g' <- liftAnnex $ do@@ -225,7 +229,7 @@ <$> liftAnnex Annex.Branch.forceUpdate forM_ remotes $ \r -> liftAnnex $ Command.Sync.mergeRemote r- currentbranch Command.Sync.mergeConfig def+ currentbranch mc def when haddiverged $ updateExportTreeFromLogAll return (catMaybes failed, haddiverged)
Assistant/Threads/Merger.hs view
@@ -90,8 +90,11 @@ ] void $ liftAnnex $ do cmode <- annexCommitMode <$> Annex.getGitConfig+ -- Allow merging unrelated histories.+ mc <- Command.Sync.mergeConfig True Command.Sync.merge- currbranch Command.Sync.mergeConfig+ currbranch+ mc def cmode changedbranch
Backend.hs view
@@ -16,14 +16,11 @@ maybeLookupBackendVariety, isStableKey, isCryptographicallySecure,- isVerifiable,- startVerifyKeyContentIncrementally, ) where import Annex.Common import qualified Annex import Annex.CheckAttr-import Annex.Verify import Types.Key import Types.KeySource import qualified Types.Backend as B@@ -125,18 +122,3 @@ isCryptographicallySecure :: Key -> Annex Bool isCryptographicallySecure k = maybe False (`B.isCryptographicallySecure` k) <$> maybeLookupBackendVariety (fromKey keyVariety k)--isVerifiable :: Key -> Annex Bool-isVerifiable k = maybe False (isJust . B.verifyKeyContent) - <$> maybeLookupBackendVariety (fromKey keyVariety k)--startVerifyKeyContentIncrementally :: VerifyConfig -> Key -> Annex (Maybe B.IncrementalVerifier)-startVerifyKeyContentIncrementally verifyconfig k = - ifM (shouldVerify verifyconfig)- ( maybeLookupBackendVariety (fromKey keyVariety k) >>= \case- Just b -> case B.verifyKeyContentIncrementally b of- Just v -> Just <$> v k- Nothing -> return Nothing- Nothing -> return Nothing- , return Nothing- )
CHANGELOG view
@@ -1,3 +1,34 @@+git-annex (8.20210803) upstream; urgency=medium++ * whereused: New command, finds what files use a key, or where a key+ was used historically.+ * Fix a bug that prevented getting content from a repository that+ started out as a bare repository, or had annex.crippledfilesystem+ set, and was converted to a non-bare repository.+ * Fix retrieval of content from borg repos accessed over ssh.+ * sync: When --quiet is used, run git commit, push, and pull without+ their ususual output.+ * merge: When --quiet is used, run git merge without its usual output.+ * sync, merge, post-receive: Avoid merging unrelated histories,+ which used to be allowed only to support direct mode repositories.+ (However, sync does still merge unrelated histories when importing+ trees from special remotes, and the assistant still merges unrelated+ histories.)+ * sync, merge: Added --allow-unrelated-histories option, which+ is the same as the git merge option.+ * Fix bug that caused some transfers to incorrectly fail with+ "content changed while it was being sent", when the content was not+ changed.+ * Fix bug that could prevent pointer files from being populated,+ in a repository that was upgraded from v7.+ * fsck: Detect and correct stale or missing inode caches.+ * Fix a rounding bug in display of data sizes.+ * git-annex get when run as the first git-annex command in a new repo+ did not populate unlocked files.+ (Reversion in version 8.20210621)++ -- Joey Hess <id@joeyh.name> Tue, 03 Aug 2021 12:20:09 -0400+ git-annex (8.20210714) upstream; urgency=medium * assistant: Avoid unncessary git repository repair in a situation where
CmdLine/GitAnnex.hs view
@@ -72,6 +72,7 @@ import qualified Command.Find import qualified Command.FindRef import qualified Command.Whereis+import qualified Command.WhereUsed import qualified Command.List import qualified Command.Log import qualified Command.Merge@@ -207,6 +208,7 @@ , Command.Find.cmd , Command.FindRef.cmd , Command.Whereis.cmd+ , Command.WhereUsed.cmd , Command.List.cmd , Command.Log.cmd , Command.Merge.cmd
Command/ConfigList.hs view
@@ -47,7 +47,7 @@ else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit)) ( do liftIO checkNotReadOnly- initialize Nothing Nothing+ initialize True Nothing Nothing getUUID , return NoUUID )
Command/Fix.hs view
@@ -77,15 +77,15 @@ unlessM (checkedCopyFile key obj tmp' mode) $ error "unable to break hard link" thawContent tmp'+ Database.Keys.storeInodeCaches key [tmp'] modifyContent obj $ freezeContent obj- Database.Keys.storeInodeCaches key [file] next $ return True makeHardLink :: RawFilePath -> Key -> CommandPerform makeHardLink file key = do replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file- linkFromAnnex key (toRawFilePath tmp) mode >>= \case+ linkFromAnnex' key (toRawFilePath tmp) mode >>= \case LinkAnnexFailed -> error "unable to make hard link" _ -> noop next $ return True
Command/Fsck.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - 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. -}@@ -16,6 +16,7 @@ import qualified Types.Backend import qualified Backend import Annex.Content+import Annex.Content.Presence.LowLevel import Annex.Perms import Annex.Link import Logs.Location@@ -31,6 +32,8 @@ import Utility.CopyFile import Git.FilePath import Utility.PID+import Utility.InodeCache+import Annex.InodeSentinal import qualified Database.Keys import qualified Database.Fsck as FsckDb import Types.CleanupActions@@ -357,13 +360,13 @@ let tmp' = toRawFilePath tmp mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file ifM (annexThin <$> Annex.getGitConfig)- ( void $ linkFromAnnex key tmp' mode+ ( void $ linkFromAnnex' key tmp' mode , do obj <- calcRepo (gitAnnexLocation key) void $ checkedCopyFile key obj tmp' mode thawContent tmp' )- Database.Keys.storeInodeCaches key [file]+ Database.Keys.storeInodeCaches key [tmp'] _ -> return () return True @@ -437,17 +440,23 @@ {- Runs the backend specific check on a key's content object. -- - When a file is unlocked, it may be a hard link to the object,- - thus when the user modifies the file, the object will be modified and+ - When a annex.this is set, an unlocked file may be a hard link to the object.+ - Thus when the user modifies the file, the object will be modified and - not pass the check, and we don't want to find an error in this case.- - So, skip the check if the key is unlocked and modified. -} checkBackend :: Backend -> Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend backend key keystatus afile = do content <- calcRepo (gitAnnexLocation key) ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) ( nocheck- , checkBackendOr badContent backend key content ai+ , do+ mic <- withTSDelta (liftIO . genInodeCache content)+ ifM (checkBackendOr badContent backend key content ai)+ ( do+ checkInodeCache key content mic ai+ return True+ , return False+ ) ) where nocheck = return True@@ -460,29 +469,44 @@ checkBackendOr :: (Key -> Annex String) -> Backend -> Key -> RawFilePath -> ActionItem -> Annex Bool checkBackendOr bad backend key file ai =- checkBackendOr' bad backend key file ai (return True)---- The postcheck action is run after the content is verified,--- in order to detect situations where the file is changed while being--- verified.-checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> RawFilePath -> ActionItem -> Annex Bool -> Annex Bool-checkBackendOr' bad backend key file ai postcheck = case Types.Backend.verifyKeyContent backend of- Nothing -> return True Just verifier -> do ok <- verifier key file- ifM postcheck- ( do- unless ok $ do- msg <- bad key+ unless ok $ do+ msg <- bad key+ warning $ concat+ [ decodeBS' (actionItemDesc ai)+ , ": Bad file content; "+ , msg+ ]+ return ok+ Nothing -> return True++{- Check, if there are InodeCaches recorded for a key, that one of them+ - matches the object file. There are situations where the InodeCache+ - of the object file does not get recorded, including a v8 upgrade.+ - There may also be situations where the wrong InodeCache is recorded,+ - if inodes are not stable.+ -+ - This must be called after the content of the object file has been+ - verified to be correct. The InodeCache is generated again to detect if+ - the object file was changed while the content was being verified.+ -}+checkInodeCache :: Key -> RawFilePath -> Maybe InodeCache -> ActionItem -> Annex ()+checkInodeCache key content mic ai = case mic of+ Nothing -> noop+ Just ic -> do+ ics <- Database.Keys.getInodeCaches key+ unless (null ics) $+ unlessM (isUnmodifiedCheapLowLevel ic ics) $ do+ withTSDelta (liftIO . genInodeCache content) >>= \case+ Nothing -> noop+ Just ic' -> whenM (compareInodeCaches ic ic') $ do warning $ concat [ decodeBS' (actionItemDesc ai)- , ": Bad file content; "- , msg+ , ": Stale or missing inode cache; updating." ]- return ok- , return True- )+ Database.Keys.addInodeCaches key [ic] checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool checkKeyNumCopies key afile numcopies = do
Command/Init.hs view
@@ -70,7 +70,7 @@ Just v | v /= wantversion -> giveup $ "This repository is already a initialized with version " ++ show (fromRepoVersion v) ++ ", not changing to requested version." _ -> noop- initialize+ initialize False (if null (initDesc os) then Nothing else Just (initDesc os)) (initVersion os) Annex.SpecialRemote.autoEnable
Command/Lock.hs view
@@ -91,8 +91,10 @@ liftIO $ removeWhenExistsWith R.removeLink obj case mfile of Just unmodified ->- unlessM (checkedCopyFile key unmodified obj Nothing)- lostcontent+ ifM (checkedCopyFile key unmodified obj Nothing)+ ( Database.Keys.storeInodeCaches key [obj]+ , lostcontent+ ) Nothing -> lostcontent lostcontent = logStatus key InfoMissing
Command/Merge.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -12,23 +12,35 @@ import qualified Git import qualified Git.Branch import Annex.CurrentBranch-import Command.Sync (prepMerge, mergeLocal, mergeConfig, merge, SyncOptions(..))+import Command.Sync (prepMerge, mergeLocal, mergeConfig, merge, notOnlyAnnexOption, parseUnrelatedHistoriesOption) import Git.Types cmd :: Command cmd = command "merge" SectionMaintenance "merge changes from remotes"- (paramOptional paramRef) (withParams seek)+ (paramOptional paramRef) (seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek [] = do- prepMerge- commandAction mergeAnnexBranch- commandAction mergeSyncedBranch-seek bs = do- prepMerge- forM_ bs (commandAction . mergeBranch . Git.Ref . encodeBS')+data MergeOptions = MergeOptions+ { mergeBranches :: [String]+ , allowUnrelatedHistories :: Bool+ } +optParser :: CmdParamsDesc -> Parser MergeOptions+optParser desc = MergeOptions+ <$> cmdParams desc+ <*> parseUnrelatedHistoriesOption++seek :: MergeOptions -> CommandSeek+seek o+ | mergeBranches o == [] = do+ prepMerge+ commandAction mergeAnnexBranch+ commandAction (mergeSyncedBranch o)+ | otherwise = do+ prepMerge+ forM_ (mergeBranches o) $+ commandAction . mergeBranch o . Git.Ref . encodeBS'+ mergeAnnexBranch :: CommandStart mergeAnnexBranch = starting "merge" ai si $ do _ <- Annex.Branch.update@@ -39,14 +51,17 @@ ai = ActionItemOther (Just (fromRef Annex.Branch.name)) si = SeekInput [] -mergeSyncedBranch :: CommandStart-mergeSyncedBranch = mergeLocal mergeConfig def =<< getCurrentBranch+mergeSyncedBranch :: MergeOptions -> CommandStart+mergeSyncedBranch o = do+ mc <- mergeConfig (allowUnrelatedHistories o)+ mergeLocal mc def =<< getCurrentBranch -mergeBranch :: Git.Ref -> CommandStart-mergeBranch r = starting "merge" ai si $ do+mergeBranch :: MergeOptions -> Git.Ref -> CommandStart+mergeBranch o r = starting "merge" ai si $ do currbranch <- getCurrentBranch- let o = def { notOnlyAnnexOption = True }- next $ merge currbranch mergeConfig o Git.Branch.ManualCommit r+ mc <- mergeConfig (allowUnrelatedHistories o)+ let so = def { notOnlyAnnexOption = True }+ next $ merge currbranch mc so Git.Branch.ManualCommit r where ai = ActionItemOther (Just (Git.fromRef r)) si = SeekInput []
Command/PostReceive.hs view
@@ -52,4 +52,5 @@ updateInsteadEmulation = do prepMerge let o = def { notOnlyAnnexOption = True }- mergeLocal mergeConfig o =<< getCurrentBranch+ mc <- mergeConfig False+ mergeLocal mc o =<< getCurrentBranch
Command/Reinit.hs view
@@ -35,6 +35,6 @@ then return $ toUUID s else Remote.nameToUUID s storeUUID u- initialize' Nothing+ initialize' False Nothing Annex.SpecialRemote.autoEnable next $ return True
Command/Reinject.hs view
@@ -50,7 +50,7 @@ where src' = toRawFilePath src go key = starting "reinject" ai si $- ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src')+ ifM (verifyKeyContent key src') ( perform src' key , giveup $ src ++ " does not have expected content of " ++ dest )
Command/Smudge.hs view
@@ -267,7 +267,7 @@ -- point to refresh the keys database for changes to annexed files. -- Doing it explicitly here avoids a later pause in the middle of -- some other action.- scanAnnexedFiles False+ scanAnnexedFiles updateSmudged (Restage True) stop
Command/Sync.hs view
@@ -1,7 +1,7 @@ {- git-annex command - - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>- - 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. -}@@ -24,6 +24,7 @@ syncBranch, updateBranches, seekExportContent,+ parseUnrelatedHistoriesOption, SyncOptions(..), ) where @@ -102,6 +103,7 @@ , cleanupOption :: Bool , keyOptions :: Maybe KeyOptions , resolveMergeOverride :: Bool+ , allowUnrelatedHistories :: Bool } instance Default SyncOptions where@@ -120,6 +122,7 @@ , cleanupOption = False , keyOptions = Nothing , resolveMergeOverride = False+ , allowUnrelatedHistories = False } optParser :: CmdParamsDesc -> Parser SyncOptions@@ -177,7 +180,14 @@ <*> invertableSwitch "resolvemerge" True ( help "do not automatically resolve merge conflicts" )+ <*> parseUnrelatedHistoriesOption +parseUnrelatedHistoriesOption :: Parser Bool+parseUnrelatedHistoriesOption = + invertableSwitch "allow-unrelated-histories" False+ ( help "allow merging unrelated histories"+ )+ -- Since prepMerge changes the working directory, FilePath options -- have to be adjusted. instance DeferredParseClass SyncOptions where@@ -196,6 +206,7 @@ <*> pure (cleanupOption v) <*> pure (keyOptions v) <*> pure (resolveMergeOverride v)+ <*> pure (allowUnrelatedHistories v) seek :: SyncOptions -> CommandSeek seek o = do@@ -218,21 +229,23 @@ commandAction (withbranch cleanupLocal) mapM_ (commandAction . withbranch . cleanupRemote) gitremotes else do+ mc <- mergeConfig (allowUnrelatedHistories o)+ -- Syncing involves many actions, any of which -- can independently fail, without preventing -- the others from running. -- These actions cannot be run concurrently. mapM_ includeCommandAction $ concat [ [ commit o ]- , [ withbranch (mergeLocal mergeConfig o) ]- , map (withbranch . pullRemote o mergeConfig) gitremotes+ , [ withbranch (mergeLocal mc o) ]+ , map (withbranch . pullRemote o mc) gitremotes , [ mergeAnnex ] ] content <- shouldSyncContent o forM_ (filter isImport contentremotes) $- withbranch . importRemote content o mergeConfig+ withbranch . importRemote content o forM_ (filter isThirdPartyPopulated contentremotes) $ pullThirdPartyPopulated o @@ -259,7 +272,7 @@ -- avoid our push overwriting those changes. when (syncedcontent || exportedcontent) $ do mapM_ includeCommandAction $ concat- [ map (withbranch . pullRemote o mergeConfig) gitremotes+ [ map (withbranch . pullRemote o mc) gitremotes , [ commitAnnex, mergeAnnex ] ] @@ -273,17 +286,18 @@ prepMerge :: Annex () prepMerge = Annex.changeDirectory . fromRawFilePath =<< fromRepo Git.repoPath -mergeConfig :: [Git.Merge.MergeConfig] -mergeConfig = - [ Git.Merge.MergeNonInteractive- -- In several situations, unrelated histories should be merged- -- together. This includes pairing in the assistant, merging- -- from a remote into a newly created direct mode repo,- -- and an initial merge from an import from a special remote.- -- (Once direct mode is removed, this could be changed, so only- -- the assistant and import from special remotes use it.)- , Git.Merge.MergeUnrelatedHistories- ]+mergeConfig :: Bool -> Annex [Git.Merge.MergeConfig]+mergeConfig mergeunrelated = do+ quiet <- commandProgressDisabled+ return $ catMaybes+ [ Just Git.Merge.MergeNonInteractive+ , if mergeunrelated + then Just Git.Merge.MergeUnrelatedHistories+ else Nothing+ , if quiet+ then Just Git.Merge.MergeQuiet+ else Nothing+ ] merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool merge currbranch mergeconfig o commitmode tomerge = do@@ -331,7 +345,9 @@ Annex.Branch.commit =<< Annex.Branch.commitMessage next $ do showOutput- void $ inRepo $ Git.Branch.commitCommand Git.Branch.ManualCommit+ let cmode = Git.Branch.ManualCommit+ cquiet <- Git.Branch.CommitQuiet <$> commandProgressDisabled+ void $ inRepo $ Git.Branch.commitCommand cmode cquiet [ Param "-a" , Param "-m" , Param commitmessage@@ -462,16 +478,21 @@ where fetch bs = do repo <- Remote.getRepo remote+ ms <- Annex.getState Annex.output inRepoWithSshOptionsTo repo (Remote.gitconfig remote) $- Git.Command.runBool $- [Param "fetch", Param $ Remote.name remote]- ++ map Param bs+ Git.Command.runBool $ catMaybes+ [ Just $ Param "fetch"+ , if commandProgressDisabled' ms+ then Just $ Param "--quiet"+ else Nothing+ , Just $ Param $ Remote.name remote+ ] ++ map Param bs wantpull = remoteAnnexPull (Remote.gitconfig remote) ai = ActionItemOther (Just (Remote.name remote)) si = SeekInput [] -importRemote :: Bool -> SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandSeek-importRemote importcontent o mergeconfig remote currbranch+importRemote :: Bool -> SyncOptions -> Remote -> CurrBranch -> CommandSeek+importRemote importcontent o remote currbranch | not (pullOption o) || not wantpull = noop | otherwise = case remoteAnnexTrackingBranch (Remote.gitconfig remote) of Nothing -> noop@@ -484,7 +505,13 @@ if canImportKeys remote importcontent then do Command.Import.seekRemote remote branch subdir importcontent (CheckGitIgnore True)- void $ mergeRemote remote currbranch mergeconfig o+ -- Importing generates a branch+ -- that is not initially connected+ -- to the current branch, so allow+ -- merging unrelated histories when+ -- mergeing it.+ mc <- mergeConfig True+ void $ mergeRemote remote currbranch mc o else warning $ "Cannot import from " ++ Remote.name remote ++ " when not syncing content." where wantpull = remoteAnnexPull (Remote.gitconfig remote)@@ -548,8 +575,9 @@ starting "push" ai si $ next $ do repo <- Remote.getRepo remote showOutput+ ms <- Annex.getState Annex.output ok <- inRepoWithSshOptionsTo repo gc $- pushBranch remote mainbranch+ pushBranch remote mainbranch ms if ok then postpushupdate repo else do@@ -621,8 +649,8 @@ - The only difference caused by using a forced push in that case is that - the last repository to push wins the race, rather than the first to push. -}-pushBranch :: Remote -> Maybe Git.Branch -> Git.Repo -> IO Bool-pushBranch remote mbranch g = directpush `after` annexpush `after` syncpush+pushBranch :: Remote -> Maybe Git.Branch -> MessageState -> Git.Repo -> IO Bool+pushBranch remote mbranch ms g = directpush `after` annexpush `after` syncpush where syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes [ (refspec . fromAdjustedBranch) <$> mbranch@@ -648,9 +676,12 @@ (transcript, ok) <- processTranscript' p Nothing when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $ hPutStr stderr transcript- pushparams branches =- [ Param "push"- , Param $ Remote.name remote+ pushparams branches = catMaybes+ [ Just $ Param "push"+ , if commandProgressDisabled' ms+ then Just $ Param "--quiet"+ else Nothing+ , Just $ Param $ Remote.name remote ] ++ map Param branches refspec b = concat [ Git.fromRef $ Git.Ref.base b
Command/TestRemote.hs view
@@ -354,7 +354,7 @@ liftIO $ hClose h tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case Left _ -> return False- Right () -> verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified k (toRawFilePath tmp)+ Right () -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify UnVerified k (toRawFilePath tmp) checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation removeexport ea k = Remote.removeExport ea k testexportlocation removeexportdirectory ea = case Remote.removeExportDirectory ea of
Command/Unlock.hs view
@@ -50,7 +50,7 @@ replaceWorkTreeFile (fromRawFilePath dest) $ \tmp -> ifM (inAnnex key) ( do- r <- linkFromAnnex key (toRawFilePath tmp) destmode+ r <- linkFromAnnex' key (toRawFilePath tmp) destmode case r of LinkAnnexOk -> return () LinkAnnexNoop -> return ()
Command/Unused.hs view
@@ -139,7 +139,7 @@ unusedMsg' u mheader mtrailer = unlines $ mheader ++ table u ++- ["(To see where data was previously used, try: git log --stat --no-textconv -S'KEY')"] +++ ["(To see where this data was previously used, run: git annex whereused --historical --unused"] ++ mtrailer remoteUnusedMsg :: Maybe Remote -> RemoteName -> [(Int, Key)] -> String
Command/Upgrade.hs view
@@ -45,6 +45,6 @@ start _ = starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do whenM (isNothing <$> getVersion) $ do- initialize Nothing Nothing+ initialize False Nothing Nothing r <- upgrade False latestVersion next $ return r
+ Command/WhereUsed.hs view
@@ -0,0 +1,163 @@+{- git-annex command+ -+ - Copyright 2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.WhereUsed where++import Command+import Git+import Git.Sha+import Git.FilePath+import qualified Git.Ref+import qualified Git.Command+import qualified Git.DiffTree as DiffTree+import qualified Annex+import qualified Annex.Branch+import Annex.CatFile+import Database.Keys++import Data.Char+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++cmd :: Command+cmd = noCommit $ withGlobalOptions [annexedMatchingOptions] $+ command "whereused" SectionQuery+ "lists repositories that have file content"+ paramNothing (seek <$$> optParser)++data WhereUsedOptions = WhereUsedOptions+ { keyOptions :: KeyOptions+ , historicalOption :: Bool+ }++optParser :: CmdParamsDesc -> Parser WhereUsedOptions+optParser _desc = WhereUsedOptions+ <$> (parseUnusedKeysOption <|> parseSpecificKeyOption)+ <*> switch+ ( long "historical"+ <> help "find historical uses"+ )++seek :: WhereUsedOptions -> CommandSeek+seek o = withKeyOptions (Just (keyOptions o)) False dummyfileseeker+ (commandAction . start o) dummyfilecommandseek (WorkTreeItems [])+ where+ dummyfileseeker = AnnexedFileSeeker+ { startAction = \_ _ _ -> return Nothing+ , checkContentPresent = Nothing+ , usesLocationLog = False+ }+ dummyfilecommandseek = const noop++start :: WhereUsedOptions -> (SeekInput, Key, ActionItem) -> CommandStart+start o (_, key, _) = startingCustomOutput key $ do+ fs <- filterM stillassociated + =<< mapM (fromRepo . fromTopFilePath)+ =<< getAssociatedFiles key+ liftIO $ forM_ fs $ display key . fromRawFilePath++ when (historicalOption o && null fs) $+ findHistorical key++ next $ return True+ where+ -- Some associated files that are in the keys database may no+ -- longer correspond to files in the repository.+ stillassociated f = catKeyFile f >>= \case+ Just k | k == key -> return True+ _ -> return False++display :: Key -> String -> IO ()+display key loc = putStrLn (serializeKey key ++ " " ++ loc)++findHistorical :: Key -> Annex ()+findHistorical key = do+ -- Find most recent change to the key, in all branches and+ -- tags, except the git-annex branch.+ found <- searchLog key + -- Search all local branches, except git-annex branch.+ [ Param ("--exclude=*/" ++ fromRef (Annex.Branch.name))+ , Param "--glob=*"+ -- Also search remote branches+ , Param ("--exclude=" ++ fromRef (Annex.Branch.name))+ , Param "--remotes=*"+ -- And search tags.+ , Param "--tags=*"+ -- Output the commit hash+ , Param "--pretty=%H"+ ] $ \h fs repo -> do+ commitsha <- getSha "log" (pure h)+ commitdesc <- S.takeWhile (/= fromIntegral (ord '\n'))+ <$> Git.Command.pipeReadStrict+ [ Param "describe"+ , Param "--contains"+ , Param "--all"+ , Param (fromRef commitsha)+ ] repo+ if S.null commitdesc+ then return False+ else process fs $+ displayreffile (Ref commitdesc)+ + unless found $+ void $ searchLog key+ [ Param "--walk-reflogs"+ -- Output the reflog selector+ , Param "--pretty=%gd"+ ] $ \h fs _ -> process fs $+ displayreffile (Ref h)+ where+ process fs a = or <$> forM fs a++ displayreffile r f = do+ let fref = Git.Ref.branchFileRef r f+ display key (fromRef fref)+ return True++searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Repo -> IO Bool) -> Annex Bool+searchLog key ps a = Annex.inRepo $ \repo -> do+ (output, cleanup) <- Git.Command.pipeNullSplit ps' repo+ found <- case output of+ (h:rest) -> do+ let diff = DiffTree.parseDiffRaw rest+ let fs = map (flip fromTopFilePath repo . DiffTree.file) diff+ rfs <- mapM relPathCwdToFile fs+ a (L.toStrict h) rfs repo+ _ -> return False+ void cleanup+ return found+ where+ ps' = + [ Param "log"+ , Param "-z"+ -- Don't convert pointer files.+ , Param "--no-textconv"+ -- Don't abbreviate hashes.+ , Param "--no-abbrev"+ -- Only find the most recent commit, for speed.+ , Param "-n1"+ -- Be sure to treat -G as a regexp.+ , Param "--basic-regexp"+ -- Find commits that contain the key. The object has to+ -- end with the key to avoid confusion with longer keys,+ -- so a regexp is used. Since annex pointer files+ -- may contain a newline followed by perhaps something+ -- else, that is also matched.+ , Param ("-G" ++ escapeRegexp (fromRawFilePath (keyFile key)) ++ "($|\n)")+ -- Skip commits where the file was deleted,+ -- only find those where it was added or modified.+ , Param "--diff-filter=ACMRTUX"+ -- Output the raw diff.+ , Param "--raw"+ ] ++ ps++escapeRegexp :: String -> String+escapeRegexp = concatMap esc+ where+ esc c+ | isAscii c && isAlphaNum c = [c]+ | otherwise = ['[', c, ']']
Database/Keys.hs view
@@ -18,7 +18,6 @@ getAssociatedKey, removeAssociatedFile, storeInodeCaches,- storeInodeCaches', addInodeCaches, getInodeCaches, removeInodeCaches,@@ -37,6 +36,7 @@ import qualified Annex import Annex.LockFile import Annex.Content.PointerFile+import Annex.Content.Presence.LowLevel import Annex.Link import Utility.InodeCache import Annex.InodeSentinal@@ -175,18 +175,22 @@ {- Stats the files, and stores their InodeCaches. -} storeInodeCaches :: Key -> [RawFilePath] -> Annex ()-storeInodeCaches k fs = storeInodeCaches' k fs []--storeInodeCaches' :: Key -> [RawFilePath] -> [InodeCache] -> Annex ()-storeInodeCaches' k fs ics = withTSDelta $ \d ->- addInodeCaches k . (++ ics) . catMaybes+storeInodeCaches k fs = withTSDelta $ \d ->+ addInodeCaches k . catMaybes =<< liftIO (mapM (\f -> genInodeCache f d) fs) addInodeCaches :: Key -> [InodeCache] -> Annex () addInodeCaches k is = runWriterIO $ SQL.addInodeCaches k is {- A key may have multiple InodeCaches; one for the annex object, and one- - for each pointer file that is a copy of it. -}+ - for each pointer file that is a copy of it.+ -+ - When there are no pointer files, the annex object typically does not+ - have its InodeCache recorded either, so the list will be empty.+ -+ - Note that, in repos upgraded from v7, there may be InodeCaches recorded+ - for pointer files, but none recorded for the annex object.+ -} getInodeCaches :: Key -> Annex [InodeCache] getInodeCaches = runReaderIO . SQL.getInodeCaches @@ -379,12 +383,16 @@ reconcilepointerfile file key = do ics <- liftIO $ SQL.getInodeCaches key (SQL.ReadHandle qh) obj <- calcRepo (gitAnnexLocation key)- objic <- withTSDelta (liftIO . genInodeCache obj)- -- Like inAnnex, check the annex object's inode cache+ mobjic <- withTSDelta (liftIO . genInodeCache obj)+ let addinodecaches k v = liftIO $+ SQL.addInodeCaches k v (SQL.WriteHandle qh)+ -- Like inAnnex, check the annex object is unmodified -- when annex.thin is set. keypopulated <- ifM (annexThin <$> Annex.getGitConfig)- ( maybe (pure False) (`elemInodeCaches` ics) objic- , pure (isJust objic)+ ( case mobjic of+ Just objic -> isUnmodifiedLowLevel addinodecaches key obj objic ics+ Nothing -> pure False+ , pure (isJust mobjic) ) p <- fromRepo $ fromTopFilePath file filepopulated <- sameInodeCache p ics@@ -392,10 +400,8 @@ (True, False) -> populatePointerFile (Restage True) key obj p >>= \case Nothing -> return ()- Just ic -> liftIO $- SQL.addInodeCaches key- (catMaybes [Just ic, objic])- (SQL.WriteHandle qh)+ Just ic -> addinodecaches key+ (catMaybes [Just ic, mobjic]) (False, True) -> depopulatePointerFile key p _ -> return ()
Database/Keys/Handle.hs view
@@ -8,7 +8,6 @@ module Database.Keys.Handle ( DbHandle, newDbHandle,- unavailableDbHandle, DbState(..), withDbState, flushDbQueue,@@ -33,9 +32,6 @@ newDbHandle :: IO DbHandle newDbHandle = DbHandle <$> newMVar DbClosed--unavailableDbHandle :: IO DbHandle-unavailableDbHandle = DbHandle <$> newMVar DbUnavailable -- Runs an action on the state of the handle, which can change its state. -- The MVar is empty while the action runs, which blocks other users
Git/Branch.hs view
@@ -121,6 +121,13 @@ (False, True) -> findbest c rs -- worse (False, False) -> findbest c rs -- same +{- Should the commit avoid the usual summary output? -}+newtype CommitQuiet = CommitQuiet Bool++applyCommitQuiet :: CommitQuiet -> [CommandParam] -> [CommandParam]+applyCommitQuiet (CommitQuiet True) ps = Param "--quiet" : ps+applyCommitQuiet (CommitQuiet False) ps = ps+ {- The user may have set commit.gpgsign, intending all their manual - commits to be signed. But signing automatic/background commits could - easily lead to unwanted gpg prompts or failures.@@ -148,12 +155,14 @@ ps' = applyCommitMode commitmode ps {- Commit via the usual git command. -}-commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool+commitCommand :: CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO Bool commitCommand = commitCommand' runBool -commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a-commitCommand' runner commitmode ps = runner $- Param "commit" : applyCommitMode commitmode ps+commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO a+commitCommand' runner commitmode commitquiet ps =+ runner $ Param "commit" : ps'+ where+ ps' = applyCommitMode commitmode (applyCommitQuiet commitquiet ps) {- Commits the index into the specified branch (or other ref), - with the specified parent refs, and returns the committed sha.@@ -162,7 +171,7 @@ - one parent, and it has the same tree that would be committed. - - Unlike git-commit, does not run any hooks, or examine the work tree- - in any way.+ - in any way, or output a summary. -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do
Git/DiffTree.hs view
@@ -15,6 +15,7 @@ diffFiles, diffLog, commitDiff,+ parseDiffRaw, ) where import qualified Data.ByteString as B@@ -116,9 +117,13 @@ go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL' s ++ "\"" -- :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>+--+-- May be prefixed with a newline, which git log --pretty=format+-- adds to the first line of the diff, even with -z. parserDiffRaw :: RawFilePath -> A.Parser DiffTreeItem parserDiffRaw f = DiffTreeItem- <$ A8.char ':'+ <$ A.option '\n' (A8.char '\n')+ <* A8.char ':' <*> octal <* A8.char ' ' <*> octal
Git/Merge.hs view
@@ -1,6 +1,6 @@ {- git merging -- - Copyright 2012-2016 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -22,9 +22,12 @@ data MergeConfig = MergeNonInteractive- -- ^ avoids interactive merge+ -- ^ avoids interactive merge with commit message edit | MergeUnrelatedHistories -- ^ avoids git's prevention of merging unrelated histories+ | MergeQuiet+ -- ^ avoids usual output when merging, but errors will still be+ -- displayed deriving (Eq) merge :: Ref -> [MergeConfig] -> CommitMode -> Repo -> IO Bool@@ -36,11 +39,14 @@ go [Param $ fromRef branch] | otherwise = go [Param "--no-edit", Param $ fromRef branch] where- go ps = merge'' (sp ++ [Param "merge"] ++ ps ++ extraparams) mergeconfig r+ go ps = merge'' (sp ++ [Param "merge"] ++ qp ++ ps ++ extraparams) mergeconfig r sp | commitmode == AutomaticCommit = [Param "-c", Param "commit.gpgsign=false"] | otherwise = []+ qp+ | MergeQuiet `notElem` mergeconfig = []+ | otherwise = [Param "--quiet"] merge'' :: [CommandParam] -> [MergeConfig] -> Repo -> IO Bool merge'' ps mergeconfig r
Messages.hs view
@@ -43,9 +43,11 @@ setupConsole, enableDebugOutput, commandProgressDisabled,+ commandProgressDisabled', jsonOutputEnabled, outputMessage, withMessageState,+ MessageState, prompt, mkPrompter, ) where@@ -276,12 +278,14 @@ {- Should commands that normally output progress messages have that - output disabled? -} commandProgressDisabled :: Annex Bool-commandProgressDisabled = withMessageState $ \s -> return $- case outputType s of- NormalOutput -> concurrentOutputEnabled s- QuietOutput -> True- JSONOutput _ -> True- SerializedOutput _ _ -> True+commandProgressDisabled = withMessageState $ return . commandProgressDisabled'++commandProgressDisabled' :: MessageState -> Bool+commandProgressDisabled' s = case outputType s of+ NormalOutput -> concurrentOutputEnabled s+ QuietOutput -> True+ JSONOutput _ -> True+ SerializedOutput _ _ -> True jsonOutputEnabled :: Annex Bool jsonOutputEnabled = withMessageState $ \s -> return $
P2P/Annex.hs view
@@ -23,8 +23,7 @@ import Logs.Location import Types.NumCopies import Utility.Metered-import Types.Backend (IncrementalVerifier(..))-import Backend+import Annex.Verify import Control.Monad.Free import Control.Concurrent.STM
Remote/Borg.hs view
@@ -39,7 +39,7 @@ import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P -type BorgRepo = String+newtype BorgRepo = BorgRepo { locBorgRepo :: String } type BorgArchiveName = S.ByteString @@ -109,9 +109,7 @@ , config = c , getRepo = return r , gitconfig = gc- , localpath = if borgLocal borgrepo && not (null borgrepo)- then Just borgrepo- else Nothing+ , localpath = borgRepoLocalPath borgrepo , remotetype = remote , availability = if borgLocal borgrepo then LocallyAvailable else GloballyAvailable , readonly = False@@ -122,13 +120,16 @@ , untrustworthy = maybe True not $ getRemoteConfigValue appendonlyField c , mkUnavailable = return Nothing- , getInfo = return [("repo", borgrepo)]+ , getInfo = return [("repo", locBorgRepo borgrepo)] , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs } where- borgrepo = fromMaybe (giveup "missing borgrepo") $ remoteAnnexBorgRepo gc+ borgrepo = maybe+ (giveup "missing borgrepo")+ BorgRepo+ (remoteAnnexBorgRepo gc) borgSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) borgSetup _ mu _ c _gc = do@@ -145,15 +146,26 @@ return (c, u) borgLocal :: BorgRepo -> Bool-borgLocal = notElem ':'+borgLocal (BorgRepo r) = notElem ':' r borgArchive :: BorgRepo -> BorgArchiveName -> String-borgArchive r n = r ++ "::" ++ decodeBS' n+borgArchive (BorgRepo r) n = r ++ "::" ++ decodeBS' n +absBorgRepo :: BorgRepo -> IO BorgRepo+absBorgRepo r@(BorgRepo p)+ | borgLocal r = BorgRepo . fromRawFilePath+ <$> absPath (toRawFilePath p)+ | otherwise = return r++borgRepoLocalPath :: BorgRepo -> Maybe FilePath+borgRepoLocalPath r@(BorgRepo p)+ | borgLocal r && not (null p) = Just p+ | otherwise = Nothing+ listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) listImportableContentsM u borgrepo c = prompt $ do imported <- getImported u- ls <- withborglist borgrepo Nothing formatarchivelist $ \as ->+ 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)@@ -329,14 +341,14 @@ [ Param "list" , Param "--format" , Param "1"- , Param borgrepo+ , Param (locBorgRepo borgrepo) ] (Nothing, Nothing, Nothing, pid) <- withNullHandle $ \nullh -> createProcess $ p { std_out = UseHandle nullh } ifM (checkSuccessProcess pid) ( return False -- repo exists, content not in it- , giveup $ "Unable to access borg repository " ++ borgrepo+ , giveup $ "Unable to access borg repository " ++ locBorgRepo borgrepo ) retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key@@ -345,7 +357,7 @@ prompt $ withOtherTmp $ \othertmp -> liftIO $ do -- borgrepo could be relative, and borg has to be run -- in the temp directory to get it to write there- absborgrepo <- fromRawFilePath <$> absPath (toRawFilePath borgrepo)+ absborgrepo <- absBorgRepo borgrepo let p = proc "borg" $ toCommand [ Param "extract" , Param (borgArchive absborgrepo archivename)
Remote/Git.hs view
@@ -269,7 +269,7 @@ set_ignore "uses a protocol not supported by git-annex" False return r | otherwise = storeUpdatedRemote $- liftIO readlocalannexconfig+ readlocalannexconfig `catchNonAsync` const failedreadlocalconfig where haveconfig = not . M.null . Git.config@@ -355,8 +355,8 @@ warning $ "remote " ++ Git.repoDescribe r ++ ":" ++ show e Annex.getState Annex.repo- s <- Annex.new r- Annex.eval s $ check `finally` stopCoProcesses+ s <- newLocal r+ liftIO $ Annex.eval s $ check `finally` stopCoProcesses failedreadlocalconfig = do unless hasuuid $ case Git.remoteName r of@@ -429,8 +429,8 @@ -- If the remote is known to not be bare, try the hash locations -- used for non-bare repos first, as an optimisation. locs- | remoteAnnexBare remoteconfig == Just False = reverse (annexLocations gc key)- | otherwise = annexLocations gc key+ | remoteAnnexBare remoteconfig == Just False = annexLocationsNonBare gc key+ | otherwise = annexLocationsBare gc key #ifndef mingw32_HOST_OS locs' = map fromRawFilePath locs #else@@ -773,10 +773,20 @@ lra <- mkLocalRemoteAnnex repo onLocal' lra a +newLocal :: Git.Repo -> Annex (Annex.AnnexState, Annex.AnnexRead)+newLocal repo = do+ (st, rd) <- liftIO $ Annex.new repo+ debugenabled <- Annex.getRead Annex.debugenabled+ debugselector <- Annex.getRead Annex.debugselector+ return (st, rd+ { Annex.debugenabled = debugenabled+ , Annex.debugselector = debugselector+ })+ onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a onLocal' (LocalRemoteAnnex repo mv) a = liftIO (takeMVar mv) >>= \case Nothing -> do- v <- liftIO $ Annex.new repo+ v <- newLocal repo go (v, ensureInitialized >> a) Just v -> go (v, a) where
Remote/Helper/ExportImport.hs view
@@ -13,7 +13,7 @@ import Types.Remote import Types.Key import Types.ProposedAccepted-import Backend+import Annex.Verify import Remote.Helper.Encryptable (encryptionIsEnabled) import qualified Database.Export as Export import qualified Database.ContentIdentifier as ContentIdentifier
Remote/Helper/P2P.hs view
@@ -17,7 +17,7 @@ import Messages.Progress import Utility.Metered import Types.NumCopies-import Backend+import Annex.Verify import Control.Concurrent
Test.hs view
@@ -1983,7 +1983,7 @@ testimport = do origbranch <- annexeval origBranch git_annex "import" [origbranch++":"++subdir, "--from", "foo"] "import of subdir"- git_annex "merge" ["foo/master"] "git annex merge foo/master"+ git_annex "merge" ["foo/master", "--allow-unrelated-histories"] "git annex merge foo/master" -- Make sure that import did not import the file to the top -- of the repo.
Test/Framework.hs view
@@ -488,6 +488,7 @@ , ("GIT_ANNEX_USE_GIT_SSH", "1") , ("TESTMODE", show testmode) ]+ runFakeSsh :: [String] -> IO () runFakeSsh ("-n":ps) = runFakeSsh ps runFakeSsh (_host:cmd:[]) =
Upgrade/V5.hs view
@@ -47,7 +47,7 @@ , do checkGitVersionForIndirectUpgrade )- scanAnnexedFiles True+ scanAnnexedFiles configureSmudgeFilter -- Inode sentinal file was only used in direct mode and when -- locking down files as they were added. In v6, it's used more
Utility/HumanNumber.hs view
@@ -1,6 +1,6 @@ {- numbers for humans -- - Copyright 2012-2013 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -11,11 +11,15 @@ - of decimal digits. -} showImprecise :: RealFrac a => Int -> a -> String showImprecise precision n- | precision == 0 || remainder == 0 = show (round n :: Integer)- | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder)+ | precision == 0 || remainder' == 0 = show (round n :: Integer)+ | otherwise = show int' ++ "." ++ striptrailing0s (pad0s $ show remainder') where int :: Integer (int, frac) = properFraction n remainder = round (frac * 10 ^ precision) :: Integer+ (int', remainder')+ -- carry the 1+ | remainder == 10 ^ precision = (int + 1, 0)+ | otherwise = (int, remainder) pad0s s = replicate (precision - length s) '0' ++ s striptrailing0s = reverse . dropWhile (== '0') . reverse
Utility/Process/Transcript.hs view
@@ -86,7 +86,7 @@ where asyncreader pid h = async $ reader pid h [] reader pid h c = hGetLineUntilExitOrEOF pid h >>= \case- Nothing -> return (concat (reverse c))+ Nothing -> return (unlines (reverse c)) Just l -> reader pid h (l:c) writeinput (Just s) p = do let inh = stdinHandle p
+ doc/git-annex-filter-branch.mdwn view
@@ -0,0 +1,151 @@+# NAME++git-annex filter-branch - filter information from the git-annex branch++# SYNOPSIS++git annex filter-branch [...]++# DESCRIPTION++This copies selected information from the git-annex branch into a git+commit object, and outputs its hash. The git commit can be transported+to another git repository, and given a branch name such as "foo/git-annex",+and git-annex there will automatically merge that into its git-annex+branch. This allows publishing some information from your git-annex branch,+without publishing the whole thing.++Other ways to avoid publishing information from a git-annex branch,+or remove information from it include [[git-annex-forget]](1), the +`annex.private` git config, and the `--private` option to+[[git-annex-initremote](1). Those are much easier to use, but this+provides full control for those who need it.++With no options, no information at all will be included from the git-annex+branch. Use options to specify what to include. All options can be specified+multiple times.++When the repository contains information about a private+repository (due to `annex.private` being set, or `git-annex initremote+--private` being used), that private information will be included when+allowed by the options, even though it is not recorded on the git-annex+branch.++When a repository was created with `git annex initremote --sameas=foo`,+its information will be included when the information for foo is,+and excluded when foo is excluded.++When a special remote is configured with importtree=yes or exporttree=yes,+normally the git tree corresponding to the repository is included in+the git-annex branch, to make sure it does not get garbage collected+by `git gc`. Those trees are *not* included when filtering the git-annex+branch. Usually this will not cause any problems, but if such a tree does+get garbage collected, it will prevent accessing files on the special+remote, until the next time a tree is imported or exported to it.++# OPTIONS++* `path`++ Include information about all keys of annexed files in the path.++* file matching options++ The [[git-annex-matching-options]](1)+ can be used to specify which files in a path to include.++* `--branch=ref`++ Include information about keys referred of annexed files in the branch+ or treeish.++* `--key=key`++ Include information about a specific key.++* `--all`++ Include information about all keys.++* `--include-key-information-for=repo`++ When including information about a key, include information specific to+ this repository. The repository can be specified with a uuid or the name+ of a remote. This option can be used repeatedly to include several+ repositories.++* `--include-all-key-information`++ Include key information for all repositories, except any excluded with+ the `--exclude-key-information-for` option.++* `--exclude-key-information-for=repo`++ When including information about a key, exclude information specific to+ this repository. The repository can be specified with a uuid or the name+ of a remote. This option can be used repeatedly to exclude+ several repositories.++* `--include-repo-config-for=repo`++ Include configuration specific to this repository. + The repository can be specified with a uuid or the name of a remote.++ This includes the configuration of special remotes, which may include+ embedded credentials, or encryption parameters. It also includes trust+ settings, preferred content, etc. It does not include information+ about any git-annex keys. This option can be used repeatedly to include+ several repositories.++* `--include-all-repo-config`++ Include the configuration of all repositories, except for any excluded+ with the `--exclude-repo-config-for` option.++* `--exclude-repo-config-for=repo`++ Exclude configuration specific to this repository. + The repository can be specified with a uuid or the name of a remote.+ This option can be used repeatedly to exclude several repositories.++* `--include-global-config`++ Include global configuration, that is not specific to any repository.++ This includes configs stored by [[git-annex-numcopies]](1),+ [[git-annex-config]](1), etc.++# EXAMPLES++You have a big git-annex repository and are splitting the directory "foo"+out, to make a smaller repository. You want the smaller repo's git-annex+branch to contain all the information about remotes and other configuration,+but only information about keys in that directory.++ git-annex filter-branch foo --include-all-key-information \+ --include-all-repo-config --include-global-config++That only includes information about the keys that are currently+in the directory "foo", not keys used by old versions of files.+To also include information about the version of the subdir in+tag "1.0", add the option `--branch=1.0:foo`++Your repository has a special remote "bar", and you want to share information+about which annexed files are stored in it, but without sharing anything+about the configuration of the remote.++ git-annex filter-branch --all --include-all-key-information \+ --include-all-repo-config --exclude-repo-config-for=bar \+ --include-global-config++# SEE ALSO++[[git-annex]](1)++[[git-annex-forget]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex-import.mdwn view
@@ -42,19 +42,17 @@ For example: git annex import master --from myremote- git annex merge myremote/master+ git annex merge --allow-unrelated-histories myremote/master -You could just as well use `git merge myremote/master` as the second step,-but using `git-annex merge` avoids a couple of gotchas. When using adjusted-branches, it adjusts the branch before merging from it. And it avoids-the merge failing on the first merge from an import due to unrelated-histories.+You could just as well use `git merge --allow-unrelated-histories myremote/master`+as the second step, but using `git-annex merge` avoids a couple of gotchas.+When using adjusted branches, it adjusts the branch before merging from it. -If you do use `git merge`, you can pass `--allow-unrelated-histories` the-first time you `git merge` from an import. Think of this as the remote-being a separate git repository with its own files. If you first-`git annex export` files to a remote, and then `git annex import` from it,-you won't need that option.+The --allow-unrelated-histories option is needed for at least the first+merge of an imported remote tracking branch, since the branch's history is+not connected. Think of this as the remote being a separate git repository+with its own files. If you first `git annex export` files to a remote, and+then `git annex import` from it, you won't need that option. You can import into a subdirectory, using the "branch:subdir" syntax. For example, if "camera" is a special remote that accesses a camera, and you
doc/git-annex-merge.mdwn view
@@ -22,7 +22,12 @@ # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--allow-unrelated-histories`, `--no-allow-unrelated-histories`++ Passed on to `git merge`, to control whether or not to merge+ histories that do not share a common ancestor.++* Also, the [[git-annex-common-options]](1) can be used. # SEE ALSO
doc/git-annex-sync.mdwn view
@@ -150,6 +150,11 @@ less efficient. When --content is synced, the files are processed in parallel as well. +* `--allow-unrelated-histories`, `--no-allow-unrelated-histories`++ Passed on to `git merge`, to control whether or not to merge+ histories that do not share a common ancestor.+ * `--resolvemerge`, `--no-resolvemerge` By default, merge conflicts are automatically handled by sync. When two
doc/git-annex-unused.mdwn view
@@ -83,6 +83,8 @@ [[git-annex-addunused]](1) +[[git-annex-whereused]](1)+ # AUTHOR Joey Hess <id@joeyh.name>
+ doc/git-annex-whereused.mdwn view
@@ -0,0 +1,53 @@+# NAME++git-annex whereused - find what files use or used a key++# SYNOPSIS++git annex whereused `--key=keyname|--unused`++# DESCRIPTION++Finds what files use or used a key.++For each file in the working tree that uses a key, this outputs one line,+starting with the key, then a space, and then the name of the file.+When multiple files use the same key, they will all be listed. When+nothing is found that uses the key, there will be no output.++The default is to find only files in the current working tree that use a+key. The `--historical` option makes it also find past versions of files.++# OPTIONS++* `--key=keyname`++ Operate on this key.++* `--unused`++ Operate on keys found by last run of git-annex unused.++ Usually these keys won't be used by any files in the current working+ tree, or any tags or branches. Combining this option with `--historical`+ will find past uses of the keys.++* `--historical`++ When no files in the current working tree use a key, this causes more+ work to be done, looking at past versions of the current branch, other+ branches, tags, and the reflog, to find somewhere that the key was used.+ It stops after finding one use of the key, and outputs a git rev that+ refers to where it was used, eg "HEAD@{40}:somefile"++# SEE ALSO++[[git-annex]](1)++[[git-annex-unused]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex.mdwn view
@@ -447,6 +447,10 @@ See [[git-annex-list]](1) for details. +* `whereused`++ Finds what files use or used a key.+ * `log [path ...]` Displays the location log for the specified file or files,
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20210714+Version: 8.20210803 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -64,6 +64,7 @@ doc/git-annex-examinekey.mdwn doc/git-annex-expire.mdwn doc/git-annex-export.mdwn+ doc/git-annex-filter-branch.mdwn doc/git-annex-find.mdwn doc/git-annex-findref.mdwn doc/git-annex-fix.mdwn@@ -143,6 +144,7 @@ doc/git-annex-watch.mdwn doc/git-annex-webapp.mdwn doc/git-annex-whereis.mdwn+ doc/git-annex-whereused.mdwn doc/git-remote-tor-annex.mdwn doc/logo.svg doc/logo_16x16.png@@ -628,6 +630,7 @@ Annex.Concurrent.Utility Annex.Content Annex.Content.Presence+ Annex.Content.Presence.LowLevel Annex.Content.LowLevel Annex.Content.PointerFile Annex.CopyFile@@ -829,6 +832,7 @@ Command.View Command.Wanted Command.Whereis+ Command.WhereUsed Common Config Config.Cost