git-annex 10.20250630 → 10.20250721
raw patch · 23 files changed
+362/−141 lines, 23 files
Files
- Annex.hs +6/−2
- Annex/FileMatcher.hs +2/−1
- Annex/Fixup.hs +46/−32
- Annex/Link.hs +3/−2
- Annex/Locations.hs +78/−40
- Assistant/Repair.hs +1/−1
- CHANGELOG +21/−0
- CmdLine/GitAnnex/Options.hs +5/−0
- CmdLine/GitRemoteAnnex.hs +2/−1
- Command/Fsck.hs +40/−2
- Command/P2P.hs +15/−11
- Command/P2PHttp.hs +45/−6
- Database/Keys.hs +24/−23
- Git/Construct.hs +1/−0
- Git/Types.hs +3/−0
- Limit.hs +21/−0
- P2P/Auth.hs +36/−11
- P2P/IO.hs +0/−1
- Remote/GCrypt.hs +3/−2
- Remote/Git.hs +4/−2
- RemoteDaemon/Transport/Tor.hs +1/−1
- Test/Framework.hs +4/−2
- git-annex.cabal +1/−1
Annex.hs view
@@ -12,6 +12,7 @@ AnnexState(..), AnnexRead(..), new,+ new', run, eval, makeRunner,@@ -291,10 +292,13 @@ - Ensures the config is read, if it was not already, and performs - any necessary git repo fixups. -} new :: Git.Repo -> IO (AnnexState, AnnexRead)-new r = do+new = new' fixupRepo++new' :: (Git.Repo -> GitConfig -> IO Git.Repo) -> Git.Repo -> IO (AnnexState, AnnexRead)+new' f r = do r' <- Git.Config.read r let c = extractGitConfig FromGitConfig r'- st <- newAnnexState c =<< fixupRepo r' c+ st <- newAnnexState c =<< f r' c rd <- newAnnexRead c return (st, rd)
Annex/FileMatcher.hs view
@@ -1,6 +1,6 @@ {- git-annex file matching -- - Copyright 2012-2024 Joey Hess <id@joeyh.name>+ - Copyright 2012-2025 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -194,6 +194,7 @@ , ValueToken "approxlackingcopies" (usev $ limitLackingCopies "approxlackingcopies" True) , ValueToken "inbackend" (usev limitInBackend) , ValueToken "metadata" (usev limitMetaData)+ , ValueToken "url" (usev limitUrl) , ValueToken "inallgroup" (usev $ limitInAllGroup $ getGroupMap pcd) , ValueToken "onlyingroup" (usev $ limitOnlyInGroup $ getGroupMap pcd) , ValueToken "balanced" (usev $ limitBalanced (repoUUID pcd) (getGroupMap pcd))
Annex/Fixup.hs view
@@ -69,9 +69,14 @@ - whether a repo is used as a submodule or not, and wheverever the - submodule is mounted. -- - git-worktree directories have a .git file.- - That needs to be converted to a symlink, and .git/annex made a symlink- - to the main repository's git-annex directory.+ - git-worktree directories have a .git file which points to a different+ - git directory than the main git directory. That needs to be converted to+ - a symlink, and .git/annex made a symlink to the main repository's + - git-annex directory so that annex symlinks in the git repository point+ - to the object files. When the filesystem does not support symlinks, the+ - mainWorkTreePath of the repository is set, so that the git-annex+ - directory of the main repository will still be used.+ - - The worktree shares git config with the main repository, so the same - annex uuid and other configuration will be used in the worktree as in - the main repository.@@ -85,26 +90,32 @@ - unlocked branches. - - Don't do any of this if the repo has not been initialized for git-annex- - use yet.+ - use yet. Except, do set mainWorkTreePath. -} fixupUnusualRepos :: Repo -> GitConfig -> IO Repo-fixupUnusualRepos r@(Repo { location = l@(Local { worktree = Just w, gitdir = d }) }) c- | isNothing (annexVersion c) = return r+fixupUnusualRepos r@(Repo { location = Local { worktree = Just w, gitdir = d } }) c+ | isNothing (annexVersion c) =+ ifM (needsGitLinkFixup r)+ ( setworktreepath r+ , return r+ ) | needsSubmoduleFixup r = do when (coreSymlinks c) $ (replacedotgit >> unsetcoreworktree) `catchNonAsync` \e -> hPutStrLn stderr $ "warning: unable to convert submodule to form that will work with git-annex: " ++ show e- return $ r'+ return $ r { config = M.delete "core.worktree" (config r) } | otherwise = ifM (needsGitLinkFixup r) ( do- when (coreSymlinks c) $- (replacedotgit >> worktreefixup)- `catchNonAsync` \e -> hPutStrLn stderr $- "warning: unable to convert .git file to symlink that will work with git-annex: " ++ show e- return r'+ if coreSymlinks c+ then do+ (replacedotgit >> worktreefixup)+ `catchNonAsync` \e -> hPutStrLn stderr $+ "warning: unable to convert .git file to symlink that will work with git-annex: " ++ show e+ setworktreepath r+ else setworktreepath r , return r ) where@@ -117,28 +128,31 @@ -- Unsetting a config fails if it's not set, so ignore failure. unsetcoreworktree = void $ Git.Config.unset "core.worktree" r+ + -- git-worktree sets up a "commondir" file that contains+ -- the path to the main git directory.+ -- Using --separate-git-dir does not.+ commondirfile = fromOsPath (d </> literalOsPath "commondir") - worktreefixup = do- -- git-worktree sets up a "commondir" file that contains- -- the path to the main git directory.- -- Using --separate-git-dir does not.- let commondirfile = fromOsPath (d </> literalOsPath "commondir")- catchDefaultIO Nothing (headMaybe . lines <$> readFile commondirfile) >>= \case- Just gd -> do- -- Make the worktree's git directory- -- contain an annex symlink to the main- -- repository's annex directory.- let linktarget = toOsPath gd </> literalOsPath "annex"- R.createSymbolicLink (fromOsPath linktarget) $- fromOsPath $ dotgit </> literalOsPath "annex"- Nothing -> return ()+ readcommondirfile = catchDefaultIO Nothing $+ fmap toOsPath . headMaybe . lines+ <$> readFile commondirfile - -- Repo adjusted, so that symlinks to objects that get checked- -- in will have the usual path, rather than pointing off to the- -- real .git directory.- r'- | coreSymlinks c = r { location = l { gitdir = dotgit } }- | otherwise = r+ setworktreepath r' = readcommondirfile >>= \case+ Just gd -> return $ r'+ { mainWorkTreePath = Just gd+ }+ Nothing -> return r'++ worktreefixup = readcommondirfile >>= \case+ Just gd -> do+ -- Make the worktree's git directory+ -- contain an annex symlink to the main+ -- repository's annex directory.+ let linktarget = gd </> literalOsPath "annex"+ R.createSymbolicLink (fromOsPath linktarget) $+ fromOsPath $ dotgit </> literalOsPath "annex"+ Nothing -> return () fixupUnusualRepos r _ = return r needsSubmoduleFixup :: Repo -> Bool
Annex/Link.hs view
@@ -407,7 +407,8 @@ formatPointer :: Key -> S.ByteString formatPointer k = fromOsPath prefix <> fromOsPath (keyFile k) <> nl where- prefix = toInternalGitPath $ pathSeparator `OS.cons` objectDir+ prefix = toInternalGitPath $+ pathSeparator `OS.cons` objectDir standardGitLocationMaker nl = S8.singleton '\n' {- Maximum size of a file that could be a pointer to a key.@@ -475,7 +476,7 @@ #endif where s' = toOsPath s- p = pathSeparator `OS.cons` objectDir+ p = pathSeparator `OS.cons` objectDir standardGitLocationMaker #ifdef mingw32_HOST_OS p' = toInternalGitPath p #endif
Annex/Locations.hs view
@@ -1,6 +1,6 @@ {- git-annex file locations -- - Copyright 2010-2024 Joey Hess <id@joeyh.name>+ - Copyright 2010-2025 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -9,6 +9,9 @@ {-# LANGUAGE CPP #-} module Annex.Locations (+ GitLocationMaker(..),+ standardGitLocationMaker,+ repoGitLocationMaker, keyFile, fileKey, keyPaths,@@ -136,6 +139,24 @@ import Annex.DirHashes import Annex.Fixup +{- When constructing a path that is usually relative to the+ - .git directory, this can be used to relocate the path to+ - elsewhere.+ -+ - This is used when in a linked git worktree, which has its own+ - git directory, to make the git-annex directory be located in the+ - git directory of the main worktree.+ -}+newtype GitLocationMaker = GitLocationMaker (OsPath -> OsPath)++standardGitLocationMaker :: GitLocationMaker+standardGitLocationMaker = GitLocationMaker id++repoGitLocationMaker :: Git.Repo -> GitLocationMaker+repoGitLocationMaker r = case Git.mainWorkTreePath r of+ Nothing -> standardGitLocationMaker+ Just p -> GitLocationMaker (p </>)+ {- Conventions: - - Functions ending in "Dir" should always return values ending with a@@ -151,38 +172,42 @@ {- The directory git annex uses for local state, relative to the .git - directory -}-annexDir :: OsPath-annexDir = addTrailingPathSeparator (literalOsPath "annex")+annexDir :: GitLocationMaker -> OsPath+annexDir (GitLocationMaker glm) = addTrailingPathSeparator $+ glm $ literalOsPath "annex" {- The directory git annex uses for locally available object content, - relative to the .git directory -}-objectDir :: OsPath-objectDir = addTrailingPathSeparator $ annexDir </> literalOsPath "objects"+objectDir :: GitLocationMaker -> OsPath+objectDir glm = addTrailingPathSeparator $+ annexDir glm </> literalOsPath "objects" {- Annexed file's possible locations relative to the .git directory- - in a non-bare eepository.+ - in a non-bare repository. - - Normally it is hashDirMixed. However, it's always possible that a - bare repository was converted to non-bare, or that the cripped - filesystem setting changed, so still need to check both. -}-annexLocationsNonBare :: GitConfig -> Key -> [OsPath]-annexLocationsNonBare config key = - map (annexLocation config key) [hashDirMixed, hashDirLower]+annexLocationsNonBare :: GitLocationMaker -> GitConfig -> Key -> [OsPath]+annexLocationsNonBare glm config key = + map (annexLocation glm config key) [hashDirMixed, hashDirLower] {- Annexed file's possible locations relative to a bare repository. -}-annexLocationsBare :: GitConfig -> Key -> [OsPath]-annexLocationsBare config key = - map (annexLocation config key) [hashDirLower, hashDirMixed]+annexLocationsBare :: GitLocationMaker -> GitConfig -> Key -> [OsPath]+annexLocationsBare glm config key = + map (annexLocation glm config key) [hashDirLower, hashDirMixed] -annexLocation :: GitConfig -> Key -> (HashLevels -> Hasher) -> OsPath-annexLocation config key hasher = objectDir </> keyPath key (hasher $ objectHashLevels config)+annexLocation :: GitLocationMaker -> GitConfig -> Key -> (HashLevels -> Hasher) -> OsPath+annexLocation glm config key hasher = + objectDir glm </> keyPath key (hasher $ objectHashLevels config) {- For exportree remotes with annexobjects=true, objects are stored - in this location as well as in the exported tree. -} exportAnnexObjectLocation :: GitConfig -> Key -> ExportLocation exportAnnexObjectLocation gc k = mkExportLocation $- literalOsPath ".git" </> annexLocation gc k hashDirLower+ literalOsPath ".git" + </> annexLocation standardGitLocationMaker gc k hashDirLower {- Number of subdirectories from the gitAnnexObjectDir - to the gitAnnexLocation. -}@@ -203,14 +228,17 @@ gitAnnexLocation = gitAnnexLocation' doesPathExist gitAnnexLocation' :: (OsPath -> IO Bool) -> Key -> Git.Repo -> GitConfig -> IO OsPath-gitAnnexLocation' checker key r config = gitAnnexLocation'' key r config- (annexCrippledFileSystem config)- (coreSymlinks config)- checker- (Git.localGitDir r)+gitAnnexLocation' checker key r config = + gitAnnexLocation'' key glm r config+ (annexCrippledFileSystem config)+ (coreSymlinks config)+ checker+ (Git.localGitDir r)+ where+ glm = repoGitLocationMaker r -gitAnnexLocation'' :: Key -> Git.Repo -> GitConfig -> Bool -> Bool -> (OsPath -> IO Bool) -> OsPath -> IO OsPath-gitAnnexLocation'' key r config crippled symlinkssupported checker gitdir+gitAnnexLocation'' :: Key -> GitLocationMaker -> Git.Repo -> GitConfig -> Bool -> Bool -> (OsPath -> IO Bool) -> OsPath -> IO OsPath+gitAnnexLocation'' key glm r config crippled symlinkssupported checker gitdir {- Bare repositories default to hashDirLower for new - content, as it's more portable. But check all locations. -} | Git.repoIsLocalBare r = checkall annexLocationsBare@@ -225,8 +253,8 @@ else checkall annexLocationsBare | otherwise = checkall annexLocationsNonBare where- only = return . inrepo . annexLocation config key- checkall f = check $ map inrepo $ f config key+ only = return . inrepo . annexLocation glm config key+ checkall f = check $ map inrepo $ f glm config key inrepo d = gitdir </> d check locs@(l:_) = fromMaybe l <$> firstM checker locs@@ -238,14 +266,14 @@ currdir <- getCurrentDirectory let absfile = absNormPathUnix currdir file let gitdir = getgitdir currdir- loc <- gitAnnexLocation'' key r config False False (\_ -> return True) gitdir+ loc <- gitAnnexLocation'' key standardGitLocationMaker r config False False (\_ -> return True) gitdir toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc where getgitdir currdir- {- This special case is for git submodules on filesystems not- - supporting symlinks; generate link target that will- - work portably. -}- | not (coreSymlinks config) && needsSubmoduleFixup r =+ {- This special case is for git submodules and worktrees+ - on filesystems not supporting symlinks; generate link+ - target that will work portably. -}+ | not (coreSymlinks config) && (needsSubmoduleFixup r || isJust (Git.mainWorkTreePath r)) = absNormPathUnix currdir (Git.repoPath r </> literalOsPath ".git") | otherwise = Git.localGitDir r absNormPathUnix d p = toInternalGitPath $@@ -299,16 +327,22 @@ gitAnnexInodeSentinal r = gitAnnexDir r </> literalOsPath "sentinal" gitAnnexInodeSentinalCache :: Git.Repo -> OsPath-gitAnnexInodeSentinalCache r = gitAnnexInodeSentinal r <> literalOsPath ".cache"+gitAnnexInodeSentinalCache r = + gitAnnexInodeSentinal r <> literalOsPath ".cache" {- The annex directory of a repository. -} gitAnnexDir :: Git.Repo -> OsPath-gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir+gitAnnexDir r = addTrailingPathSeparator $+ Git.localGitDir r </> annexDir glm+ where+ glm = repoGitLocationMaker r {- The part of the annex directory where file contents are stored. -} gitAnnexObjectDir :: Git.Repo -> OsPath gitAnnexObjectDir r = addTrailingPathSeparator $- Git.localGitDir r </> objectDir+ Git.localGitDir r </> objectDir glm+ where+ glm = repoGitLocationMaker r {- .git/annex/tmp/ is used for temp files for key's contents -} gitAnnexTmpObjectDir :: Git.Repo -> OsPath@@ -337,7 +371,8 @@ {- The temp file to use for a given key's content. -} gitAnnexTmpObjectLocation :: Key -> Git.Repo -> OsPath-gitAnnexTmpObjectLocation key r = gitAnnexTmpObjectDir r </> keyFile key+gitAnnexTmpObjectLocation key r =+ gitAnnexTmpObjectDir r </> keyFile key {- Given a temp file such as gitAnnexTmpObjectLocation, makes a name for a - subdirectory in the same location, that can be used as a work area@@ -373,13 +408,12 @@ {- Lock file for the keys database. -} gitAnnexKeysDbLock :: Git.Repo -> GitConfig -> OsPath-gitAnnexKeysDbLock r c = gitAnnexKeysDbDir r c <> literalOsPath ".lck"+gitAnnexKeysDbLock r c = gitAnnexKeysDbDir r c <> literalOsPath ".lck" {- Contains the stat of the last index file that was - reconciled with the keys database. -} gitAnnexKeysDbIndexCache :: Git.Repo -> GitConfig -> OsPath-gitAnnexKeysDbIndexCache r c =- gitAnnexKeysDbDir r c <> literalOsPath ".cache"+gitAnnexKeysDbIndexCache r c = gitAnnexKeysDbDir r c <> literalOsPath ".cache" {- .git/annex/fsck/uuid/ is used to store information about incremental - fscks. -}@@ -392,19 +426,23 @@ {- used to store information about incremental fscks. -} gitAnnexFsckState :: UUID -> Git.Repo -> OsPath-gitAnnexFsckState u r = gitAnnexFsckDir u r Nothing </> literalOsPath "state"+gitAnnexFsckState u r = + gitAnnexFsckDir u r Nothing </> literalOsPath "state" {- Directory containing database used to record fsck info. -} gitAnnexFsckDbDir :: UUID -> Git.Repo -> GitConfig -> OsPath-gitAnnexFsckDbDir u r c = gitAnnexFsckDir u r (Just c) </> literalOsPath "fsckdb"+gitAnnexFsckDbDir u r c = + gitAnnexFsckDir u r (Just c) </> literalOsPath "fsckdb" {- Directory containing old database used to record fsck info. -} gitAnnexFsckDbDirOld :: UUID -> Git.Repo -> GitConfig -> OsPath-gitAnnexFsckDbDirOld u r c = gitAnnexFsckDir u r (Just c) </> literalOsPath "db"+gitAnnexFsckDbDirOld u r c =+ gitAnnexFsckDir u r (Just c) </> literalOsPath "db" {- Lock file for the fsck database. -} gitAnnexFsckDbLock :: UUID -> Git.Repo -> GitConfig -> OsPath-gitAnnexFsckDbLock u r c = gitAnnexFsckDir u r (Just c) </> literalOsPath "fsck.lck"+gitAnnexFsckDbLock u r c =+ gitAnnexFsckDir u r (Just c) </> literalOsPath "fsck.lck" {- .git/annex/fsckresults/uuid is used to store results of git fscks -} gitAnnexFsckResultsLog :: UUID -> Git.Repo -> OsPath
Assistant/Repair.hs view
@@ -133,7 +133,7 @@ repairStaleLocks lockfiles return $ not $ null lockfiles where- findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator annexDir) True . Git.localGitDir+ findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator (annexDir standardGitLocationMaker)) True . Git.localGitDir islock f | literalOsPath "gc.pid" `OS.isInfixOf` f = False | literalOsPath ".lock" `OS.isSuffixOf` f = True
CHANGELOG view
@@ -1,3 +1,24 @@+git-annex (10.20250721) upstream; urgency=medium++ * Improved workaround for git 2.50 bug, avoding an occasional test suite+ failure, as well as some situations where an unlocked file did not get+ populated when adding another file to the repository with the same+ content.+ * Add --url option and url= preferred content expression, to match+ content that is recorded as present in an url. + * p2phttp: Scan multilevel directories with --directory.+ * p2phttp: Added --socket option.+ * Fix bug in handling of linked worktrees on filesystems not supporting+ symlinks, that caused annexed file content to be stored in the wrong+ location inside the git directory, and also caused pointer files to not+ get populated.+ * fsck: Fix location of annexed files when run in linked worktrees+ that have experienced the above bug.+ * Fix symlinks generated to annexed content when in adjusted unlocked+ branch in a linked worktree on a filesystem not supporting symlinks.++ -- Joey Hess <id@joeyh.name> Tue, 22 Jul 2025 14:11:26 -0400+ git-annex (10.20250630) upstream; urgency=medium * Work around git 2.50 bug that caused it to crash when there is a merge
CmdLine/GitAnnex/Options.hs view
@@ -348,6 +348,11 @@ <> help "match files with attached metadata" <> hidden )+ , annexOption (setAnnexState . Limit.addUrl) $ strOption+ ( long "url" <> metavar paramGlob+ <> help "match files by url"+ <> hidden+ ) , annexFlag (setAnnexState Limit.Wanted.addWantGet) ( long "want-get" <> help "match files the local repository wants to get"
CmdLine/GitRemoteAnnex.hs view
@@ -1027,9 +1027,10 @@ keyExportLocations rmt k cfg uuid | exportTree (Remote.config rmt) || importTree (Remote.config rmt) = Just $ map (\p -> mkExportLocation (literalOsPath ".git" </> p)) $- concatMap (`annexLocationsBare` k) cfgs+ concatMap (`mkloc` k) cfgs | otherwise = Nothing where+ mkloc = annexLocationsBare standardGitLocationMaker -- 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.
Command/Fsck.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2010-2023 Joey Hess <id@joeyh.name>+ - Copyright 2010-2025 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -15,6 +15,7 @@ import qualified Remote import qualified Types.Backend import qualified Backend+import qualified Git import Annex.Content import Annex.Verify #ifndef mingw32_HOST_OS@@ -24,6 +25,7 @@ import Annex.Content.Presence.LowLevel import Annex.Perms import Annex.Link+import Annex.Fixup import Logs.Location import Logs.Trust import Logs.Activity@@ -102,6 +104,8 @@ from <- maybe (pure Nothing) (Just <$$> getParsed) (fsckFromOption o) u <- maybe getUUID (pure . Remote.uuid) from checkDeadRepo u+ when (isNothing from) $+ cleanupLinkedWorkTreeBug i <- prepIncremental u (incrementalOpt o) let seeker = AnnexedFileSeeker { startAction = const $ start from i@@ -768,4 +772,38 @@ withFsckDb (StartIncremental h) a = a h withFsckDb (NonIncremental mh) a = maybe noop a mh withFsckDb (ScheduleIncremental _ _ i) a = withFsckDb i a-+ +-- A bug caused linked worktrees on filesystems not supporting symlinks+-- to not use the common annex directory, but one annex directory per+-- linked worktree. Object files could end up stored in those directories.+--+-- When run in a linked worktree with its own annex directory that is not a+-- symlink, move any object files to the right location, and delete the+-- annex directory.+cleanupLinkedWorkTreeBug :: Annex ()+cleanupLinkedWorkTreeBug = + whenM (Annex.inRepo needsGitLinkFixup) $ do+ r <- Annex.gitRepo+ -- mainWorkTreePath is set by fixupUnusualRepos.+ -- Unsetting it makes a version of the Repo that uses+ -- the wrong object location.+ let r' = r { Git.mainWorkTreePath = Nothing }+ let dir = gitAnnexDir r'+ whenM (liftIO $ dirnotsymlink dir) $ do+ showSideAction $ "Cleaning up directory " + <> QuotedPath dir+ <> " created by buggy version of git-annex"+ (st, rd) <- liftIO $ Annex.new' (\r'' _c -> pure r'') r'+ ks <- liftIO $ Annex.eval (st, rd) $+ listKeys InAnnex+ forM_ ks $ \k -> void $ tryNonAsync $ do+ loc <- liftIO $ gitAnnexLocation k r'+ (Annex.gitconfig st)+ moveAnnex k loc+ void $ tryNonAsync $ liftIO $+ removeDirectoryRecursive dir+ where+ dirnotsymlink dir = + tryIO (R.getSymbolicLinkStatus (fromOsPath dir)) >>= \case+ Right st -> return $ not (isSymbolicLink st)+ Left _ -> return False
Command/P2P.hs view
@@ -90,12 +90,16 @@ genAddresses :: [P2PAddress] -> Annex () genAddresses [] = giveup "No P2P networks are currently available." genAddresses addrs = do- authtoken <- liftIO $ genAuthToken 128- storeP2PAuthToken authtoken+ addrauths <- forM addrs go earlyWarning "These addresses allow access to this git-annex repository. Only share them with people you trust with that access, using trusted communication channels!" liftIO $ putStr $ safeOutput $ unlines $- map formatP2PAddress $- map (`P2PAddressAuth` authtoken) addrs+ map formatP2PAddress addrauths+ + where+ go addr = do+ authtoken <- liftIO $ genAuthToken 128+ storeP2PAuthToken addr authtoken+ return $ P2PAddressAuth addr authtoken -- Address is read from stdin, to avoid leaking it in shell history. linkRemote :: RemoteName -> CommandStart@@ -268,20 +272,20 @@ case (toAuthToken (ourhalf <> theirhalf), toAuthToken (theirhalf <> ourhalf)) of (Just ourauthtoken, Just theirauthtoken) -> do liftIO $ putStrLn $ "Successfully exchanged pairing data. Connecting to " ++ remotename ++ "..."- storeP2PAuthToken ourauthtoken- go retries theiraddrs theirauthtoken+ go retries theiraddrs theirauthtoken ourauthtoken _ -> return ReceiveFailed where- go 0 [] _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "."- go n [] theirauthtoken = do+ go 0 [] _ _ = return $ LinkFailed $ "Unable to connect to " ++ remotename ++ "."+ go n [] theirauthtoken ourauthtoken = do liftIO $ threadDelaySeconds (Seconds 2) liftIO $ putStrLn $ "Unable to connect to " ++ remotename ++ ". Retrying..."- go (n-1) theiraddrs theirauthtoken- go n (addr:rest) theirauthtoken = do+ go (n-1) theiraddrs theirauthtoken ourauthtoken+ go n (addr:rest) theirauthtoken ourauthtoken = do+ storeP2PAuthToken addr ourauthtoken r <- setupLink remotename (P2PAddressAuth addr theirauthtoken) case r of LinkSuccess -> return PairSuccess- _ -> go n rest theirauthtoken+ _ -> go n rest theirauthtoken ourauthtoken data LinkResult = LinkSuccess
Command/P2PHttp.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2024 Joey Hess <id@joeyh.name>+ - Copyright 2024-2025 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -21,11 +21,15 @@ import qualified Git.Construct import qualified Annex import Types.Concurrency+import qualified Utility.RawFilePath as R+import Utility.FileMode import Servant import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WarpTLS as Warp import Network.Socket (PortNumber)+import qualified Network.Socket as Socket+import System.PosixCompat.Files (isSymbolicLink) import qualified Data.Map as M import Data.String import Control.Concurrent.STM@@ -40,6 +44,7 @@ data Options = Options { portOption :: Maybe PortNumber , bindOption :: Maybe String+ , socketOption :: Maybe FilePath , certFileOption :: Maybe FilePath , privateKeyFileOption :: Maybe FilePath , chainFileOption :: [FilePath]@@ -66,6 +71,10 @@ <> help "specify address to bind to" )) <*> optional (strOption+ ( long "socket" <> metavar paramPath+ <> help "bind to unix domain socket"+ ))+ <*> optional (strOption ( long "certfile" <> metavar paramFile <> help "TLS certificate file for HTTPS" ))@@ -172,12 +181,21 @@ let settings = Warp.setPort port $ Warp.setHost host $ Warp.defaultSettings mstv <- newTMVarIO mst+ let app = p2pHttpApp mstv case (certFileOption o, privateKeyFileOption o) of- (Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp mstv)+ (Nothing, Nothing) -> case socketOption o of+ Nothing -> Warp.runSettings settings app+ Just socketpath -> + withsocket socketpath $ \sock ->+ Warp.runSettingsSocket settings sock app (Just certfile, Just privatekeyfile) -> do let tlssettings = Warp.tlsSettingsChain certfile (chainFileOption o) privatekeyfile- Warp.runTLS tlssettings settings (p2pHttpApp mstv)+ case socketOption o of+ Nothing -> Warp.runTLS tlssettings settings app+ Just socketpath -> + withsocket socketpath $ \sock ->+ Warp.runTLSSocket tlssettings settings sock app _ -> giveup "You must use both --certfile and --privatekeyfile options to enable HTTPS." port = maybe (fromIntegral defaultP2PHttpProtocolPort)@@ -187,6 +205,13 @@ (fromString "*") -- both ipv4 and ipv6 fromString (bindOption o)+ withsocket socketpath =+ bracket (opensocket socketpath) Socket.close+ opensocket socketpath = protectedOutput $ do+ sock <- Socket.socket Socket.AF_UNIX Socket.Stream 0+ Socket.bind sock $ Socket.SockAddrUnix socketpath+ Socket.listen sock Socket.maxListenQueue+ return sock mkServerState :: Options -> M.Map Auth P2P.ServerMode -> Annex P2PHttpServerState mkServerState o authenv = @@ -268,6 +293,20 @@ findRepos o = do files <- concat <$> mapM (dirContents . toOsPath) (directoryOption o)- map Git.Construct.newFrom . catMaybes - <$> mapM Git.Construct.checkForRepo files-+ concat <$> mapM go files+ where+ go f = Git.Construct.checkForRepo f >>= \case+ Just loc -> return [Git.Construct.newFrom loc]+ Nothing -> + -- Avoid following symlinks, both to avoid+ -- cycles and in case there is an unexpected+ -- symlink to some other directory we are not+ -- supposed to serve.+ ifM (isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath f))+ ( return []+ -- Ignore any errors getting the contents of a+ -- subdirectory.+ , catchNonAsync+ (concat <$> (mapM go =<< dirContents f))+ (const (return []))+ )
Database/Keys.hs view
@@ -260,7 +260,7 @@ - is an associated file. -} reconcileStaged :: Bool -> H.DbQueue -> Annex DbTablesChanged-reconcileStaged dbisnew qh = ifM notneeded+reconcileStaged dbisnew qh = ifM isBareRepo ( return mempty , do gitindex <- inRepo currentIndexFile@@ -299,12 +299,12 @@ inRepo $ update' lastindexref newtree fastDebug "Database.Keys" "reconcileStaged end" return (DbTablesChanged True True)- -- git write-tree will fail if the index is locked or when there is- -- a merge conflict. To get up-to-date with the current index, - -- diff --staged with the old index tree. The current index tree- -- is not known, so not recorded, and the inode cache is not updated,- -- so the next time git-annex runs, it will diff again, even- -- if the index is unchanged.+ -- Was not able to run git write-tree, or it failed due to the+ -- index being locked or a merge conflict. To get up-to-date with+ -- the current index, diff --staged with the old index tree. The+ -- current index tree is not known, so not recorded, and the inode+ -- cache is not updated, so the next time git-annex runs, it will+ -- diff again, even if the index is unchanged. -- -- When there is a merge conflict, that will not see the new local -- version of the files that are conflicted. So a second diff@@ -327,21 +327,22 @@ processor l False `finally` void cleanup - -- Avoid running smudge clean filter, which would block trying to- -- access the locked database. git write-tree sometimes calls it,- -- even though it is not adding work tree files to the index,- -- and so the filter cannot have an effect on the contents of the- -- index or on the tree that gets written from it.- getindextree = inRepo $ \r -> writeTreeQuiet $ r- { gitGlobalOpts = gitGlobalOpts r ++ bypassSmudgeConfig }- - notneeded = isBareRepo- -- Avoid doing anything when run by the - -- smudge clean filter. When that happens in a conflicted- -- merge situation, running git write-tree- -- here would cause git merge to fail with an internal- -- error. This works around around that bug in git.- <||> Annex.getState Annex.insmudgecleanfilter+ -- This avoids running git write-tree when run by the smudge clean+ -- filter, in order to work around a bug in git. That causes+ -- git merge to fail with an internal error when git write-tree is+ -- run by the smudge clean filter in conflicted merge situation.+ --+ -- When running git write-tree, avoid it running the smudge clean+ -- filter, which would block trying to access the locked database. + -- git write-tree sometimes calls it, even though it is not adding+ -- work tree files to the index, and so the filter cannot have an + -- effect on the contents of the index or on the tree that gets+ -- written from it.+ getindextree = ifM (Annex.getState Annex.insmudgecleanfilter)+ ( return Nothing+ , inRepo $ \r -> writeTreeQuiet $ r+ { gitGlobalOpts = gitGlobalOpts r ++ bypassSmudgeConfig }+ ) diff old new = -- Avoid running smudge clean filter, since we want the@@ -365,7 +366,7 @@ -- prefilter so that's ok. , Param $ "-G" ++ fromOsPath (toInternalGitPath $- pathSeparator `OS.cons` objectDir)+ pathSeparator `OS.cons` objectDir standardGitLocationMaker) -- Disable rename detection. , Param "--no-renames" -- Avoid other complications.
Git/Construct.hs view
@@ -304,5 +304,6 @@ , gitGlobalOpts = [] , gitDirSpecifiedExplicitly = False , repoPathSpecifiedExplicitly = False+ , mainWorkTreePath = Nothing }
Git/Types.hs view
@@ -62,6 +62,9 @@ -- -c safe.directory=* and -c safe.bareRepository=all -- when using this repository. , repoPathSpecifiedExplicitly :: Bool+ -- When a Repo is a linked git worktree, this is the path+ -- from its gitdir to the git directory of the main worktree.+ , mainWorkTreePath :: Maybe OsPath } deriving (Show, Eq, Ord) type RepoConfig = M.Map ConfigKey ConfigValue
Limit.hs view
@@ -31,6 +31,7 @@ import Types.MetaData import Annex.MetaData import Logs.MetaData+import Logs.Web import Logs.Group import Logs.Unused import Logs.Location@@ -866,6 +867,26 @@ check f matching k = not . S.null . S.filter matching . metaDataValues f <$> getCurrentMetaData k++addUrl :: String -> Annex ()+addUrl = addLimit . limitUrl++limitUrl :: MkLimit Annex+limitUrl glob = Right $ MatchFiles+ { matchAction = const $ const $ checkKey check+ , matchNeedsFileName = False+ , matchNeedsFileContent = False+ , matchNeedsKey = True+ , matchNeedsLocationLog = False+ , matchNeedsLiveRepoSize = False+ , matchNegationUnstable = False+ , matchDesc = "url" =? glob+ }+ where+ check k = any (matchGlob cglob)+ . map (fst . getDownloader)+ <$> getUrls k+ cglob = compileGlob glob CaseSensitive (GlobFilePath False) -- memoized addAccessedWithin :: Duration -> Annex () addAccessedWithin duration = do
P2P/Auth.hs view
@@ -1,6 +1,6 @@ {- P2P authtokens -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2025 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -18,24 +18,49 @@ import qualified Data.Text as T --- | Load authtokens that are accepted by this repository.-loadP2PAuthTokens :: Annex AllowedAuthTokens-loadP2PAuthTokens = allowedAuthTokens <$> loadP2PAuthTokens'+-- | Load authtokens that are accepted by this repository for tor.+loadP2PAuthTokensTor :: Annex AllowedAuthTokens+loadP2PAuthTokensTor = allowedAuthTokens + . map fst . filter istor+ <$> loadP2PAuthTokens'+ where+ istor (_, Nothing) = True+ istor _ = False -loadP2PAuthTokens' :: Annex [AuthToken]-loadP2PAuthTokens' = mapMaybe toAuthToken- . map T.pack+-- | Load authtokens that are accepted for a given P2PAddress.+loadP2PAuthTokens :: P2PAddress -> Annex AllowedAuthTokens+loadP2PAuthTokens addr = allowedAuthTokens + . map fst . filter ((== Just addr) . snd)+ <$> loadP2PAuthTokens'++loadP2PAuthTokens' :: Annex [(AuthToken, Maybe P2PAddress)]+loadP2PAuthTokens' = mapMaybe parse . lines . fromMaybe [] <$> readCreds p2pAuthCredsFile+ where+ parse l = + let (tok, addr) = separate (== ' ') l+ in do+ tok' <- toAuthToken (T.pack tok) + return (tok', unformatP2PAddress addr) -- | Stores an AuthToken, making it be accepted by this repository.-storeP2PAuthToken :: AuthToken -> Annex ()-storeP2PAuthToken t = do+storeP2PAuthToken :: P2PAddress -> AuthToken -> Annex ()+storeP2PAuthToken addr t = do ts <- loadP2PAuthTokens'- unless (t `elem` ts) $ do- let d = unlines $ map (T.unpack . fromAuthToken) (t:ts)+ unless (v `elem` ts) $ do+ let d = unlines $ map fmt (v:ts) writeCreds d p2pAuthCredsFile+ where+ v = case addr of+ TorAnnex _ _ -> (t, Nothing)+ -- _ -> (t, Just addr)+ + fmt (tok, Nothing) = T.unpack (fromAuthToken tok)+ fmt (tok, Just addr') = T.unpack (fromAuthToken tok) + ++ " " ++ formatP2PAddress addr'+ p2pAuthCredsFile :: OsPath p2pAuthCredsFile = literalOsPath "p2pauth"
P2P/IO.hs view
@@ -168,7 +168,6 @@ S.bind soc (S.SockAddrUnix (fromOsPath unixsocket)) -- Allow everyone to read and write to the socket, -- so a daemon like tor, that is probably running as a different- -- de sock $ addModes -- user, can access it. -- -- Connections have to authenticate to do anything,
Remote/GCrypt.hs view
@@ -303,7 +303,7 @@ - which is needed for rsync of objects to it to work. -} rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do- createAnnexDirectory (tmp </> objectDir)+ createAnnexDirectory (tmp </> objectDir standardGitLocationMaker) dummycfg <- liftIO dummyRemoteGitConfig let (rsynctransport, rsyncurl, _) = rsyncTransport r dummycfg let tmpconfig = fromOsPath $ tmp </> literalOsPath "config"@@ -466,7 +466,8 @@ checkshell = Ssh.inAnnex repo k gCryptTopDir :: Git.Repo -> OsPath-gCryptTopDir repo = toOsPath (Git.repoLocation repo) </> objectDir+gCryptTopDir repo = + toOsPath (Git.repoLocation repo) </> objectDir standardGitLocationMaker {- Annexed objects are hashed using lower-case directories for max - portability. -}
Remote/Git.hs view
@@ -467,14 +467,16 @@ -- If the remote is known to not be bare, try the hash locations -- used for non-bare repos first, as an optimisation. locs- | remoteAnnexBare remoteconfig == Just False = annexLocationsNonBare gc key- | otherwise = annexLocationsBare gc key+ | remoteAnnexBare remoteconfig == Just False = + annexLocationsNonBare glm gc key+ | otherwise = annexLocationsBare glm gc key #ifndef mingw32_HOST_OS locs' = map fromOsPath locs #else locs' = map (replace "\\" "/" . fromOsPath) locs #endif remoteconfig = gitconfig r+ glm = repoGitLocationMaker repo dropKey :: Remote -> State -> Maybe SafeDropProof -> Key -> Annex () dropKey r st proof key = do
RemoteDaemon/Transport/Tor.hs view
@@ -109,7 +109,7 @@ ((), (st', _rd)) <- Annex.run (st, rd) $ do -- Load auth tokens for every connection, to notice -- when the allowed set is changed.- allowed <- loadP2PAuthTokens+ allowed <- loadP2PAuthTokensTor let conn = P2PConnection { connRepo = Just r , connCheckAuth = (`isAllowedAuthToken` allowed)
Test/Framework.hs view
@@ -196,8 +196,10 @@ case r of Right () -> return () Left e -> do- whenM (keepFailuresOption . testOptions <$> getTestMode) $- putStrLn $ "** Preserving repo for failure analysis in " ++ clone+ whenM (keepFailuresOption . testOptions <$> getTestMode) $ do+ topdir <- Utility.Env.getEnvDefault "TOPDIR" ""+ putStrLn $ "** Preserving repo for failure analysis in " ++ + fromOsPath (toOsPath topdir </> toOsPath clone) throwM e disconnectOrigin :: Assertion
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20250630+Version: 10.20250721 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>