diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -1,6 +1,6 @@ {- adjusted branch - - - Copyright 2016-2023 Joey Hess + - Copyright 2016-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -68,9 +68,12 @@ import Config import Logs.View (is_branchView) import Logs.AdjustedBranchUpdate +import Utility.FileMode +import qualified Utility.RawFilePath as R import Data.Time.Clock.POSIX import qualified Data.Map as M +import System.PosixCompat.Files (fileMode) class AdjustTreeItem t where -- How to perform various adjustments to a TreeItem. @@ -155,8 +158,13 @@ adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case Just k -> do Database.Keys.addAssociatedFile k f - Just . TreeItem f (fromTreeItemType TreeFile) - <$> hashPointerFile k + exe <- catchDefaultIO False $ + (isExecutable . fileMode) <$> + (liftIO . R.getFileStatus + =<< calcRepo (gitAnnexLocation k)) + let mode = fromTreeItemType $ + if exe then TreeExecutable else TreeFile + Just . TreeItem f mode <$> hashPointerFile k Nothing -> return (Just ti) adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem) @@ -173,7 +181,7 @@ -- This is a hidden branch ref, that's used as the basis for the AdjBranch, -- since pushes can overwrite the OrigBranch at any time. So, changes --- are propigated from the AdjBranch to the head of the BasisBranch. +-- are propagated from the AdjBranch to the head of the BasisBranch. newtype BasisBranch = BasisBranch Ref -- The basis for refs/heads/adjusted/master(unlocked) is @@ -256,7 +264,7 @@ | not (adjustmentIsStable adj) = do (b, origheadfile, newheadfile) <- preventCommits $ \commitlck -> do -- Avoid losing any commits that the adjusted branch - -- has that have not yet been propigated back to the + -- has that have not yet been propagated back to the -- origbranch. _ <- propigateAdjustedCommits' True origbranch adj commitlck @@ -472,7 +480,7 @@ -- since that message is looked for later. -- After git-annex 10.20240227, it's possible to use -- commitTree instead of this, but this is being kept - -- for some time, for compatability with older versions. + -- for some time, for compatibility with older versions. mkcommit cmode = Git.Branch.commitTreeExactMessage cmode adjustedBranchCommitMessage parents treesha @@ -497,10 +505,10 @@ _ -> return Nothing {- Check for any commits present on the adjusted branch that have not yet - - been propigated to the basis branch, and propagate them to the basis + - been propagated to the basis branch, and propagate them to the basis - branch and from there on to the orig branch. - - - After propigating the commits back to the basis branch, + - After propagating the commits back to the basis branch, - rebase the adjusted branch on top of the updated basis branch. -} propigateAdjustedCommits :: OrigBranch -> Adjustment -> Annex () @@ -642,7 +650,7 @@ - checked out adjusted branch; the origin could have the two branches - out of sync (eg, due to another branch having been pushed to the origin's - origbranch), or due to a commit on its adjusted branch not having been - - propigated back to origbranch. + - propagated back to origbranch. - - So, find the adjusting commit on the currently checked out adjusted - branch, and use the parent of that commit as the basis, and set the diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -727,7 +727,8 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do prepareModifyIndex jl g <- gitRepo - let dir = gitAnnexJournalDir g + st <- getState + let dir = gitAnnexJournalDir st g (jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir) withHashObjectHandle $ \h -> withJournalHandle gitAnnexJournalDir $ \jh -> diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -1,6 +1,6 @@ {- git-annex repository initialization - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,6 +12,7 @@ checkInitializeAllowed, ensureInitialized, autoInitialize, + autoInitialize', isInitialized, initialize, initialize', @@ -256,14 +257,17 @@ - Checks repository version and handles upgrades too. -} autoInitialize :: Annex [Remote] -> Annex () -autoInitialize remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade +autoInitialize = autoInitialize' autoInitializeAllowed + +autoInitialize' :: Annex Bool -> Annex [Remote] -> Annex () +autoInitialize' check remotelist = getInitializedVersion >>= maybe needsinit checkUpgrade where needsinit = - whenM (initializeAllowed <&&> autoInitializeAllowed) $ do + whenM (initializeAllowed <&&> check) $ do initialize Nothing Nothing autoEnableSpecialRemotes remotelist -{- Checks if a repository is initialized. Does not check version for ugrade. -} +{- Checks if a repository is initialized. Does not check version for upgrade. -} isInitialized :: Annex Bool isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion diff --git a/Annex/Journal.hs b/Annex/Journal.hs --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -7,7 +7,7 @@ - All files in the journal must be a series of lines separated by - newlines. - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,6 +23,8 @@ import Annex.Perms import Annex.Tmp import Annex.LockFile +import Annex.BranchState +import Types.BranchState import Utility.Directory.Stream import qualified Utility.RawFilePath as R @@ -82,9 +84,10 @@ -} setJournalFile :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex () setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do + st <- getState jd <- fromRepo =<< ifM (regardingPrivateUUID ru) - ( return gitAnnexPrivateJournalDir - , return gitAnnexJournalDir + ( return (gitAnnexPrivateJournalDir st) + , return (gitAnnexJournalDir st) ) -- journal file is written atomically let jfile = journalFile file @@ -106,9 +109,10 @@ - branch. -} checkCanAppendJournalFile :: JournalLocked -> RegardingUUID -> RawFilePath -> Annex (Maybe AppendableJournalFile) checkCanAppendJournalFile _jl ru file = do + st <- getState jd <- fromRepo =<< ifM (regardingPrivateUUID ru) - ( return gitAnnexPrivateJournalDir - , return gitAnnexJournalDir + ( return (gitAnnexPrivateJournalDir st) + , return (gitAnnexJournalDir st) ) let jfile = jd P. journalFile file ifM (liftIO $ R.doesPathExist jfile) @@ -176,14 +180,12 @@ -} getJournalFileStale :: GetPrivate -> RawFilePath -> Annex JournalledContent getJournalFileStale (GetPrivate getprivate) file = do - -- Optimisation to avoid a second MVar access. st <- Annex.getState id - let g = Annex.repo st liftIO $ if getprivate && privateUUIDsKnown' st then do - x <- getfrom (gitAnnexJournalDir g) - getfrom (gitAnnexPrivateJournalDir g) >>= \case + x <- getfrom (gitAnnexJournalDir (Annex.branchstate st) (Annex.repo st)) + getfrom (gitAnnexPrivateJournalDir (Annex.branchstate st) (Annex.repo st)) >>= \case Nothing -> return $ case x of Nothing -> NoJournalledContent Just b -> JournalledContent b @@ -193,7 +195,7 @@ -- happens in a merge of two -- git-annex branches. Just x' -> x' <> y - else getfrom (gitAnnexJournalDir g) >>= return . \case + else getfrom (gitAnnexJournalDir (Annex.branchstate st) (Annex.repo st)) >>= return . \case Nothing -> NoJournalledContent Just b -> JournalledContent b where @@ -219,18 +221,20 @@ {- List of existing journal files in a journal directory, but without locking, - may miss new ones just being added, or may have false positives if the - journal is staged as it is run. -} -getJournalledFilesStale :: (Git.Repo -> RawFilePath) -> Annex [RawFilePath] +getJournalledFilesStale :: (BranchState -> Git.Repo -> RawFilePath) -> Annex [RawFilePath] getJournalledFilesStale getjournaldir = do - g <- gitRepo - fs <- liftIO $ catchDefaultIO [] $ - getDirectoryContents $ fromRawFilePath (getjournaldir g) + st <- Annex.getState id + let d = getjournaldir (Annex.branchstate st) (Annex.repo st) + fs <- liftIO $ catchDefaultIO [] $ + getDirectoryContents (fromRawFilePath d) return $ filter (`notElem` [".", ".."]) $ map (fileJournal . toRawFilePath) fs {- Directory handle open on a journal directory. -} -withJournalHandle :: (Git.Repo -> RawFilePath) -> (DirectoryHandle -> IO a) -> Annex a +withJournalHandle :: (BranchState -> Git.Repo -> RawFilePath) -> (DirectoryHandle -> IO a) -> Annex a withJournalHandle getjournaldir a = do - d <- fromRepo getjournaldir + st <- Annex.getState id + let d = getjournaldir (Annex.branchstate st) (Annex.repo st) bracket (opendir d) (liftIO . closeDirectory) (liftIO . a) where -- avoid overhead of creating the journal directory when it already @@ -239,9 +243,10 @@ `catchIO` (const (createAnnexDirectory d >> opendir d)) {- Checks if there are changes in the journal. -} -journalDirty :: (Git.Repo -> RawFilePath) -> Annex Bool +journalDirty :: (BranchState -> Git.Repo -> RawFilePath) -> Annex Bool journalDirty getjournaldir = do - d <- fromRawFilePath <$> fromRepo getjournaldir + st <- getState + d <- fromRawFilePath <$> fromRepo (getjournaldir st) liftIO $ (not <$> isDirectoryEmpty d) `catchIO` (const $ doesDirectoryExist d) diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -118,6 +118,7 @@ import Types.UUID import Types.GitConfig import Types.Difference +import Types.BranchState import qualified Git import qualified Git.Types as Git import Git.FilePath @@ -131,7 +132,7 @@ - trailing path separator. Most code does not rely on that, but a few - things do. - - - Everything else should not end in a trailing path sepatator. + - Everything else should not end in a trailing path separator. - - Only functions (with names starting with "git") that build a path - based on a git repository should return full path relative to the git @@ -528,15 +529,19 @@ {- .git/annex/journal/ is used to journal changes made to the git-annex - branch -} -gitAnnexJournalDir :: Git.Repo -> RawFilePath -gitAnnexJournalDir r = - P.addTrailingPathSeparator $ gitAnnexDir r P. "journal" +gitAnnexJournalDir :: BranchState -> Git.Repo -> RawFilePath +gitAnnexJournalDir st r = P.addTrailingPathSeparator $ + case alternateJournal st of + Nothing -> gitAnnexDir r P. "journal" + Just d -> d {- .git/annex/journal.private/ is used to journal changes regarding private - repositories. -} -gitAnnexPrivateJournalDir :: Git.Repo -> RawFilePath -gitAnnexPrivateJournalDir r = - P.addTrailingPathSeparator $ gitAnnexDir r P. "journal-private" +gitAnnexPrivateJournalDir :: BranchState -> Git.Repo -> RawFilePath +gitAnnexPrivateJournalDir st r = P.addTrailingPathSeparator $ + case alternateJournal st of + Nothing -> gitAnnexDir r P. "journal-private" + Just d -> d {- Lock file for the journal. -} gitAnnexJournalLock :: Git.Repo -> RawFilePath diff --git a/Annex/RemoteTrackingBranch.hs b/Annex/RemoteTrackingBranch.hs --- a/Annex/RemoteTrackingBranch.hs +++ b/Annex/RemoteTrackingBranch.hs @@ -46,7 +46,7 @@ - - The second parent of the merge commit is the past history of the - RemoteTrackingBranch as imported from a remote. When importing a - - history of trees from a remote, commits can be sythesized from + - history of trees from a remote, commits can be synthesized from - them, but such commits won't have the same sha due to eg date differing. - But since we know that the second parent consists entirely of such - import commits, they can be reused when updating the diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -1,6 +1,6 @@ {- git-annex special remote configuration - - - Copyright 2019-2023 Joey Hess + - Copyright 2019-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -107,17 +107,23 @@ (FieldDesc "name for the special remote") , optionalStringParser sameasNameField HiddenField , optionalStringParser sameasUUIDField HiddenField - , optionalStringParser typeField - (FieldDesc "type of special remote") , autoEnableFieldParser , costParser costField (FieldDesc "default cost of this special remote") + , optionalStringParser preferreddirField + (FieldDesc "directory whose content is preferred") + ] ++ essentialFieldParsers + +{- Parsers for fields that are common to all special remotes, and are + - also essential to include in eg, annex:: urls. -} +essentialFieldParsers :: [RemoteConfigFieldParser] +essentialFieldParsers = + [ optionalStringParser typeField + (FieldDesc "type of special remote") , yesNoParser exportTreeField (Just False) (FieldDesc "export trees of files to this remote") , yesNoParser importTreeField (Just False) (FieldDesc "import trees of files from this remote") - , optionalStringParser preferreddirField - (FieldDesc "directory whose content is preferred") ] autoEnableFieldParser :: RemoteConfigFieldParser diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -407,7 +407,7 @@ {- Enables ssh caching for git push/pull to a particular - remote git repo. (Can safely be used on non-ssh remotes.) - - - Also propigates any configured ssh-options. + - Also propagates any configured ssh-options. - - Like inRepo, the action is run with the local git repo. - But here it's a modified version, with gitEnv to set GIT_SSH=git-annex, diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -372,7 +372,7 @@ <$> B.readFile tmpfile return $ case partitionEithers v of ((parserr:_), _) -> - Left $ "yt-dlp json parse errror: " ++ parserr + Left $ "yt-dlp json parse error: " ++ parserr ([], r) -> Right r else return $ Left $ if null outerr then "yt-dlp failed" diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -64,7 +64,7 @@ return $ \dstatus -> dstatus { syncRemotes = syncable - , syncGitRemotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) syncable + , syncGitRemotes = filter Remote.gitSyncableRemote syncable , syncDataRemotes = dataremotes , exportRemotes = exportremotes , downloadRemotes = contentremotes diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -1,4 +1,4 @@ -{- git-annex assistant sceduled jobs runner +{- git-annex assistant scheduled jobs runner - - Copyright 2013 Joey Hess - diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -102,7 +102,7 @@ networkd = "org.freedesktop.network1" wicd = "org.wicd.daemon" -{- Listens for systemd-networkd connections and diconnections. +{- Listens for systemd-networkd connections and disconnections. - - Connection example (once fully connected): - [Variant {"OperationalState": Variant "routable"}] @@ -128,7 +128,7 @@ else setconnected False Nothing -> noop -{- Listens for NetworkManager connections and diconnections. +{- Listens for NetworkManager connections and disconnections. - - Connection example (once fully connected): - [Variant {"ActivatingConnection": Variant (ObjectPath "/"), "PrimaryConnection": Variant (ObjectPath "/org/freedesktop/NetworkManager/ActiveConnection/34"), "State": Variant 70}] diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -77,7 +77,7 @@ - - Creates the destination directory where the upgrade will be installed - early, in order to check if another upgrade has happened (or is - - happending). On failure, the directory is removed. + - happening). On failure, the directory is removed. -} startDistributionDownload :: GitAnnexDistribution -> Assistant () startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation diff --git a/Backend/GitRemoteAnnex.hs b/Backend/GitRemoteAnnex.hs new file mode 100644 --- /dev/null +++ b/Backend/GitRemoteAnnex.hs @@ -0,0 +1,120 @@ +{- Backends for git-remote-annex. + - + - GITBUNDLE keys store git bundles + - GITMANIFEST keys store ordered lists of GITBUNDLE keys + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Backend.GitRemoteAnnex ( + backends, + genGitBundleKey, + genManifestKey, + genBackupManifestKey, + isGitRemoteAnnexKey, +) where + +import Annex.Common +import Types.Key +import Types.Backend +import Utility.Hash +import Utility.Metered +import qualified Backend.Hash as Hash + +import qualified Data.ByteString.Short as S +import qualified Data.ByteString.Char8 as B8 + +backends :: [Backend] +backends = [gitbundle, gitmanifest] + +gitbundle :: Backend +gitbundle = Backend + { backendVariety = GitBundleKey + , genKey = Nothing + -- ^ Not provided because these keys can only be generated by + -- git-remote-annex. + , verifyKeyContent = Just $ Hash.checkKeyChecksum sameCheckSum hash + , verifyKeyContentIncrementally = Just (liftIO . incrementalVerifier) + , canUpgradeKey = Nothing + , fastMigrate = Nothing + , isStableKey = const True + , isCryptographicallySecure = Hash.cryptographicallySecure hash + , isCryptographicallySecureKey = const $ pure $ + Hash.cryptographicallySecure hash + } + +gitmanifest :: Backend +gitmanifest = Backend + { backendVariety = GitManifestKey + , genKey = Nothing + , verifyKeyContent = Nothing + , verifyKeyContentIncrementally = Nothing + , canUpgradeKey = Nothing + , fastMigrate = Nothing + , isStableKey = const True + , isCryptographicallySecure = False + , isCryptographicallySecureKey = const $ pure False + } + +-- git bundle keys use the sha256 hash. +hash :: Hash.Hash +hash = Hash.SHA2Hash (HashSize 256) + +incrementalVerifier :: Key -> IO IncrementalVerifier +incrementalVerifier = + mkIncrementalVerifier sha2_256_context "checksum" . sameCheckSum + +sameCheckSum :: Key -> String -> Bool +sameCheckSum key s = s == expected + where + -- The checksum comes after a UUID. + expected = reverse $ takeWhile (/= '-') $ reverse $ + decodeBS $ S.fromShort $ fromKey keyName key + +genGitBundleKey :: UUID -> RawFilePath -> MeterUpdate -> Annex Key +genGitBundleKey remoteuuid file meterupdate = do + filesize <- liftIO $ getFileSize file + s <- Hash.hashFile hash file meterupdate + return $ mkKey $ \k -> k + { keyName = S.toShort $ fromUUID remoteuuid <> "-" <> encodeBS s + , keyVariety = GitBundleKey + , keySize = Just filesize + } + +genManifestKey :: UUID -> Key +genManifestKey = genManifestKey' Nothing + +genBackupManifestKey :: UUID -> Key +genBackupManifestKey = genManifestKey' (Just ".bak") + +genManifestKey' :: Maybe S.ShortByteString -> UUID -> Key +genManifestKey' extension u = mkKey $ \kd -> kd + { keyName = S.toShort (fromUUID u) <> + fromMaybe mempty extension + , keyVariety = GitManifestKey + } + +{- Is the key a manifest or bundle key that belongs to the special remote + - with this uuid? -} +isGitRemoteAnnexKey :: UUID -> Key -> Bool +isGitRemoteAnnexKey u k = + case fromKey keyVariety k of + GitBundleKey -> sameuuid $ \b -> + -- Remove the checksum that comes after the UUID. + let b' = fst $ B8.spanEnd (/= '-') b + in B8.take (B8.length b' - 1) b' + GitManifestKey -> sameuuid $ \b -> + -- Remove an optional extension after the UUID. + -- (A UUID never contains '.') + if '.' `B8.elem` b + then + let b' = fst $ B8.spanEnd (/= '.') b + in B8.take (B8.length b' - 1) b' + else b + _ -> False + where + sameuuid f = fromUUID u == f (S.fromShort (fromKey keyName k)) diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -1,6 +1,6 @@ {- git-annex hashing backends - - - Copyright 2011-2021 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,6 +12,10 @@ testKeyBackend, keyHash, descChecksum, + Hash(..), + cryptographicallySecure, + hashFile, + checkKeyChecksum ) where import Annex.Common @@ -22,7 +26,6 @@ import Types.KeySource import Utility.Hash import Utility.Metered -import qualified Utility.RawFilePath as R import qualified Data.ByteString as S import qualified Data.ByteString.Short as S (toShort, fromShort) @@ -78,7 +81,7 @@ genBackend hash = Backend { backendVariety = hashKeyVariety hash (HasExt False) , genKey = Just (keyValue hash) - , verifyKeyContent = Just $ checkKeyChecksum hash + , verifyKeyContent = Just $ checkKeyChecksum sameCheckSum hash , verifyKeyContentIncrementally = Just $ checkKeyChecksumIncremental hash , canUpgradeKey = Just needsUpgrade , fastMigrate = Just trivialMigrate @@ -123,16 +126,11 @@ keyValue hash source meterupdate >>= addE source (const $ hashKeyVariety hash (HasExt True)) -checkKeyChecksum :: Hash -> Key -> RawFilePath -> Annex Bool -checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do - fast <- Annex.getRead Annex.fast - exists <- liftIO $ R.doesPathExist file - case (exists, fast) of - (True, False) -> do - showAction (UnquotedString descChecksum) - sameCheckSum key - <$> hashFile hash file nullMeterUpdate - _ -> return True +checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> RawFilePath -> Annex Bool +checkKeyChecksum issame hash key file = catchIOErrorType HardwareFault hwfault $ do + showAction (UnquotedString descChecksum) + issame key + <$> hashFile hash file nullMeterUpdate where hwfault e = do warning $ UnquotedString $ "hardware fault: " ++ show e diff --git a/Backend/VURL.hs b/Backend/VURL.hs --- a/Backend/VURL.hs +++ b/Backend/VURL.hs @@ -41,7 +41,7 @@ Nothing -> pure False anyM check eks , verifyKeyContentIncrementally = Just $ \k -> do - -- Run incremental verifiers for each equivilant key together, + -- Run incremental verifiers for each equivalent key together, -- and see if any of them succeed. eks <- equivkeys k let get = \ek -> getbackend ek >>= \case @@ -53,7 +53,7 @@ return $ IncrementalVerifier { updateIncrementalVerifier = \s -> forM_ l $ flip updateIncrementalVerifier s - -- If there are no equivilant keys recorded somehow, + -- If there are no equivalent keys recorded somehow, -- or if none of them support incremental verification, -- this will return Nothing, which indicates that -- incremental verification was not able to be @@ -80,9 +80,9 @@ -- Not all keys using this backend are necessarily -- cryptographically secure. , isCryptographicallySecure = False - -- A key is secure when all recorded equivilant keys are. + -- A key is secure when all recorded equivalent keys are. -- If there are none recorded yet, it's secure because when - -- downloaded, an equivilant key that is cryptographically secure + -- downloaded, an equivalent key that is cryptographically secure -- will be constructed then. , isCryptographicallySecureKey = \k -> equivkeys k >>= \case @@ -95,7 +95,7 @@ } where equivkeys k = filter allowedequiv <$> getEquivilantKeys k - -- Don't allow using VURL keys as equivilant keys, because that + -- Don't allow using VURL keys as equivalent keys, because that -- could let a crafted git-annex branch cause an infinite loop. allowedequiv ek = fromKey keyVariety ek /= VURLKey varietymap = makeVarietyMap regularBackendList diff --git a/Backend/Variety.hs b/Backend/Variety.hs --- a/Backend/Variety.hs +++ b/Backend/Variety.hs @@ -18,12 +18,14 @@ import qualified Backend.Hash import qualified Backend.WORM import qualified Backend.URL +import qualified Backend.GitRemoteAnnex {- Regular backends. Does not include externals or VURL. -} regularBackendList :: [Backend] regularBackendList = Backend.Hash.backends ++ Backend.WORM.backends ++ Backend.URL.backends + ++ Backend.GitRemoteAnnex.backends {- The default hashing backend. -} defaultHashBackend :: Backend diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -1,5 +1,5 @@ {- Generating and installing a desktop menu entry file and icon, - - and a desktop autostart file. (And OSX equivilants.) + - and a desktop autostart file. (And OSX equivalents.) - - Copyright 2012 Joey Hess - diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,23 @@ +git-annex (10.20240531) upstream; urgency=medium + + * git-remote-annex: New program which allows pushing a git repo to a + git-annex special remote, and cloning from a special remote. + (Based on Michael Hanke's git-remote-datalad-annex.) + * initremote, enableremote: Added --with-url to enable using + git-remote-annex. + * When building an adjusted unlocked branch, make pointer files + executable when the annex object file is executable. + * group: Added --list option. + * fsck: Fix recent reversion that made it say it was checksumming files + whose content is not present. + * Avoid the --fast option preventing checksumming in some cases it + was not supposed to. + * testremote: Really fsck downloaded objects. + * Typo fixes. + Thanks, Yaroslav Halchenko + + -- Joey Hess Fri, 31 May 2024 12:32:29 -0400 + git-annex (10.20240430) upstream; urgency=medium * Bug fix: While redundant concurrent transfers were already @@ -4576,7 +4596,7 @@ --clean-duplicates mode, verify that enough copies of its content still exist. * Improve integration with KDE's file manager to work with dolphin - version 14.12.3 while still being compatable with 4.14.2. + version 14.12.3 while still being compatible with 4.14.2. Thanks, silvio. * assistant: Added --autostop to complement --autostart. * Work around wget bug #784348 which could cause it to clobber git-annex diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs new file mode 100644 --- /dev/null +++ b/CmdLine/GitRemoteAnnex.hs @@ -0,0 +1,1201 @@ +{- git-remote-annex program + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module CmdLine.GitRemoteAnnex where + +import Annex.Common +import Types.GitRemoteAnnex +import qualified Annex +import qualified Remote +import qualified Git +import qualified Git.CurrentRepo +import qualified Git.Ref +import qualified Git.Branch +import qualified Git.Bundle +import qualified Git.Remote +import qualified Git.Remote.Remove +import qualified Git.Version +import qualified Annex.SpecialRemote as SpecialRemote +import qualified Annex.Branch +import qualified Annex.BranchState +import qualified Annex.Url as Url +import qualified Types.Remote as Remote +import qualified Logs.Remote +import qualified Remote.External +import Remote.Helper.Encryptable (parseEncryptionMethod) +import Annex.Transfer +import Backend.GitRemoteAnnex +import Config +import Types.Key +import Types.RemoteConfig +import Types.ProposedAccepted +import Types.Export +import Types.GitConfig +import Types.BranchState +import Types.Difference +import Types.Crypto +import Git.Types +import Logs.File +import Logs.Difference +import Annex.Init +import Annex.UUID +import Annex.Content +import Annex.Perms +import Annex.SpecialRemote.Config +import Remote.List +import Remote.List.Util +import Utility.Tmp +import Utility.Tmp.Dir +import Utility.Env +import Utility.Metered +import Utility.FileMode + +import Network.URI +import Data.Either +import Data.Char +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Map.Strict as M +import qualified System.FilePath.ByteString as P +import qualified Utility.RawFilePath as R +import qualified Data.Set as S + +run :: [String] -> IO () +run (remotename:url:[]) = do + repo <- getRepo + state <- Annex.new repo + Annex.eval state $ + resolveSpecialRemoteWebUrl url >>= \case + -- git strips the "annex::" prefix of the url + -- when running this command, so add it back + Nothing -> parseurl ("annex::" ++ url) pure + Just url' -> parseurl url' checkAllowedFromSpecialRemoteWebUrl + where + parseurl u checkallowed = + case parseSpecialRemoteNameUrl remotename u of + Right src -> checkallowed src >>= run' u + Left e -> giveup e +run (_remotename:[]) = giveup "remote url not configured" +run _ = giveup "expected remote name and url parameters" + +run' :: String -> SpecialRemoteConfig -> Annex () +run' url src = do + sab <- startAnnexBranch + whenM (Annex.getRead Annex.debugenabled) $ + enableDebugOutput + -- Prevent any usual git-annex output to stdout, because + -- the output of this command is being parsed by git. + doQuietAction $ + withSpecialRemote src sab $ \rmt -> do + reportFullUrl url rmt + ls <- lines <$> liftIO getContents + go rmt ls emptyState + where + go rmt (l:ls) st = + let (c, v) = splitLine l + in case c of + "capabilities" -> capabilities >> go rmt ls st + "list" -> case v of + "" -> list st rmt False >>= go rmt ls + "for-push" -> list st rmt True >>= go rmt ls + _ -> protocolError l + "fetch" -> fetch st rmt (l:ls) + >>= \ls' -> go rmt ls' st + "push" -> push st rmt (l:ls) + >>= \(ls', st') -> go rmt ls' st' + "" -> return () + _ -> protocolError l + go _ [] _ = return () + +data State = State + { manifestCache :: Maybe Manifest + , trackingRefs :: M.Map Ref Sha + } + +emptyState :: State +emptyState = State + { manifestCache = Nothing + , trackingRefs = mempty + } + +protocolError :: String -> a +protocolError l = giveup $ "gitremote-helpers protocol error at " ++ show l + +capabilities :: Annex () +capabilities = do + liftIO $ putStrLn "fetch" + liftIO $ putStrLn "push" + liftIO $ putStrLn "" + liftIO $ hFlush stdout + +list :: State -> Remote -> Bool -> Annex State +list st rmt forpush = do + manifest <- if forpush + then downloadManifestWhenPresent rmt + else downloadManifestOrFail rmt + l <- forM (inManifest manifest) $ \k -> do + b <- downloadGitBundle rmt k + heads <- inRepo $ Git.Bundle.listHeads b + -- Get all the objects from the bundle. This is done here + -- so that the tracking refs can be updated with what is + -- listed, and so what when a full repush is done, all + -- objects are available to be pushed. + when forpush $ + inRepo $ Git.Bundle.unbundle b + -- The bundle may contain tracking refs, or regular refs, + -- make sure we're operating on regular refs. + return $ map (\(s, r) -> (fromTrackingRef rmt r, s)) heads + + -- Later refs replace earlier refs with the same name. + let refmap = M.fromList $ concat l + let reflist = M.toList refmap + let trackingrefmap = M.mapKeys (toTrackingRef rmt) refmap + + -- When listing for a push, update the tracking refs to match what + -- was listed. This is necessary in order for a full repush to know + -- what to push. + when forpush $ + updateTrackingRefs True rmt trackingrefmap + + -- Respond to git with a list of refs. + liftIO $ do + forM_ reflist $ \(ref, sha) -> + B8.putStrLn $ fromRef' sha <> " " <> fromRef' ref + -- Newline terminates list of refs. + putStrLn "" + hFlush stdout + + -- Remember the tracking refs and manifest. + return $ st + { manifestCache = Just manifest + , trackingRefs = trackingrefmap + } + +-- Any number of fetch commands can be sent by git, asking for specific +-- things. We fetch everything new at once, so find the end of the fetch +-- commands (which is supposed to be a blank line) before fetching. +fetch :: State -> Remote -> [String] -> Annex [String] +fetch st rmt (l:ls) = case splitLine l of + ("fetch", _) -> fetch st rmt ls + ("", _) -> do + fetch' st rmt + return ls + _ -> do + fetch' st rmt + return (l:ls) +fetch st rmt [] = do + fetch' st rmt + return [] + +fetch' :: State -> Remote -> Annex () +fetch' st rmt = do + manifest <- maybe (downloadManifestOrFail rmt) pure (manifestCache st) + forM_ (inManifest manifest) $ \k -> + downloadGitBundle rmt k >>= inRepo . Git.Bundle.unbundle + -- Newline indicates end of fetch. + liftIO $ do + putStrLn "" + hFlush stdout + +-- Note that the git bundles that are generated to push contain +-- tracking refs, rather than the actual refs that the user requested to +-- push. This is done because git bundle does not allow creating a bundle +-- that contains refs with different names than the ones in the git +-- repository. Consider eg, git push remote foo:bar, where the destination +-- ref is bar, but there may be no bar ref locally, or the bar ref may +-- be different than foo. If git bundle supported GIT_NAMESPACE, it would +-- be possible to generate a bundle that contains the specified refs. +push :: State -> Remote -> [String] -> Annex ([String], State) +push st rmt ls = do + let (refspecs, ls') = collectRefSpecs ls + (responses, trackingrefs) <- calc refspecs ([], trackingRefs st) + updateTrackingRefs False rmt trackingrefs + (ok, st') <- if M.null trackingrefs + then pushEmpty st rmt + else if any forcedPush refspecs + then fullPush st rmt (M.keys trackingrefs) + else incrementalPush st rmt + (trackingRefs st) trackingrefs + if ok + then do + sendresponses responses + return (ls', st' { trackingRefs = trackingrefs }) + else do + -- Restore the old tracking refs + updateTrackingRefs True rmt (trackingRefs st) + sendresponses $ + map (const "error push failed") refspecs + return (ls', st') + where + calc + :: [RefSpec] + -> ([B.ByteString], M.Map Ref Sha) + -> Annex ([B.ByteString], M.Map Ref Sha) + calc [] (responses, trackingrefs) = + return (reverse responses, trackingrefs) + calc (r:rs) (responses, trackingrefs) = + let tr = toTrackingRef rmt (dstRef r) + okresp m = pure + ( ("ok " <> fromRef' (dstRef r)):responses + , m + ) + errresp msg = pure + ( ("error " <> fromRef' (dstRef r) <> " " <> msg):responses + , trackingrefs + ) + in calc rs =<< case srcRef r of + Just srcref -> inRepo (Git.Ref.sha srcref) >>= \case + Just sha + | forcedPush r -> okresp $ + M.insert tr sha trackingrefs + | otherwise -> ifM (isfastforward sha tr) + ( okresp $ + M.insert tr sha trackingrefs + , errresp "non-fast-forward" + ) + Nothing -> errresp "unknown ref" + Nothing -> okresp $ M.delete tr trackingrefs + + -- Check if the push is a fast-forward that will not overwrite work + -- in the ref currently stored in the remote. This seems redundant + -- to git's own checking for non-fast-forwards. But unfortunately, + -- before git push checks that, it actually tells us to push. + -- That seems likely to be a bug in git, and this is a workaround. + isfastforward newref tr = case M.lookup tr (trackingRefs st) of + Just prevsha -> inRepo $ Git.Ref.isAncestor prevsha newref + Nothing -> pure True + + -- Send responses followed by newline to indicate end of push. + sendresponses responses = liftIO $ do + mapM_ B8.putStrLn responses + putStrLn "" + hFlush stdout + +-- Full push of the specified refs to the remote. +fullPush :: State -> Remote -> [Ref] -> Annex (Bool, State) +fullPush st rmt refs = guardPush st $ do + oldmanifest <- maybe (downloadManifestWhenPresent rmt) pure + (manifestCache st) + fullPush' oldmanifest st rmt refs + +fullPush' :: Manifest -> State -> Remote -> [Ref] -> Annex (Bool, State) +fullPush' oldmanifest st rmt refs = do + let bs = map Git.Bundle.fullBundleSpec refs + (bundlekey, uploadbundle) <- generateGitBundle rmt bs oldmanifest + let manifest = mkManifest [bundlekey] $ + S.fromList (inManifest oldmanifest) + `S.union` + outManifest oldmanifest + manifest' <- startPush rmt manifest + uploadbundle + uploadManifest rmt manifest' + return (True, st { manifestCache = Nothing }) + +guardPush :: State -> Annex (Bool, State) -> Annex (Bool, State) +guardPush st a = catchNonAsync a $ \ex -> do + liftIO $ hPutStrLn stderr $ + "Push failed (" ++ show ex ++ ")" + return (False, st { manifestCache = Nothing }) + +-- Incremental push of only the refs that changed. +-- +-- No refs were deleted (that causes a fullPush), but new refs may +-- have been added. +incrementalPush :: State -> Remote -> M.Map Ref Sha -> M.Map Ref Sha -> Annex (Bool, State) +incrementalPush st rmt oldtrackingrefs newtrackingrefs = guardPush st $ do + oldmanifest <- maybe (downloadManifestWhenPresent rmt) pure (manifestCache st) + if length (inManifest oldmanifest) + 1 > remoteAnnexMaxGitBundles (Remote.gitconfig rmt) + then fullPush' oldmanifest st rmt (M.keys newtrackingrefs) + else go oldmanifest + where + go oldmanifest = do + bs <- calc [] (M.toList newtrackingrefs) + (bundlekey, uploadbundle) <- generateGitBundle rmt bs oldmanifest + let manifest = oldmanifest <> mkManifest [bundlekey] mempty + manifest' <- startPush rmt manifest + uploadbundle + uploadManifest rmt manifest' + return (True, st { manifestCache = Nothing }) + + calc c [] = return (reverse c) + calc c ((ref, sha):refs) = case M.lookup ref oldtrackingrefs of + Just oldsha + | oldsha == sha -> calc c refs -- unchanged + | otherwise -> + ifM (inRepo $ Git.Ref.isAncestor oldsha ref) + ( use $ checkprereq oldsha ref + , use $ findotherprereq ref sha + ) + Nothing -> use $ findotherprereq ref sha + where + use a = do + bs <- a + calc (bs:c) refs + + -- Unfortunately, git bundle will let a prerequisite specified + -- for one ref prevent it including another ref. For example, + -- where x is a ref that points at A, and y is a ref that points at + -- B (which has A as its parent), git bundle x A..y + -- will omit including the x ref in the bundle at all. + -- + -- But we need to include all (changed) refs that the user + -- specified to push in the bundle. So, only include the sha + -- as a prerequisite when it will not prevent including another + -- changed ref in the bundle. + checkprereq prereq ref = + ifM (anyM shadows $ M.elems $ M.delete ref changedrefs) + ( pure $ Git.Bundle.fullBundleSpec ref + , pure $ Git.Bundle.BundleSpec + { Git.Bundle.preRequisiteRef = Just prereq + , Git.Bundle.includeRef = ref + } + ) + where + shadows s + | s == prereq = pure True + | otherwise = inRepo $ Git.Ref.isAncestor s prereq + changedrefs = M.differenceWith + (\a b -> if a == b then Nothing else Just a) + newtrackingrefs oldtrackingrefs + + -- When the old tracking ref is not able to be used as a + -- prerequisite, this to find some other ref that was previously + -- pushed that can be used as a prerequisite instead. This can + -- optimise the bundle size a bit in edge cases. + -- + -- For example, a forced push of branch foo that resets it back + -- several commits can use a previously pushed bar as a prerequisite + -- if it's an ancestor of foo. + findotherprereq ref sha = + findotherprereq' ref sha (M.elems oldtrackingrefs) + findotherprereq' ref _ [] = pure (Git.Bundle.fullBundleSpec ref) + findotherprereq' ref sha (l:ls) + | l == sha = findotherprereq' ref sha ls + | otherwise = ifM (inRepo $ Git.Ref.isAncestor l ref) + ( checkprereq l ref + , findotherprereq' ref sha ls + ) + +pushEmpty :: State -> Remote -> Annex (Bool, State) +pushEmpty st rmt = guardPush st $ do + oldmanifest <- maybe (downloadManifestWhenPresent rmt) pure + (manifestCache st) + let manifest = mkManifest mempty $ + S.fromList (inManifest oldmanifest) + `S.union` + outManifest oldmanifest + (manifest', manifestwriter) <- startPush' rmt manifest + manifest'' <- dropOldKeys rmt manifest' + manifestwriter manifest'' + uploadManifest rmt manifest'' + return (True, st { manifestCache = Nothing }) + +data RefSpec = RefSpec + { forcedPush :: Bool + , srcRef :: Maybe Ref -- ^ Nothing when deleting a ref + , dstRef :: Ref + } + deriving (Show) + +-- Any number of push commands can be sent by git, specifying the refspecs +-- to push. They should be followed by a blank line. +collectRefSpecs :: [String] -> ([RefSpec], [String]) +collectRefSpecs = go [] + where + go c (l:ls) = case splitLine l of + ("push", refspec) -> go (parseRefSpec refspec:c) ls + ("", _) -> (c, ls) + _ -> (c, (l:ls)) + go c [] = (c, []) + +parseRefSpec :: String -> RefSpec +parseRefSpec ('+':s) = (parseRefSpec s) { forcedPush = True } +parseRefSpec s = + let (src, cdst) = break (== ':') s + dst = if null cdst then cdst else drop 1 cdst + deletesrc = null src + in RefSpec + -- To delete a ref, have to do a force push of all + -- remaining refs. + { forcedPush = deletesrc + , srcRef = if deletesrc + then Nothing + else Just (Ref (encodeBS src)) + , dstRef = Ref (encodeBS dst) + } + +-- "foo bar" to ("foo", "bar") +-- "foo" to ("foo", "") +splitLine :: String -> (String, String) +splitLine l = + let (c, sv) = break (== ' ') l + v = if null sv then sv else drop 1 sv + in (c, v) + +data SpecialRemoteConfig + = SpecialRemoteConfig + { specialRemoteUUID :: UUID + , specialRemoteConfig :: RemoteConfig + , specialRemoteName :: Maybe RemoteName + , specialRemoteUrl :: String + } + | ExistingSpecialRemote RemoteName + deriving (Show) + +-- The url for a special remote looks like +-- "annex::uuid?param=value¶m=value..." +-- +-- Also accept an url of "annex::", when a remote name is provided, +-- to use an already enabled special remote. +parseSpecialRemoteNameUrl :: String -> String -> Either String SpecialRemoteConfig +parseSpecialRemoteNameUrl remotename url + | url == "annex::" && remotename /= url = Right $ + ExistingSpecialRemote remotename + | "annex::" `isPrefixOf` remotename = parseSpecialRemoteUrl url Nothing + | otherwise = parseSpecialRemoteUrl url (Just remotename) + +parseSpecialRemoteUrl :: String -> Maybe RemoteName -> Either String SpecialRemoteConfig +parseSpecialRemoteUrl url remotename = case parseURI url of + Nothing -> Left "URL parse failed" + Just u -> case uriScheme u of + "annex:" -> case uriPath u of + "" -> Left "annex: URL did not include a UUID" + (':':p) + | null p -> Left "annex: URL did not include a UUID" + | otherwise -> Right $ SpecialRemoteConfig + { specialRemoteUUID = toUUID p + , specialRemoteConfig = parsequery u + , specialRemoteName = remotename + , specialRemoteUrl = url + } + _ -> Left "annex: URL malformed" + _ -> Left "Not an annex: URL" + where + parsequery u = M.fromList $ + map parsekv $ splitc '&' (drop 1 (uriQuery u)) + parsekv kv = + let (k, sv) = break (== '=') kv + v = if null sv then sv else drop 1 sv + in (Proposed (unEscapeString k), Proposed (unEscapeString v)) + +-- Handles an url that contains a http address, by downloading +-- the web page and using it as the full annex:: url. +-- The passed url has already had "annex::" stripped off. +resolveSpecialRemoteWebUrl :: String -> Annex (Maybe String) +resolveSpecialRemoteWebUrl url + | "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl = + Url.withUrlOptionsPromptingCreds $ \uo -> + withTmpFile "git-remote-annex" $ \tmp h -> do + liftIO $ hClose h + Url.download' nullMeterUpdate Nothing url tmp uo >>= \case + Left err -> giveup $ url ++ " " ++ err + Right () -> liftIO $ + (headMaybe . lines) + <$> readFileStrict tmp + | otherwise = return Nothing + where + lcurl = map toLower url + +-- Only some types of special remotes are allowed to come from +-- resolveSpecialRemoteWebUrl. Throws an error if this one is not. +checkAllowedFromSpecialRemoteWebUrl :: SpecialRemoteConfig -> Annex SpecialRemoteConfig +checkAllowedFromSpecialRemoteWebUrl src@(ExistingSpecialRemote {}) = pure src +checkAllowedFromSpecialRemoteWebUrl src@(SpecialRemoteConfig {}) = + case M.lookup typeField (specialRemoteConfig src) of + Nothing -> giveup "Web URL did not include a type field." + Just t + | t == Proposed "httpalso" -> return src + | otherwise -> giveup "Web URL can only be used for a httpalso special remote." + +getSpecialRemoteUrl :: Remote -> Annex (Maybe String) +getSpecialRemoteUrl rmt = do + rcp <- Remote.configParser (Remote.remotetype rmt) + (unparsedRemoteConfig (Remote.config rmt)) + return $ genSpecialRemoteUrl rmt rcp + +genSpecialRemoteUrl :: Remote -> RemoteConfigParser -> Maybe String +genSpecialRemoteUrl rmt rcp + -- Fields that are accepted by remoteConfigRestPassthrough + -- are not necessary to include in the url, except perhaps for + -- external special remotes. If an external special remote sets + -- some such fields, cannot generate an url. + | Remote.typename (Remote.remotetype rmt) == Remote.typename Remote.External.remote + && any (`notElem` knownfields) (M.keys c) = Nothing + | otherwise = Just $ + "annex::" ++ fromUUID (Remote.uuid rmt) ++ "?" ++ + intercalate "&" (map configpair cs) + where + configpair (k, v) = conv k ++ "=" ++ conv v + conv = escapeURIString isUnescapedInURIComponent + . fromProposedAccepted + + cs = M.toList (M.filterWithKey (\k _ -> k `elem` safefields) c) + ++ case remoteAnnexConfigUUID (Remote.gitconfig rmt) of + Nothing -> [] + Just cu -> [(Accepted "config-uuid", Accepted (fromUUID cu))] + + c = unparsedRemoteConfig $ Remote.config rmt + + -- Hidden fields are used for internal stuff like ciphers + -- that should not be included in the url. + safefields = map parserForField $ + filter (\p -> fieldDesc p /= HiddenField) ps + + knownfields = map parserForField ps + + ps = SpecialRemote.essentialFieldParsers + ++ remoteConfigFieldParsers rcp + +reportFullUrl :: String -> Remote -> Annex () +reportFullUrl url rmt = + when (url == "annex::") $ + getSpecialRemoteUrl rmt >>= \case + Nothing -> noop + Just fullurl -> + liftIO $ hPutStrLn stderr $ + "Full remote url: " ++ fullurl + +-- Runs an action with a Remote as specified by the SpecialRemoteConfig. +withSpecialRemote :: SpecialRemoteConfig -> StartAnnexBranch -> (Remote -> Annex a) -> Annex a +withSpecialRemote (ExistingSpecialRemote remotename) sab a = + getEnabledSpecialRemoteByName remotename >>= + maybe (giveup $ "There is no special remote named " ++ remotename) + (specialRemoteFromUrl sab . a) +withSpecialRemote cfg@(SpecialRemoteConfig {}) sab a = case specialRemoteName cfg of + -- The name could be the name of an existing special remote, + -- if so use it as long as its UUID matches the UUID from the url. + Just remotename -> getEnabledSpecialRemoteByName remotename >>= \case + Just rmt + | Remote.uuid rmt == specialRemoteUUID cfg -> + specialRemoteFromUrl sab (a rmt) + | otherwise -> giveup $ "The uuid in the annex:: url does not match the uuid of the remote named " ++ remotename + -- When cloning from an annex:: url, + -- this is used to set up the origin remote. + Nothing -> specialRemoteFromUrl sab + (initremote remotename >>= a) + Nothing -> specialRemoteFromUrl sab inittempremote + where + -- Initialize a new special remote with the provided configuration + -- and name. + initremote remotename = do + let c = M.insert SpecialRemote.nameField (Proposed remotename) $ + M.delete (Accepted "config-uuid") $ + specialRemoteConfig cfg + t <- either giveup return (SpecialRemote.findType c) + dummycfg <- liftIO dummyRemoteGitConfig + (c', u) <- Remote.setup t Remote.Init (Just (specialRemoteUUID cfg)) + Nothing c dummycfg + `onException` cleanupremote remotename + Logs.Remote.configSet u c' + setConfig (remoteConfig c' "url") (specialRemoteUrl cfg) + case M.lookup (Accepted "config-uuid") (specialRemoteConfig cfg) of + Just cu -> do + setConfig (remoteAnnexConfig c' "config-uuid") + (fromProposedAccepted cu) + -- This is not quite the same as what is + -- usually stored to the git-annex branch + -- for the config-uuid, but it will work. + -- This change will never be committed to the + -- git-annex branch. + Logs.Remote.configSet (toUUID (fromProposedAccepted cu)) c' + Nothing -> noop + remotesChanged + getEnabledSpecialRemoteByName remotename >>= \case + Just rmt -> return rmt + Nothing -> do + cleanupremote remotename + giveup "Unable to find special remote after setup." + + -- Temporarily initialize a special remote, and remove it after + -- the action is run. + inittempremote = + let remotename = Git.Remote.makeLegalName $ + "annex-temp-" ++ fromUUID (specialRemoteUUID cfg) + in bracket + (initremote remotename) + (const $ cleanupremote remotename) + a + + cleanupremote remotename = do + l <- inRepo Git.Remote.listRemotes + when (remotename `elem` l) $ + inRepo $ Git.Remote.Remove.remove remotename + +-- When a special remote has already been enabled, just use it. +getEnabledSpecialRemoteByName :: RemoteName -> Annex (Maybe Remote) +getEnabledSpecialRemoteByName remotename = + Remote.byNameOnly remotename >>= \case + Nothing -> return Nothing + Just rmt + -- If the git-annex branch is missing or does not + -- have a remote config for this remote, but the + -- git config has the remote, it can't be used. + | unparsedRemoteConfig (Remote.config rmt) == mempty -> + return Nothing + | otherwise -> + maybe (Just <$> importTreeWorkAround rmt) giveup + (checkSpecialRemoteProblems rmt) + +checkSpecialRemoteProblems :: Remote -> Maybe String +checkSpecialRemoteProblems rmt + -- Avoid using special remotes that are thirdparty populated, + -- because there is no way to push the git repository keys into one. + | Remote.thirdPartyPopulated (Remote.remotetype rmt) = + Just $ "Cannot use this thirdparty-populated special" + ++ " remote as a git remote." + | parseEncryptionMethod (unparsedRemoteConfig (Remote.config rmt)) /= Right NoneEncryption + && not (remoteAnnexAllowEncryptedGitRepo (Remote.gitconfig rmt)) = + Just $ "Using an encrypted special remote as a git" + ++ " remote makes it impossible to clone" + ++ " from it. If you will never need to" + ++ " clone from this remote, set: git config " + ++ decodeBS allowencryptedgitrepo ++ " true" + | otherwise = Nothing + where + ConfigKey allowencryptedgitrepo = remoteAnnexConfig rmt "allow-encrypted-gitrepo" + +-- Using importTree remotes needs the content identifier database to be +-- populated, but it is not when cloning, and cannot be updated when +-- pushing since git-annex branch updates by this program are prevented. +-- +-- So, generate instead a version of the remote that uses exportTree actions, +-- which do not need content identifiers. Since Remote.Helper.exportImport +-- replaces the exportActions in exportActionsForImport with ones that use +-- import actions, have to instantiate a new remote with a modified config. +importTreeWorkAround :: Remote -> Annex Remote +importTreeWorkAround rmt + | not (importTree (Remote.config rmt)) = pure rmt + | not (exportTree (Remote.config rmt)) = giveup "Using special remotes with importtree=yes but without exporttree=yes as git remotes is not supported." + | otherwise = do + m <- Logs.Remote.remoteConfigMap + r <- Remote.getRepo rmt + remoteGen' adjustconfig m (Remote.remotetype rmt) r >>= \case + Just rmt' -> return rmt' + Nothing -> giveup "Failed to use importtree=yes remote." + where + adjustconfig = M.delete importTreeField + +-- Downloads the Manifest when present in the remote. When not present, +-- returns an empty Manifest. +downloadManifestWhenPresent :: Remote -> Annex Manifest +downloadManifestWhenPresent rmt = fromMaybe mempty <$> downloadManifest rmt + +-- Downloads the Manifest, or fails if the remote does not contain it. +downloadManifestOrFail :: Remote -> Annex Manifest +downloadManifestOrFail rmt = + maybe (giveup "No git repository found in this remote.") return + =<< downloadManifest rmt + +-- Downloads the Manifest or Nothing if the remote does not contain a +-- manifest. +-- +-- Throws errors if the remote cannot be accessed or the download fails, +-- or if the manifest file cannot be parsed. +downloadManifest :: Remote -> Annex (Maybe Manifest) +downloadManifest rmt = get mkmain >>= maybe (get mkbak) (pure . Just) + where + mkmain = genManifestKey (Remote.uuid rmt) + mkbak = genBackupManifestKey (Remote.uuid rmt) + + get mk = getKeyExportLocations rmt mk >>= \case + Nothing -> ifM (Remote.checkPresent rmt mk) + ( gettotmp $ \tmp -> + Remote.retrieveKeyFile rmt mk + (AssociatedFile Nothing) tmp + nullMeterUpdate Remote.NoVerify + , return Nothing + ) + Just locs -> getexport mk locs + + -- Downloads to a temporary file, rather than using eg + -- Annex.Transfer.download that would put it in the object + -- directory. The content of manifests is not stable, and so + -- it needs to re-download it fresh every time, and the object + -- file should not be stored locally. + gettotmp dl = withTmpFile "GITMANIFEST" $ \tmp tmph -> do + liftIO $ hClose tmph + _ <- dl tmp + b <- liftIO (B.readFile tmp) + case parseManifest b of + Right m -> Just <$> verifyManifest rmt m + Left err -> giveup err + + getexport _ [] = return Nothing + getexport mk (loc:locs) = + ifM (Remote.checkPresentExport (Remote.exportActions rmt) mk loc) + ( gettotmp $ \tmp -> + Remote.retrieveExport (Remote.exportActions rmt) + mk loc tmp nullMeterUpdate + , getexport mk locs + ) + +-- Uploads the Manifest to the remote. +-- +-- Throws errors if the remote cannot be accessed or the upload fails. +-- +-- The manifest key is first dropped from the remote, then the new +-- content is uploaded. This is necessary because the same key is used, +-- and behavior of remotes is undefined when sending a key that is +-- already present on the remote, but with different content. +-- +-- So this may be interrupted and leave the manifest key not present. +-- To deal with that, there is a backup manifest key. This takes care +-- to ensure that one of the two keys will always exist. +uploadManifest :: Remote -> Manifest -> Annex () +uploadManifest rmt manifest = do + ok <- ifM (Remote.checkPresent rmt mkbak) + ( dropandput mkmain <&&> dropandput mkbak + -- The backup manifest doesn't exist, so upload + -- it first, and then the manifest second. + -- This ensures that at no point are both deleted. + , put mkbak <&&> dropandput mkmain + ) + unless ok + uploadfailed + where + mkmain = genManifestKey (Remote.uuid rmt) + mkbak = genBackupManifestKey (Remote.uuid rmt) + + uploadfailed = giveup "Failed to upload manifest." + + dropandput mk = do + dropKey' rmt mk + put mk + + put mk = withTmpFile "GITMANIFEST" $ \tmp tmph -> do + liftIO $ B8.hPut tmph (formatManifest manifest) + liftIO $ hClose tmph + -- Uploading needs the key to be in the annex objects + -- directory, so put the manifest file there temporarily. + -- Using linkOrCopy rather than moveAnnex to avoid updating + -- InodeCache database. Also, works even when the repository + -- is configured to require only cryptographically secure + -- keys, which it is not. + objfile <- calcRepo (gitAnnexLocation mk) + modifyContentDir objfile $ + linkOrCopy mk (toRawFilePath tmp) objfile Nothing >>= \case + -- Important to set the right perms even + -- though the object is only present + -- briefly, since sending objects may rely + -- on or even copy file perms. + Just _ -> do + liftIO $ R.setFileMode objfile + =<< defaultFileMode + freezeContent objfile + Nothing -> uploadfailed + ok <- (uploadGitObject rmt mk >> pure True) + `catchNonAsync` (const (pure False)) + -- Don't leave the manifest key in the annex objects + -- directory. + unlinkAnnex mk + return ok + +formatManifest :: Manifest -> B.ByteString +formatManifest manifest = + B8.unlines $ + map serializeKey' (inManifest manifest) + <> + map (\k -> "-" <> serializeKey' k) + (S.toList (outManifest manifest)) + +parseManifest :: B.ByteString -> Either String Manifest +parseManifest b = + let (outks, inks) = partitionEithers $ map parseline $ B8.lines b + in case (checkvalid [] inks, checkvalid [] outks) of + (Right inks', Right outks') -> + Right $ mkManifest inks' (S.fromList outks') + (Left err, _) -> Left err + (_, Left err) -> Left err + where + parseline l + | "-" `B.isPrefixOf` l = + Left $ deserializeKey' $ B.drop 1 l + | otherwise = + Right $ deserializeKey' l + + checkvalid c [] = Right (reverse c) + checkvalid c (Just k:ks) = case fromKey keyVariety k of + GitBundleKey -> checkvalid (k:c) ks + _ -> Left $ "Wrong type of key in manifest " ++ serializeKey k + checkvalid _ (Nothing:_) = + Left "Error parsing manifest" + +{- A manifest file is cached here before it or the bundles listed in it + - is uploaded to the special remote. + - + - This prevents forgetting which bundles were uploaded when a push gets + - interrupted before updating the manifest on the remote, or when a race + - causes the uploaded manigest to be overwritten. + -} +lastPushedManifestFile :: UUID -> Git.Repo -> RawFilePath +lastPushedManifestFile u r = gitAnnexDir r P. "git-remote-annex" + P. fromUUID u P. "manifest" + +{- Call before uploading anything. The returned manifest has added + - to it any bundle keys that were in the lastPushedManifestFile + - and that are not in the new manifest. -} +startPush :: Remote -> Manifest -> Annex Manifest +startPush rmt manifest = do + (manifest', writer) <- startPush' rmt manifest + writer manifest' + return manifest' + +startPush' :: Remote -> Manifest -> Annex (Manifest, Manifest -> Annex ()) +startPush' rmt manifest = do + f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt)) + oldmanifest <- liftIO $ + fromRight mempty . parseManifest + <$> B.readFile (fromRawFilePath f) + `catchNonAsync` (const (pure mempty)) + let oldmanifest' = mkManifest [] $ + S.fromList (inManifest oldmanifest) + `S.union` + outManifest oldmanifest + let manifest' = manifest <> oldmanifest' + let writer = writeLogFile f . decodeBS . formatManifest + return (manifest', writer) + +-- Drops the outManifest keys. Returns a version of the manifest with +-- any outManifest keys that were successfully dropped removed from it. +-- +-- If interrupted at this stage, or if a drop fails, the key remains +-- in the outManifest, so the drop will be tried again later. +dropOldKeys :: Remote -> Manifest -> Annex Manifest +dropOldKeys rmt manifest = + mkManifest (inManifest manifest) . S.fromList + <$> filterM (not <$$> dropKey rmt) + (S.toList (outManifest manifest)) + +-- When pushEmpty raced with another push, it could result in the manifest +-- listing bundles that it deleted. Such a manifest has to be treated the +-- same as an empty manifest. To detect that, this checks that all the +-- bundles listed in the manifest still exist on the remote. +verifyManifest :: Remote -> Manifest -> Annex Manifest +verifyManifest rmt manifest = + ifM (allM (checkPresentGitBundle rmt) (inManifest manifest)) + ( return manifest + , return $ mkManifest [] $ + S.fromList (inManifest manifest) + `S.union` + outManifest manifest + ) + +-- Downloads a git bundle to the annex objects directory, unless +-- the object file is already present. Returns the filename of the object +-- file. +-- +-- Throws errors if the download fails, or the checksum does not verify. +-- +-- This does not update the location log to indicate that the local +-- repository contains the git bundle object. Reasons not to include: +-- 1. When this is being used in a git clone, the repository will not have +-- a UUID yet. +-- 2. It would unncessarily bloat the git-annex branch, which would then +-- lead to more things needing to be pushed to the special remote, +-- and so more things pulled from it, etc. +-- 3. Git bundle objects are not usually transferred between repositories +-- except special remotes (although the user can if they want to). +downloadGitBundle :: Remote -> Key -> Annex FilePath +downloadGitBundle rmt k = getKeyExportLocations rmt k >>= \case + Nothing -> dlwith $ + download rmt k (AssociatedFile Nothing) stdRetry noNotification + Just locs -> dlwith $ + anyM getexport locs + where + dlwith a = ifM a + ( decodeBS <$> calcRepo (gitAnnexLocation k) + , giveup $ "Failed to download " ++ serializeKey k + ) + + getexport loc = catchNonAsync (getexport' loc) (const (pure False)) + getexport' loc = + getViaTmp rsp vc k (AssociatedFile Nothing) Nothing $ \tmp -> do + v <- Remote.retrieveExport (Remote.exportActions rmt) + k loc (decodeBS tmp) nullMeterUpdate + return (True, v) + rsp = Remote.retrievalSecurityPolicy rmt + vc = Remote.RemoteVerify rmt + +-- Checks if a bundle is present. Throws errors if the remote cannot be +-- accessed. +checkPresentGitBundle :: Remote -> Key -> Annex Bool +checkPresentGitBundle rmt k = + getKeyExportLocations rmt k >>= \case + Nothing -> Remote.checkPresent rmt k + Just locs -> anyM checkexport locs + where + checkexport = Remote.checkPresentExport (Remote.exportActions rmt) k + +-- Uploads a bundle or manifest object from the annex objects directory +-- to the remote. +-- +-- Throws errors if the upload fails. +-- +-- This does not update the location log to indicate that the remote +-- contains the git object. +uploadGitObject :: Remote -> Key -> Annex () +uploadGitObject rmt k = getKeyExportLocations rmt k >>= \case + Just (loc:_) -> do + objfile <- fromRawFilePath <$> calcRepo (gitAnnexLocation k) + Remote.storeExport (Remote.exportActions rmt) objfile k loc nullMeterUpdate + _ -> + unlessM (upload rmt k (AssociatedFile Nothing) retry noNotification) $ + giveup $ "Failed to upload " ++ serializeKey k + where + retry = case fromKey keyVariety k of + GitBundleKey -> stdRetry + -- Manifest keys are not stable + _ -> noRetry + +-- Generates a git bundle, ingests it into the local objects directory, +-- and returns an action that uploads its key to the special remote. +-- +-- If the key is already present in the provided manifest, avoids +-- ingesting or uploading it. +-- +-- On failure, an exception is thrown, and nothing is added to the local +-- objects directory. +generateGitBundle + :: Remote + -> [Git.Bundle.BundleSpec] + -> Manifest + -> Annex (Key, Annex ()) +generateGitBundle rmt bs manifest = + withTmpFile "GITBUNDLE" $ \tmp tmph -> do + liftIO $ hClose tmph + inRepo $ Git.Bundle.create tmp bs + bundlekey <- genGitBundleKey (Remote.uuid rmt) + (toRawFilePath tmp) nullMeterUpdate + if (bundlekey `notElem` inManifest manifest) + then do + unlessM (moveAnnex bundlekey (AssociatedFile Nothing) (toRawFilePath tmp)) $ + giveup "Unable to push" + return (bundlekey, uploadaction bundlekey) + else return (bundlekey, noop) + where + uploadaction bundlekey = + uploadGitObject rmt bundlekey + `onException` unlinkAnnex bundlekey + +dropKey :: Remote -> Key -> Annex Bool +dropKey rmt k = tryNonAsync (dropKey' rmt k) >>= \case + Right () -> return True + Left ex -> do + liftIO $ hPutStrLn stderr $ + "Failed to drop " + ++ serializeKey k + ++ " (" ++ show ex ++ ")" + return False + +dropKey' :: Remote -> Key -> Annex () +dropKey' rmt k = getKeyExportLocations rmt k >>= \case + Nothing -> Remote.removeKey rmt k + Just locs -> forM_ locs $ \loc -> + Remote.removeExport (Remote.exportActions rmt) k loc + +getKeyExportLocations :: Remote -> Key -> Annex (Maybe [ExportLocation]) +getKeyExportLocations rmt k = do + cfg <- Annex.getGitConfig + u <- getUUID + return $ keyExportLocations rmt k cfg u + +-- When the remote contains a tree, the git keys are stored +-- inside the .git/annex/objects/ directory in the remote. +-- +-- The first ExportLocation in the returned list is the one that +-- is the same as the local repository would use. But it's possible +-- that one of the others in the list was used by another repository to +-- upload a git key. +keyExportLocations :: Remote -> Key -> GitConfig -> UUID -> Maybe [ExportLocation] +keyExportLocations rmt k cfg uuid + | exportTree (Remote.config rmt) || importTree (Remote.config rmt) = + Just $ map (\p -> mkExportLocation (".git" P. p)) $ + concatMap (`annexLocationsNonBare` k) cfgs + | otherwise = Nothing + where + -- When git-annex has not been initialized yet (eg, when cloning), + -- the Differences are unknown, so make a version of the GitConfig + -- with and without the OneLevelObjectHash difference. + cfgs + | uuid /= NoUUID = [cfg] + | hasDifference OneLevelObjectHash (annexDifferences cfg) = + [ cfg + , cfg { annexDifferences = mempty } + ] + | otherwise = + [ cfg + , cfg + { annexDifferences = mkDifferences + (S.singleton OneLevelObjectHash) + } + ] + +-- Tracking refs are used to remember the refs that are currently on the +-- remote. This is different from git's remote tracking branches, since it +-- needs to track all refs on the remote, not only the refs that the user +-- chooses to fetch. +-- +-- For refs/heads/master, the tracking ref is +-- refs/namespaces/git-remote-annex/uuid/refs/heads/master, +-- using the uuid of the remote. See gitnamespaces(7). +trackingRefPrefix :: Remote -> B.ByteString +trackingRefPrefix rmt = "refs/namespaces/git-remote-annex/" + <> fromUUID (Remote.uuid rmt) <> "/" + +toTrackingRef :: Remote -> Ref -> Ref +toTrackingRef rmt (Ref r) = Ref $ trackingRefPrefix rmt <> r + +-- If the ref is not a tracking ref, it is returned as-is. +fromTrackingRef :: Remote -> Ref -> Ref +fromTrackingRef rmt = Git.Ref.removeBase (decodeBS (trackingRefPrefix rmt)) + +-- Update the tracking refs to be those in the map. +-- When deleteold is set, any other tracking refs are deleted. +updateTrackingRefs :: Bool -> Remote -> M.Map Ref Sha -> Annex () +updateTrackingRefs deleteold rmt new = do + old <- inRepo $ Git.Ref.forEachRef + [Param (decodeBS (trackingRefPrefix rmt))] + + -- Delete all tracking refs that are not in the map. + when deleteold $ + forM_ (filter (\p -> M.notMember (fst p) new) old) $ \(s, r) -> + inRepo $ Git.Ref.delete s r + + -- Update all changed tracking refs. + let oldmap = M.fromList (map (\(s, r) -> (r, s)) old) + forM_ (M.toList new) $ \(r, s) -> + case M.lookup r oldmap of + Just s' | s' == s -> noop + _ -> inRepo $ Git.Branch.update' r s + +-- git clone does not bother to set GIT_WORK_TREE when running this +-- program, and it does not run it inside the new git repo either. +-- GIT_DIR is set to the new git directory. So, have to override +-- the worktree to be the parent of the gitdir. +getRepo :: IO Repo +getRepo = getEnv "GIT_WORK_TREE" >>= \case + Just _ -> Git.CurrentRepo.get + Nothing -> fixup <$> Git.CurrentRepo.get + where + fixup r@(Repo { location = loc@(Local { worktree = Just _ }) }) = + r { location = loc { worktree = Just (P.takeDirectory (gitdir loc)) } } + fixup r = r + +-- Records what the git-annex branch was at the beginning of this command. +data StartAnnexBranch + = AnnexBranchExistedAlready Sha + | AnnexBranchCreatedEmpty Sha + +{- Run early in the command, gets the initial state of the git-annex + - branch. + - + - If the branch does not exist yet, it's created here. This is done + - because it's hard to avoid the branch being created by this command, + - so tracking the sha of the created branch allows cleaning it up later. + -} +startAnnexBranch :: Annex StartAnnexBranch +startAnnexBranch = ifM (null <$> Annex.Branch.siblingBranches) + ( AnnexBranchCreatedEmpty <$> Annex.Branch.getBranch + , AnnexBranchExistedAlready <$> Annex.Branch.getBranch + ) + +-- This runs an action that will set up a special remote that +-- was specified using an annex url. +-- +-- Setting up a special remote needs to write its config to the git-annex +-- branch. And using a special remote may also write to the branch. +-- But in this case, writes to the git-annex branch need to be avoided, +-- so that cleanupInitialization can leave things in the right state. +-- +-- So this prevents commits to the git-annex branch, and redirects all +-- journal writes to a temporary directory, so that all writes +-- to the git-annex branch by the action will be discarded. +specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a +specialRemoteFromUrl sab a = withTmpDir "journal" $ \tmpdir -> do + Annex.overrideGitConfig $ \c -> + c { annexAlwaysCommit = False } + Annex.BranchState.changeState $ \st -> + st { alternateJournal = Just (toRawFilePath tmpdir) } + a `finally` cleanupInitialization sab tmpdir + +-- If the git-annex branch did not exist when this command started, +-- it was created empty by this command, and this command has avoided +-- making any other commits to it, writing any temporary annex branch +-- changes to thre alternateJournal, which can now be discarded. +-- +-- If nothing else has written to the branch while this command was running, +-- the branch will be deleted. That allows for the git-annex branch that is +-- fetched from the special remote to contain Differences, which would prevent +-- it from being merged with the git-annex branch created by this command. +-- +-- If there is still not a sibling git-annex branch, this deletes all annex +-- objects for git bundles from the annex objects directory, and deletes +-- the annex objects directory. That is necessary to avoid the +-- Annex.Init.objectDirNotPresent check preventing a later initialization. +-- And if the later initialization includes Differences, the git bundle +-- objects downloaded by this process would be in the wrong locations. +-- +-- When there is now a sibling git-annex branch, this handles +-- initialization. When the initialized git-annex branch has Differences, +-- the git bundle objects are in the wrong place, so have to be deleted. +-- +-- Unfortunately, git 2.45.1 and related releases added a +-- "defense in depth" check that a freshly cloned repository +-- does not contain any hooks. Since initialization installs +-- hooks, have to work around that by not initializing, and +-- delete the git bundle objects. +cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex () +cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do + liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir + case sab of + AnnexBranchExistedAlready _ -> noop + AnnexBranchCreatedEmpty r -> + whenM ((r ==) <$> Annex.Branch.getBranch) $ do + indexfile <- fromRepo gitAnnexIndex + liftIO $ removeWhenExistsWith R.removeLink indexfile + -- When cloning failed and this is being + -- run as an exception is thrown, HEAD will + -- not be set to a valid value, which will + -- prevent deleting the git-annex branch. + -- But that's ok, git will delete the + -- repository it failed to clone into. + -- So skip deleting to avoid an ugly + -- message. + inRepo Git.Branch.currentUnsafe >>= \case + Nothing -> return () + Just _ -> void $ tryNonAsync $ + inRepo $ Git.Branch.delete Annex.Branch.fullname + ifM (Annex.Branch.hasSibling <&&> nonbuggygitversion) + ( do + autoInitialize' (pure True) remoteList + differences <- allDifferences <$> recordedDifferences + when (differences /= mempty) $ + deletebundleobjects + , deletebundleobjects + ) + where + deletebundleobjects = do + annexobjectdir <- fromRepo gitAnnexObjectDir + ks <- listKeys InAnnex + forM_ ks $ \k -> case fromKey keyVariety k of + GitBundleKey -> lockContentForRemoval k noop removeAnnex + _ -> noop + void $ liftIO $ tryIO $ removeDirectory (decodeBS annexobjectdir) + + nonbuggygitversion = liftIO $ + flip notElem buggygitversions <$> Git.Version.installed + buggygitversions = map Git.Version.normalize + [ "2.45.1" + , "2.44.1" + , "2.43.4" + , "2.42.2" + , "2.41.1" + , "2.40.2" + , "2.39.4" + ] diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -25,7 +25,7 @@ "capabilities" -> putStrLn "connect" >> ready "connect git-upload-pack" -> go UploadPack "connect git-receive-pack" -> go ReceivePack - l -> giveup $ "git-remote-helpers protocol error at " ++ show l + l -> giveup $ "gitremote-helpers protocol error at " ++ show l where (onionaddress, onionport) | '/' `elem` address = parseAddressPort $ diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2013-2023 Joey Hess + - Copyright 2013-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -19,6 +19,7 @@ import qualified Remote import qualified Types.Remote as Remote import qualified Remote.Git +import qualified Command.InitRemote import Logs.UUID import Annex.UUID import Config @@ -34,18 +35,32 @@ command "enableremote" SectionSetup "enables git-annex to use a remote" (paramPair paramName $ paramOptional $ paramRepeating paramParamValue) - (withParams seek) + (seek <$$> optParser) -seek :: CmdParams -> CommandSeek -seek = withWords (commandAction . start) +data EnableRemoteOptions = EnableRemoteOptions + { cmdparams :: CmdParams + , withUrl :: Bool + } -start :: [String] -> CommandStart -start [] = unknownNameError "Specify the remote to enable." -start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes +optParser :: CmdParamsDesc -> Parser EnableRemoteOptions +optParser desc = EnableRemoteOptions + <$> cmdParams desc + <*> switch + ( long "with-url" + <> short 'u' + <> help "configure remote with an annex:: url" + ) + +seek :: EnableRemoteOptions -> CommandSeek +seek o = withWords (commandAction . (start o)) (cmdparams o) + +start :: EnableRemoteOptions -> [String] -> CommandStart +start _ [] = unknownNameError "Specify the remote to enable." +start o (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes where matchingname r = Git.remoteName r == Just name go [] = deadLast name $ - startSpecialRemote name (Logs.Remote.keyValToConfig Proposed rest) + startSpecialRemote o name (Logs.Remote.keyValToConfig Proposed rest) go (r:_) | not (null rest) = go [] | otherwise = do @@ -69,8 +84,8 @@ ai = ActionItemOther (Just (UnquotedString name)) si = SeekInput [name] -startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart -startSpecialRemote = startSpecialRemote' "enableremote" performSpecialRemote +startSpecialRemote :: EnableRemoteOptions -> Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart +startSpecialRemote o = startSpecialRemote' "enableremote" (performSpecialRemote o) type PerformSpecialRemote = RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform @@ -97,8 +112,8 @@ startSpecialRemote' _ _ _ _ _ = giveup "Multiple remotes have that name. Either use git-annex renameremote to rename them, or specify the uuid of the remote." -performSpecialRemote :: PerformSpecialRemote -performSpecialRemote t u oldc c gc mcu = do +performSpecialRemote :: EnableRemoteOptions -> PerformSpecialRemote +performSpecialRemote o t u oldc c gc mcu = do -- Avoid enabling a special remote if there is another remote -- with the same name. case SpecialRemote.lookupName c of @@ -110,10 +125,10 @@ giveup $ "Not overwriting currently configured git remote named \"" ++ name ++ "\"" _ -> noop (c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc - next $ cleanupSpecialRemote t u' c' mcu + next $ cleanupSpecialRemote o t u' c' mcu -cleanupSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup -cleanupSpecialRemote t u c mcu = do +cleanupSpecialRemote :: EnableRemoteOptions -> RemoteType -> UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup +cleanupSpecialRemote o t u c mcu = do case mcu of Nothing -> Logs.Remote.configSet u c Just (SpecialRemote.ConfigFrom cu) -> do @@ -124,7 +139,9 @@ Just r -> do repo <- R.getRepo r setRemoteIgnore repo False - unless (Remote.gitSyncableRemoteType t) $ + when (withUrl o) $ + Command.InitRemote.setAnnexUrl c + unless (Remote.gitSyncableRemoteType t || withUrl o) $ setConfig (remoteConfig c "skipFetchAll") (boolConfig True) return True diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -111,7 +111,7 @@ -- we just want to know if the tor circuit works. liftIO (tryNonAsync $ connectPeer g addr) >>= \case Left e -> do - warning $ UnquotedString $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.." + warning $ UnquotedString $ "Unable to connect to hidden service. It may not yet have propagated to the Tor network. (" ++ show e ++ ") Will retry.." liftIO $ threadDelaySeconds (Seconds 2) check (n-1) addrs Right conn -> do diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -38,6 +38,7 @@ import Git.FilePath import Utility.PID import Utility.InodeCache +import Utility.Metered import Annex.InodeSentinal import qualified Database.Keys import qualified Database.Fsck as FsckDb @@ -206,8 +207,7 @@ ) , return Nothing ) - getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) dummymeter (RemoteVerify remote) - dummymeter _ = noop + getfile' tmp = Remote.retrieveKeyFile remote key (AssociatedFile Nothing) (fromRawFilePath tmp) nullMeterUpdate (RemoteVerify remote) getcheap tmp = case Remote.retrieveKeyFileCheap remote of Just a -> isRight <$> tryNonAsync (a key afile (fromRawFilePath tmp)) Nothing -> return False @@ -504,16 +504,19 @@ checkBackend :: Key -> KeyStatus -> AssociatedFile -> Annex Bool checkBackend key keystatus afile = do content <- calcRepo (gitAnnexLocation key) - ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) - ( nocheck - , do - mic <- withTSDelta (liftIO . genInodeCache content) - ifM (checkBackendOr badContent key content ai) - ( do - checkInodeCache key content mic ai - return True - , return False - ) + ifM (liftIO $ R.doesPathExist content) + ( ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content)) + ( nocheck + , do + mic <- withTSDelta (liftIO . genInodeCache content) + ifM (checkBackendOr badContent key content ai) + ( do + checkInodeCache key content mic ai + return True + , return False + ) + ) + , nocheck ) where nocheck = return True @@ -525,14 +528,18 @@ checkBackendOr (badContentRemote remote localcopy) key localcopy ai checkBackendOr :: (Key -> Annex String) -> Key -> RawFilePath -> ActionItem -> Annex Bool -checkBackendOr bad key file ai = do - ok <- verifyKeyContent' key file - unless ok $ do - msg <- bad key - warning $ actionItemDesc ai - <> ": Bad file content; " - <> UnquotedString msg - return ok +checkBackendOr bad key file ai = + ifM (Annex.getRead Annex.fast) + ( return True + , do + ok <- verifyKeyContent' key file + unless ok $ do + msg <- bad key + warning $ actionItemDesc ai + <> ": Bad file content; " + <> UnquotedString msg + return ok + ) {- Check, if there are InodeCaches recorded for a key, that one of them - matches the object file. There are situations where the InodeCache diff --git a/Command/Group.hs b/Command/Group.hs --- a/Command/Group.hs +++ b/Command/Group.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2012 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,19 +9,39 @@ import Command import qualified Remote -import Logs.Group import Types.Group +import Logs.Group +import Logs.UUID +import Logs.Trust import Utility.SafeOutput import qualified Data.Set as S +import qualified Data.Map as M cmd :: Command cmd = noMessages $ command "group" SectionSetup "add a repository to a group" - (paramPair paramRemote paramDesc) (withParams seek) + (paramPair paramRemote paramDesc) (seek <$$> optParser) -seek :: CmdParams -> CommandSeek -seek = withWords (commandAction . start) +data GroupOptions = GroupOptions + { cmdparams :: CmdParams + , listOption :: Bool + } +optParser :: CmdParamsDesc -> Parser GroupOptions +optParser desc = GroupOptions + <$> cmdParams desc + <*> switch + ( long "list" + <> help "list all currently defined groups" + ) + +seek :: GroupOptions -> CommandSeek +seek o + | listOption o = if null (cmdparams o) + then commandAction startList + else giveup "Cannot combine --list with other options" + | otherwise = commandAction $ start (cmdparams o) + start :: [String] -> CommandStart start ps@(name:g:[]) = do u <- Remote.nameToUUID name @@ -33,12 +53,21 @@ start (name:[]) = do u <- Remote.nameToUUID name startingCustomOutput (ActionItemOther Nothing) $ do - liftIO . putStrLn . safeOutput . unwords . map fmt . S.toList - =<< lookupGroups u + liftIO . listGroups =<< lookupGroups u next $ return True +start _ = giveup "Specify a repository and a group." + +startList :: CommandStart +startList = startingCustomOutput (ActionItemOther Nothing) $ do + us <- trustExclude DeadTrusted =<< M.keys <$> uuidDescMap + gs <- foldl' S.union mempty <$> mapM lookupGroups us + liftIO $ listGroups gs + next $ return True + +listGroups :: S.Set Group -> IO () +listGroups = liftIO . putStrLn . safeOutput . unwords . map fmt . S.toList where fmt (Group g) = decodeBS g -start _ = giveup "Specify a repository and a group." setGroup :: UUID -> Group -> CommandPerform setGroup uuid g = do diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -573,7 +573,7 @@ , ("itemtitle", [youtube_title i]) , ("feedauthor", [youtube_playlist_uploader i]) , ("itemauthor", [youtube_playlist_uploader i]) - -- itemsummary omitted, no equivilant in yt-dlp data + -- itemsummary omitted, no equivalent in yt-dlp data , ("itemdescription", [youtube_description i]) , ("itemrights", [youtube_license i]) , ("itemid", [youtube_url i]) diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011-2023 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,6 +21,7 @@ import Types.ProposedAccepted import Config import Git.Config +import Git.Types import qualified Data.Map as M import qualified Data.Text as T @@ -35,6 +36,7 @@ data InitRemoteOptions = InitRemoteOptions { cmdparams :: CmdParams , sameas :: Maybe (DeferredParse UUID) + , withUrl :: Bool , whatElse :: Bool , privateRemote :: Bool } @@ -44,6 +46,11 @@ <$> cmdParams desc <*> optional parseSameasOption <*> switch + ( long "with-url" + <> short 'u' + <> help "configure remote with an annex:: url" + ) + <*> switch ( long "whatelse" <> short 'w' <> help "describe other configuration parameters for a special remote" @@ -125,10 +132,22 @@ cu <- liftIO genUUID setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu) Logs.Remote.configSet cu c - unless (Remote.gitSyncableRemoteType t) $ + when (withUrl o) $ + setAnnexUrl c + unless (Remote.gitSyncableRemoteType t || withUrl o) $ setConfig (remoteConfig c "skipFetchAll") (boolConfig True) return True +setAnnexUrl :: R.RemoteConfig -> Annex () +setAnnexUrl c = + getConfigMaybe (remoteConfig c "url") >>= \case + Just (ConfigValue _) -> noop + _ -> do + setConfig (remoteConfig c "url") "annex::" + setConfig (remoteConfig c "fetch") $ + "+refs/heads/*:refs/remotes/" ++ + getRemoteName c ++ "/*" + describeOtherParamsFor :: RemoteConfig -> RemoteType -> CommandPerform describeOtherParamsFor c t = do cp <- R.configParser t c @@ -138,6 +157,7 @@ ( maybeAddJSONField "whatelse" $ M.fromList $ mkjson l , liftIO $ forM_ l $ \(p, fd, vd) -> case fd of HiddenField -> return () + DeprecatedField -> return () FieldDesc d -> do putStrLn p putStrLn ("\t" ++ d) @@ -152,6 +172,7 @@ mkjson = mapMaybe $ \(p, fd, vd) -> case fd of HiddenField -> Nothing + DeprecatedField -> Nothing FieldDesc d -> Just ( T.pack p , M.fromList diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -169,7 +169,7 @@ - same key. The method is to compare each value with the value - after it in the list, which is the old version of the value. - - - This ncessarily buffers the whole list, so does not stream. + - This necessarily buffers the whole list, so does not stream. - But, the number of location log changes for a single key tends to be - fairly small. - @@ -377,7 +377,7 @@ -- time across all git-annex repositories. -- -- This combines the new location log with what has been - -- accumulated so far, which is equivilant to merging together + -- accumulated so far, which is equivalent to merging together -- all git-annex branches at that point in time. update k sizemap locmap (oldlog, oldlocs) newlog = ( updatesize (updatesize sizemap sz (S.toList addedlocs)) @@ -490,7 +490,7 @@ posminus a b = max 0 (a - b) - -- A verison of sizemap where uuids that are currently dead + -- A version of sizemap where uuids that are currently dead -- have 0 size. sizemap' = M.mapWithKey zerodead sizemap zerodead u v = case M.lookup u (simpleMap trustlog) of diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -200,7 +200,7 @@ firstM (\f -> (== Just newkey) <$> isAnnexLink f) $ map (\f -> simplifyPath (fromTopFilePath f g)) fs - -- Always verify the content agains the newkey, even if + -- Always verify the content against the newkey, even if -- annex.verify is unset. This is done to prent bad migration -- information maliciously injected into the git-annex branch -- from populating files with the wrong content. diff --git a/Command/SendKey.hs b/Command/SendKey.hs --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -40,7 +40,7 @@ ) where {- No need to do any rollback; when sendAnnex fails, a nonzero - - exit will be propigated, and the remote will know the transfer + - exit will be propagated, and the remote will know the transfer - failed. -} rollback = noop diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -267,8 +267,8 @@ remotes <- syncRemotes (syncWith o) warnSyncContentTransition o remotes - -- Remotes that are git repositories, not (necesarily) special remotes. - let gitremotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) remotes + -- Remotes that git can push to and pull from. + let gitremotes = filter Remote.gitSyncableRemote remotes -- Remotes that contain annex object content. contentremotes <- filter (\r -> Remote.uuid r /= NoUUID) <$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes @@ -978,7 +978,7 @@ seekExportContent o rs (mcurrbranch, madj) | null rs = return False | otherwise = do - -- Propigate commits from the adjusted branch, so that + -- Propagate commits from the adjusted branch, so that -- when the remoteAnnexTrackingBranch is set to the parent -- branch, it will be up-to-date. case (mcurrbranch, madj) of diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -295,7 +295,9 @@ Nothing -> return True Just b -> case Types.Backend.verifyKeyContent b of Nothing -> return True - Just verifier -> verifier k (serializeKey' k) + Just verifier -> do + loc <- Annex.calcRepo (gitAnnexLocation k) + verifier k loc get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2016 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -34,6 +34,7 @@ import Annex.BloomFilter import qualified Database.Keys import Annex.InodeSentinal +import Backend.GitRemoteAnnex (isGitRemoteAnnexKey) import qualified Data.Map as M import qualified Data.ByteString as S @@ -104,7 +105,8 @@ _ <- check "" (remoteUnusedMsg r remotename) (remoteunused u) 0 next $ return True remoteunused u = loggedKeysFor u >>= \case - Just ks -> excludeReferenced refspec ks + Just ks -> filter (not . isGitRemoteAnnexKey u) + <$> excludeReferenced refspec ks Nothing -> giveup "This repository is read-only." check :: String -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int diff --git a/Database/Handle.hs b/Database/Handle.hs --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -70,7 +70,7 @@ - changes to the database! - - Note that the action is not run by the calling thread, but by a - - worker thread. Exceptions are propigated to the calling thread. + - worker thread. Exceptions are propagated to the calling thread. - - Only one action can be run at a time against a given DbHandle. - If called concurrently in the same process, this will block until diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -491,7 +491,7 @@ -- How large is large? Too large and there will be a long -- delay before the message is shown; too short and the message - -- will clutter things up unncessarily. It's uncommon for 1000 + -- will clutter things up unnecessarily. It's uncommon for 1000 -- files to change in the index, and processing that many files -- takes less than half a second, so that seems about right. largediff :: Int diff --git a/Git.hs b/Git.hs --- a/Git.hs +++ b/Git.hs @@ -167,7 +167,7 @@ p' <- relPathCwdToFile p return $ if B.null p' then "." else p' -{- Adusts the path to a local Repo using the provided function. -} +{- Adjusts the path to a local Repo using the provided function. -} adjustPath :: (RawFilePath -> IO RawFilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do d' <- f d diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -40,15 +40,19 @@ {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine' <$> pipeReadStrict - [ Param "symbolic-ref" - , Param "-q" - , Param $ fromRef Git.Ref.headRef - ] r +currentUnsafe r = withNullHandle $ \nullh -> + parse . firstLine' <$> pipeReadStrict' + (\p -> p { std_err = UseHandle nullh }) + ps r where parse b | B.null b = Nothing | otherwise = Just $ Git.Ref b + ps = + [ Param "symbolic-ref" + , Param "-q" + , Param $ fromRef Git.Ref.headRef + ] {- Checks if the second branch has any commits not present on the first - branch. -} diff --git a/Git/Bundle.hs b/Git/Bundle.hs new file mode 100644 --- /dev/null +++ b/Git/Bundle.hs @@ -0,0 +1,68 @@ +{- git bundles + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Git.Bundle where + +import Common +import Git +import Git.Command + +import Data.Char (ord) +import qualified Data.ByteString.Char8 as S8 + +listHeads :: FilePath -> Repo -> IO [(Sha, Ref)] +listHeads bundle repo = map gen . S8.lines <$> + pipeReadStrict [Param "bundle", Param "list-heads", File bundle] repo + where + gen l = let (s, r) = separate' (== fromIntegral (ord ' ')) l + in (Ref s, Ref r) + +unbundle :: FilePath -> Repo -> IO () +unbundle bundle = runQuiet [Param "bundle", Param "unbundle", File bundle] + +-- Specifies what to include in the bundle. +data BundleSpec = BundleSpec + { preRequisiteRef :: Maybe Ref + -- ^ Do not include this Ref, or any objects reachable from it + -- in the bundle. This should be an ancestor of the includeRef. + , includeRef :: Ref + -- ^ Include this Ref and objects reachable from it in the bundle, + -- unless filtered out by the preRequisiteRef of this BundleSpec + -- or any other one that is included in the bundle. + } + deriving (Show) + +-- Include the ref and all objects reachable from it in the bundle. +-- (Unless another BundleSpec is included that has a preRequisiteRef +-- that filters out the ref or other objects.) +fullBundleSpec :: Ref -> BundleSpec +fullBundleSpec r = BundleSpec + { preRequisiteRef = Nothing + , includeRef = r + } + +create :: FilePath -> [BundleSpec] -> Repo -> IO () +create bundle revs repo = pipeWrite + [ Param "bundle" + , Param "create" + , Param "--quiet" + , File bundle + , Param "--stdin" + ] repo writer + where + writer h = do + forM_ revs $ \bs -> + case preRequisiteRef bs of + Nothing -> S8.hPutStrLn h $ + fromRef' (includeRef bs) + Just pr -> S8.hPutStrLn h $ + fromRef' pr + <> ".." <> + fromRef' (includeRef bs) + hClose h diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -125,7 +125,7 @@ knownMissing FsckFailed = S.empty knownMissing (FsckFoundMissing s _) = s -{- Finds objects that are missing from the git repsitory, or are corrupt. +{- Finds objects that are missing from the git repository, or are corrupt. - - This does not use git cat-file --batch, because catting a corrupt - object can cause it to crash, or to report incorrect size information. diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,6 +1,6 @@ {- git ref stuff - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -165,8 +165,18 @@ list :: Repo -> IO [(Sha, Ref)] list = matching' [] [] -{- Deletes a ref. This can delete refs that are not branches, - - which git branch --delete refuses to delete. -} +{- Lists refs using for-each-ref. -} +forEachRef :: [CommandParam] -> Repo -> IO [(Sha, Branch)] +forEachRef ps repo = map gen . S8.lines <$> + pipeReadStrict (Param "for-each-ref" : ps ++ [format]) repo + where + format = Param "--format=%(objectname) %(refname)" + gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l + in (Ref r, Ref b) + +{- Deletes a ref when it contains the specified sha. + - This can delete refs that are not branches, which + - git branch --delete refuses to delete. -} delete :: Sha -> Ref -> Repo -> IO () delete oldvalue ref = run [ Param "update-ref" @@ -175,6 +185,14 @@ , Param $ fromRef oldvalue ] +{- Deletes a ref no matter what it contains. -} +delete' :: Ref -> Repo -> IO () +delete' ref = run + [ Param "update-ref" + , Param "-d" + , Param $ fromRef ref + ] + {- Gets the sha of the tree a ref uses. - - The ref may be something like a branch name, and it could contain @@ -191,6 +209,19 @@ then ref -- de-reference commit objects to the tree else ref <> ":" + +{- Check if the first ref is an ancestor of the second ref. + - + - Note that if the two refs point to the same commit, it is considered + - to be an ancestor of itself. + -} +isAncestor :: Ref -> Ref -> Repo -> IO Bool +isAncestor r1 r2 = runBool + [ Param "merge-base" + , Param "--is-ancestor" + , Param (fromRef r1) + , Param (fromRef r2) + ] {- Checks if a String is a legal git ref name. - diff --git a/Git/Remote.hs b/Git/Remote.hs --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -1,6 +1,6 @@ {- git remote stuff - - - Copyright 2012-2021 Joey Hess + - Copyright 2012-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -13,6 +13,7 @@ import Common import Git import Git.Types +import Git.Command import Data.Char import qualified Data.Map as M @@ -22,6 +23,11 @@ #ifdef mingw32_HOST_OS import Git.FilePath #endif + +{- Lists all currently existing git remotes. -} +listRemotes :: Repo -> IO [RemoteName] +listRemotes repo = map decodeBS . S8.lines + <$> pipeReadStrict [Param "remote"] repo {- Is a git config key one that specifies the url of a remote? -} isRemoteUrlKey :: ConfigKey -> Bool diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -29,4 +29,4 @@ older :: String -> IO Bool older n = do v <- installed - return $ v < normalize n + return $ v < normalize n diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -211,7 +211,7 @@ chunkLogExt :: S.ByteString chunkLogExt = ".log.cnk" -{- The filename of the equivilant keys log for a given key. -} +{- The filename of the equivalent keys log for a given key. -} equivilantKeysLogFile :: GitConfig -> Key -> RawFilePath equivilantKeysLogFile config key = (branchHashDir config key P. keyFile key) diff --git a/Logs/EquivilantKeys.hs b/Logs/EquivilantKeys.hs --- a/Logs/EquivilantKeys.hs +++ b/Logs/EquivilantKeys.hs @@ -1,4 +1,4 @@ -{- Logs listing keys that are equivilant to a key. +{- Logs listing keys that are equivalent to a key. - - Copyright 2024 Joey Hess - diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -267,7 +267,7 @@ hSetBuffering stderr LineBuffering #ifdef mingw32_HOST_OS {- Avoid outputting CR at end of line on Windows. git commands do - - not ouput CR there. -} + - not output CR there. -} hSetNewlineMode stdout noNewlineTranslation hSetNewlineMode stderr noNewlineTranslation #endif @@ -353,7 +353,7 @@ (const $ run a) {- Catch all (non-async and not ExitCode) exceptions and display, - - santizing any control characters in the exceptions. + - sanitizing any control characters in the exceptions. - - Exits nonzero on exception, so should only be used at topmost level. -} diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -26,7 +26,6 @@ remoteTypes, remoteList, remoteList', - gitSyncableRemoteType, remoteMap, remoteMap', uuidDescriptions, @@ -61,6 +60,8 @@ claimingUrl, claimingUrl', isExportSupported, + gitSyncableRemote, + gitSyncableRemoteType, ) where import Data.Ord @@ -445,3 +446,12 @@ fromMaybe web <$> firstM checkclaim (filter remotefilter rs) where checkclaim = maybe (pure False) (`id` url) . claimUrl + +{- Is this a remote of a type we can sync with, or a special remote + - with an annex:: url configured? -} +gitSyncableRemote :: Remote -> Bool +gitSyncableRemote r + | gitSyncableRemoteType (remotetype r) = True + | otherwise = case remoteUrl (gitconfig r) of + Just u | "annex::" `isPrefixOf` u -> True + _ -> False diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -348,7 +348,7 @@ mk _ = Nothing -- This does not guard against every possible race. As long as the adb --- connection is resonably fast, it's probably as good as +-- connection is reasonably fast, it's probably as good as -- git's handling of similar situations with files being modified while -- it's updating the working tree for a merge. retrieveExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -413,7 +413,7 @@ -- Since ignoreinodes can be changed by enableremote, and since previous -- versions of git-annex ignored inodes by default, treat two content --- idenfiers as the same if they differ only by one having the inode +-- identifiers as the same if they differ only by one having the inode -- ignored. guardSameContentIdentifiers :: a -> [ContentIdentifier] -> Maybe ContentIdentifier -> a guardSameContentIdentifiers _ _ Nothing = giveup "file not found" diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -92,7 +92,7 @@ list autoinit = do c <- fromRepo Git.config rs <- mapM (tweakurl c) =<< Annex.getGitRemotes - mapM (configRead autoinit) rs + mapM (configRead autoinit) (filter (not . isGitRemoteAnnex) rs) where annexurl r = remoteConfig r "annexurl" tweakurl c r = do @@ -102,6 +102,9 @@ Just url -> inRepo $ \g -> Git.Construct.remoteNamed n $ Git.Construct.fromRemoteLocation (Git.fromConfigValue url) False g + +isGitRemoteAnnex :: Git.Repo -> Bool +isGitRemoteAnnex r = "annex::" `isPrefixOf` Git.repoLocation r {- Git remotes are normally set up using standard git commands, not - git-annex initremote and enableremote. diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -58,7 +58,7 @@ chunkConfigParsers :: [RemoteConfigFieldParser] chunkConfigParsers = - [ optionalStringParser chunksizeField HiddenField -- deprecated + [ optionalStringParser chunksizeField DeprecatedField , optionalStringParser chunkField (FieldDesc "size of chunks (eg, 1MiB)") ] diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -14,6 +14,7 @@ encryptionAlreadySetup, encryptionConfigParsers, parseEncryptionConfig, + parseEncryptionMethod, remoteCipher, remoteCipher', embedCreds, @@ -85,7 +86,7 @@ encryptionFieldParser = RemoteConfigFieldParser { parserForField = encryptionField , valueParser = \v c -> Just . RemoteConfigValue - <$> parseEncryptionMethod (fmap fromProposedAccepted v) c + <$> parseEncryptionMethod' v c , fieldDesc = FieldDesc "how to encrypt data stored in the special remote" , valueDesc = Just $ ValueDesc $ intercalate " or " (M.keys encryptionMethods) @@ -100,14 +101,18 @@ , ("sharedpubkey", SharedPubKeyEncryption) ] -parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod -parseEncryptionMethod (Just s) _ = case M.lookup s encryptionMethods of - Just em -> Right em - Nothing -> Left badEncryptionMethod +parseEncryptionMethod :: RemoteConfig -> Either String EncryptionMethod +parseEncryptionMethod c = parseEncryptionMethod' (M.lookup encryptionField c) c + +parseEncryptionMethod' :: Maybe (ProposedAccepted String) -> RemoteConfig -> Either String EncryptionMethod +parseEncryptionMethod' (Just s) _ = + case M.lookup (fromProposedAccepted s) encryptionMethods of + Just em -> Right em + Nothing -> Left badEncryptionMethod -- Hybrid encryption is the default when a keyid is specified without -- an encryption field, or when there's a cipher already but no encryption -- field. -parseEncryptionMethod Nothing c +parseEncryptionMethod' Nothing c | M.member (Accepted "keyid") c || M.member cipherField c = Right HybridEncryption | otherwise = Left badEncryptionMethod @@ -162,7 +167,7 @@ maybe (genCipher pc gpgcmd) (updateCipher pc gpgcmd) (extractCipher pc) where -- The type of encryption - encryption = parseEncryptionMethod (fromProposedAccepted <$> M.lookup encryptionField c) c + encryption = parseEncryptionMethod c -- Generate a new cipher, depending on the chosen encryption scheme genCipher pc gpgcmd = case encryption of Right NoneEncryption -> return (c, NoEncryption) diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -87,12 +87,20 @@ {- Generates a Remote. -} remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe Remote) -remoteGen m t g = do +remoteGen = remoteGen' id + +remoteGen' + :: (RemoteConfig -> RemoteConfig) + -> M.Map UUID RemoteConfig + -> RemoteType + -> Git.Repo + -> Annex (Maybe Remote) +remoteGen' adjustconfig m t g = do u <- getRepoUUID g gc <- Annex.getRemoteGitConfig g let cu = fromMaybe u $ remoteAnnexConfigUUID gc let rs = RemoteStateHandle cu - let c = fromMaybe M.empty $ M.lookup cu m + let c = adjustconfig (fromMaybe M.empty $ M.lookup cu m) generate t g u c gc rs >>= \case Nothing -> return Nothing Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs @@ -109,7 +117,11 @@ Remote.Git.configRead False r | otherwise = return r -{- Checks if a remote is syncable using git. -} +{- Types of remotes that are always syncable using git. + - + - This does not include special remotes that may or may not have an + - annex:: url that allows using git-remote-annex with them. + -} gitSyncableRemoteType :: RemoteType -> Bool gitSyncableRemoteType t = t `elem` [ Remote.Git.remote diff --git a/Types/BranchState.hs b/Types/BranchState.hs --- a/Types/BranchState.hs +++ b/Types/BranchState.hs @@ -36,7 +36,10 @@ -- process need to be noticed while the current process is running? -- (This makes the journal always be read, and avoids using the -- cache.) + , alternateJournal :: Maybe RawFilePath + -- ^ use this directory for all journals, rather than the + -- gitAnnexJournalDir and gitAnnexPrivateJournalDir. } startBranchState :: BranchState -startBranchState = BranchState False False False [] [] [] False +startBranchState = BranchState False False False [] [] [] False Nothing diff --git a/Types/Difference.hs b/Types/Difference.hs --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -17,6 +17,7 @@ differenceConfigVal, hasDifference, listDifferences, + mkDifferences, ) where import Utility.PartialPrelude diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -373,6 +373,9 @@ , remoteAnnexBwLimitDownload :: Maybe BwRate , remoteAnnexAllowUnverifiedDownloads :: Bool , remoteAnnexConfigUUID :: Maybe UUID + , remoteAnnexMaxGitBundles :: Int + , remoteAnnexAllowEncryptedGitRepo :: Bool + , remoteUrl :: Maybe String {- These settings are specific to particular types of remotes - including special remotes. -} @@ -430,7 +433,8 @@ , remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel" , remoteAnnexStartCommand = notempty $ getmaybe "start-command" , remoteAnnexStopCommand = notempty $ getmaybe "stop-command" - , remoteAnnexSpeculatePresent = getbool "speculate-present" False + , remoteAnnexSpeculatePresent = + getbool "speculate-present" False , remoteAnnexBare = getmaybebool "bare" , remoteAnnexRetry = getmayberead "retry" , remoteAnnexForwardRetry = getmayberead "forward-retry" @@ -450,6 +454,8 @@ readBwRatePerSecond =<< getmaybe "bwlimit-download" , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe ("security-allow-unverified-downloads") + , remoteAnnexMaxGitBundles = + fromMaybe 100 (getmayberead "max-git-bundles") , remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid" , remoteAnnexShell = getmaybe "shell" , remoteAnnexSshOptions = getoptions "ssh-options" @@ -476,6 +482,14 @@ , remoteAnnexDdarRepo = getmaybe "ddarrepo" , remoteAnnexHookType = notempty $ getmaybe "hooktype" , remoteAnnexExternalType = notempty $ getmaybe "externaltype" + , remoteAnnexAllowEncryptedGitRepo = + getbool "allow-encrypted-gitrepo" False + , remoteUrl = + case Git.Config.getMaybe (remoteConfig remotename "url") r of + Just (ConfigValue b) + | B.null b -> Nothing + | otherwise -> Just (decodeBS b) + _ -> Nothing } where getbool k d = fromMaybe d $ getmaybebool k diff --git a/Types/GitRemoteAnnex.hs b/Types/GitRemoteAnnex.hs new file mode 100644 --- /dev/null +++ b/Types/GitRemoteAnnex.hs @@ -0,0 +1,45 @@ +{- git-remote-annex types + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.GitRemoteAnnex + ( Manifest + , mkManifest + , inManifest + , outManifest + ) where + +import Types.Key + +import qualified Data.Semigroup as Sem +import qualified Data.Set as S + +-- The manifest contains an ordered list of git bundle keys. +-- +-- There is a second list of git bundle keys that are no longer +-- used and should be deleted. This list should never contain keys +-- that are in the first list. +data Manifest = + Manifest + { inManifest :: [Key] + , outManifest :: S.Set Key + } + deriving (Show) + +-- Smart constructor for Manifest. Preserves outManifest invariant. +mkManifest + :: [Key] -- ^ inManifest + -> S.Set Key -- ^ outManifest + -> Manifest +mkManifest inks outks = Manifest inks (S.filter (`notElem` inks) outks) + +instance Monoid Manifest where + mempty = Manifest mempty mempty + +instance Sem.Semigroup Manifest where + a <> b = mkManifest + (inManifest a <> inManifest b) + (S.union (outManifest a) (outManifest b)) diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -60,7 +60,7 @@ instance NFData KeyData -{- Caching the seralization of a key is an optimization. +{- Caching the serialization of a key is an optimization. - - This constructor is not exported, and all smart constructors maintain - the serialization. @@ -219,6 +219,8 @@ | WORMKey | URLKey | VURLKey + | GitBundleKey + | GitManifestKey -- A key that is handled by some external backend. | ExternalKey S.ByteString HasExt -- Some repositories may contain keys of other varieties, @@ -253,6 +255,8 @@ hasExt WORMKey = False hasExt URLKey = False hasExt VURLKey = False +hasExt GitBundleKey = False +hasExt GitManifestKey = False hasExt (ExternalKey _ (HasExt b)) = b hasExt (OtherKey s) = (snd <$> S8.unsnoc s) == Just 'E' @@ -282,6 +286,8 @@ WORMKey -> "WORM" URLKey -> "URL" VURLKey -> "VURL" + GitBundleKey -> "GITBUNDLE" + GitManifestKey -> "GITMANIFEST" ExternalKey s e -> adde e ("X" <> s) OtherKey s -> s where @@ -347,6 +353,7 @@ parseKeyVariety "WORM" = WORMKey parseKeyVariety "URL" = URLKey parseKeyVariety "VURL" = VURLKey +parseKeyVariety "GITBUNDLE" = GitBundleKey parseKeyVariety b | "X" `S.isPrefixOf` b = let b' = S.tail b diff --git a/Types/RemoteConfig.hs b/Types/RemoteConfig.hs --- a/Types/RemoteConfig.hs +++ b/Types/RemoteConfig.hs @@ -51,6 +51,8 @@ data FieldDesc = FieldDesc String | HiddenField + | DeprecatedField + deriving (Eq) newtype ValueDesc = ValueDesc String diff --git a/Types/StallDetection.hs b/Types/StallDetection.hs --- a/Types/StallDetection.hs +++ b/Types/StallDetection.hs @@ -27,9 +27,9 @@ -- Parse eg, "0KiB/60s" -- --- Also, it can be set to "true" (or other git config equivilants) +-- Also, it can be set to "true" (or other git config equivalents) -- to enable ProbeStallDetection. --- And "false" (and other git config equivilants) explicitly +-- And "false" (and other git config equivalents) explicitly -- disable stall detection. parseStallDetection :: String -> Either String StallDetection parseStallDetection s = case isTrueFalse s of diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -69,7 +69,7 @@ boolGpgCmd :: GpgCmd -> [CommandParam] -> IO Bool boolGpgCmd (GpgCmd cmd) = boolSystem cmd --- Generate an argument list to asymetrically encrypt to the given recipients. +-- Generate an argument list to asymmetrically encrypt to the given recipients. pkEncTo :: [String] -> [CommandParam] pkEncTo = concatMap (\r -> [Param "--recipient", Param r]) diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -253,7 +253,7 @@ go (MatchedOpen:rest) = "(" : go rest go (MatchedClose:rest) = ")" : go rest - -- Remove unncessary outermost parens + -- Remove unnecessary outermost parens simplify True (MatchedOpen:rest) = case lastMaybe rest of Just MatchedClose -> simplify False (dropFromEnd 1 rest) _ -> simplify False rest diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -48,7 +48,7 @@ - already exists. -} absPath :: RawFilePath -> IO RawFilePath absPath file - -- Avoid unncessarily getting the current directory when the path + -- Avoid unnecessarily getting the current directory when the path -- is already absolute. absPathFrom uses simplifyPath -- so also used here for consistency. | isAbsolute file = return $ simplifyPath file diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -32,7 +32,7 @@ - characters, except for ones in surrogate plane. Converting a string that - does contain other unicode characters to a ByteString using the - filesystem encoding (see GHC.IO.Encoding) will throw an exception, - - so use this instead to avoid quickcheck tests breaking unncessarily. + - so use this instead to avoid quickcheck tests breaking unnecessarily. -} newtype TestableString = TestableString { fromTestableString :: String } @@ -46,7 +46,7 @@ - - No real-world filename can be empty or contain a NUL. So code can - well be written that assumes that and using this avoids quickcheck - - tests breaking unncessarily. + - tests breaking unnecessarily. -} newtype TestableFilePath = TestableFilePath { fromTestableFilePath :: FilePath } diff --git a/Utility/StatelessOpenPGP.hs b/Utility/StatelessOpenPGP.hs --- a/Utility/StatelessOpenPGP.hs +++ b/Utility/StatelessOpenPGP.hs @@ -58,7 +58,7 @@ - This is unfortunately needed because of an infelicity in the SOP - standard, as documented in section 9.9 "Be Careful with Special - Designators", when using "@FD:" and similar designators the SOP - - command may test for the presense of a file with the same name on the + - command may test for the presence of a file with the same name on the - filesystem, and fail with AMBIGUOUS_INPUT. - - Since we don't want to need to deal with such random failure due to diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20240430 +Version: 10.20240531 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -580,6 +580,7 @@ Author Backend Backend.External + Backend.GitRemoteAnnex Backend.Hash Backend.URL Backend.Utilities @@ -606,6 +607,7 @@ CmdLine.GitAnnexShell.Fields CmdLine.AnnexSetter CmdLine.Option + CmdLine.GitRemoteAnnex CmdLine.GitRemoteTorAnnex CmdLine.Seek CmdLine.Usage @@ -758,6 +760,7 @@ Git.AutoCorrect Git.Branch Git.BuildVersion + Git.Bundle Git.CatFile Git.CheckAttr Git.CheckIgnore @@ -939,6 +942,7 @@ Types.Export Types.FileMatcher Types.GitConfig + Types.GitRemoteAnnex Types.Group Types.Import Types.IndexFiles diff --git a/git-annex.hs b/git-annex.hs --- a/git-annex.hs +++ b/git-annex.hs @@ -1,6 +1,6 @@ {- git-annex main program dispatch - - - Copyright 2010-2016 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -13,6 +13,7 @@ import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnexShell +import qualified CmdLine.GitRemoteAnnex import qualified CmdLine.GitRemoteTorAnnex import qualified Test import qualified Benchmark @@ -35,6 +36,7 @@ where run ps n = case takeFileName n of "git-annex-shell" -> CmdLine.GitAnnexShell.run ps + "git-remote-annex" -> CmdLine.GitRemoteAnnex.run ps "git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps _ -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps