diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -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) diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -1,6 +1,6 @@ {- git-annex file matching - - - Copyright 2012-2024 Joey Hess + - Copyright 2012-2025 Joey Hess - - 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)) diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -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 diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -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 diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -1,6 +1,6 @@ {- git-annex file locations - - - Copyright 2010-2024 Joey Hess + - Copyright 2010-2025 Joey Hess - - 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 diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -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 diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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 diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -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" diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -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. diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2023 Joey Hess + - Copyright 2010-2025 Joey Hess - - 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 diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -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 diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2024 Joey Hess + - Copyright 2024-2025 Joey Hess - - 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 [])) + ) diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -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. diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -304,5 +304,6 @@ , gitGlobalOpts = [] , gitDirSpecifiedExplicitly = False , repoPathSpecifiedExplicitly = False + , mainWorkTreePath = Nothing } diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -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 diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -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 diff --git a/P2P/Auth.hs b/P2P/Auth.hs --- a/P2P/Auth.hs +++ b/P2P/Auth.hs @@ -1,6 +1,6 @@ {- P2P authtokens - - - Copyright 2016 Joey Hess + - Copyright 2016-2025 Joey Hess - - 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" diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -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, diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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. -} diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -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) diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -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 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.20250630 +Version: 10.20250721 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess