diff --git a/Annex/CopyFile.hs b/Annex/CopyFile.hs --- a/Annex/CopyFile.hs +++ b/Annex/CopyFile.hs @@ -1,6 +1,6 @@ {- Copying files. - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,6 +10,7 @@ module Annex.CopyFile where import Annex.Common +import qualified Annex import Utility.Metered import Utility.CopyFile import Utility.FileMode @@ -30,7 +31,7 @@ newCopyCoWTried :: IO CopyCoWTried newCopyCoWTried = CopyCoWTried <$> newEmptyMVar -{- Copies a file is copy-on-write is supported. Otherwise, returns False. +{- Copies a file if copy-on-write is supported. Otherwise, returns False. - - The destination file must not exist yet (or may exist but be empty), - or it will fail to make a CoW copy, and will return false. @@ -77,6 +78,23 @@ data CopyMethod = CopiedCoW | Copied +-- Should cp be allowed to copy the file with --reflink=auto? +-- +-- The benefit is that this lets it use the copy_file_range +-- syscall, which is not used with --reflink=always. The drawback is that +-- the IncrementalVerifier is not updated, so verification, if it is done, +-- will need to re-read the whole content of the file. And, interrupted +-- copies are not resumed but are restarted from the beginning. +-- +-- Using this will result in CopiedCow being returned even in cases +-- where cp fell back to a slow copy. +newtype FastCopy = FastCopy Bool + +getFastCopy :: RemoteGitConfig -> Annex FastCopy +getFastCopy gc = case remoteAnnexFastCopy gc of + False -> FastCopy . annexFastCopy <$> Annex.getGitConfig + True -> return (FastCopy True) + {- Copies from src to dest, updating a meter. Preserves mode and mtime. - Uses copy-on-write if it is supported. If the the destination already - exists, an interrupted copy will resume where it left off. @@ -94,38 +112,49 @@ - (eg when isStableKey is false), and doing this avoids getting a - corrupted file in such cases. -} -fileCopier :: CopyCoWTried -> OsPath -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> IO CopyMethod +fileCopier :: CopyCoWTried -> FastCopy -> OsPath -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> IO CopyMethod +fileCopier copycowtried (FastCopy True) src dest meterupdate iv = do + ok <- watchFileSize dest meterupdate $ const $ + copyFileExternal CopyTimeStamps src dest + if ok + then do + maybe noop unableIncrementalVerifier iv + return CopiedCoW + else fileCopier copycowtried (FastCopy False) src dest meterupdate iv #ifdef mingw32_HOST_OS -fileCopier _ src dest meterupdate iv = docopy +fileCopier _ _ src dest meterupdate iv = + fileCopier' src dest meterupdate iv #else -fileCopier copycowtried src dest meterupdate iv = +fileCopier copycowtried _ src dest meterupdate iv = ifM (tryCopyCoW copycowtried src dest meterupdate) ( do maybe noop unableIncrementalVerifier iv return CopiedCoW - , docopy + , fileCopier' src dest meterupdate iv ) #endif - where - docopy = do - -- The file might have had the write bit removed, - -- so make sure we can write to it. - void $ tryIO $ allowWrite dest - F.withBinaryFile src ReadMode $ \hsrc -> - fileContentCopier hsrc dest meterupdate iv +fileCopier' :: OsPath -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> IO CopyMethod +fileCopier' src dest meterupdate iv = do + -- The file might have had the write bit removed, + -- so make sure we can write to it. + void $ tryIO $ allowWrite dest + + F.withBinaryFile src ReadMode $ \hsrc -> + fileContentCopier hsrc dest meterupdate iv - -- Copy src mode and mtime. - mode <- fileMode <$> R.getFileStatus (fromOsPath src) - mtime <- utcTimeToPOSIXSeconds <$> getModificationTime src - let dest' = fromOsPath dest - R.setFileMode dest' mode - touch dest' mtime False + -- Copy src mode and mtime. + mode <- fileMode <$> R.getFileStatus (fromOsPath src) + mtime <- utcTimeToPOSIXSeconds <$> getModificationTime src + let dest' = fromOsPath dest + R.setFileMode dest' mode + touch dest' mtime False - return Copied + return Copied {- Copies content from a handle to a destination file. Does not - use copy-on-write, and does not copy file mode and mtime. + - Updates the IncementalVerifier with the content it copies. -} fileContentCopier :: Handle -> OsPath -> MeterUpdate -> Maybe IncrementalVerifier -> IO () fileContentCopier hsrc dest meterupdate iv = diff --git a/Annex/Hook.hs b/Annex/Hook.hs --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -106,44 +106,55 @@ runAnnexHook :: Git.Hook -> (GitConfig -> Maybe String) -> Annex () runAnnexHook hook commandcfg = runAnnexHook' hook commandcfg >>= \case - Nothing -> noop - Just failedcommanddesc -> + HookSuccess -> noop + HookFailed failedcommanddesc -> warning $ UnquotedString $ failedcommanddesc ++ " failed" --- Returns Nothing if the hook or GitConfig command succeeded, or a --- description of what failed. -runAnnexHook' :: Git.Hook -> (GitConfig -> Maybe String) -> Annex (Maybe String) +data HookResult + = HookSuccess + | HookFailed String + -- ^ A description of the hook command that failed. + deriving (Eq, Show) + +runAnnexHook' :: Git.Hook -> (GitConfig -> Maybe String) -> Annex HookResult runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook) ( runhook , runcommandcfg ) where runhook = ifM (inRepo $ Git.runHook boolSystem hook []) - ( return Nothing + ( return HookSuccess , do h <- fromRepo (Git.hookFile hook) - commandfailed (fromOsPath h) + return $ HookFailed $ fromOsPath h ) runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case - Nothing -> return Nothing + Nothing -> return HookSuccess Just command -> ifM (liftIO $ boolSystem "sh" [Param "-c", Param command]) - ( return Nothing - , commandfailed $ "git configured command '" ++ command ++ "'" + ( return HookSuccess + , return $ HookFailed $ "git configured command '" ++ command ++ "'" ) - commandfailed c = return $ Just c -runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> OsPath -> Annex Bool +runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> OsPath -> Annex HookResult runAnnexPathHook pathtoken hook commandcfg p = ifM (doesAnnexHookExist hook) ( runhook , runcommandcfg ) where - runhook = inRepo $ Git.runHook boolSystem hook [ File p' ] + runhook = ifM (inRepo $ Git.runHook boolSystem hook [ File p' ]) + ( return HookSuccess + , do + h <- fromRepo (Git.hookFile hook) + return $ HookFailed $ fromOsPath h + ) runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case - Nothing -> return True - Just basecmd -> liftIO $ - boolSystem "sh" [Param "-c", Param $ gencmd basecmd] + Nothing -> return HookSuccess + Just basecmd -> + ifM (liftIO $ boolSystem "sh" [Param "-c", Param (gencmd basecmd)]) + ( return HookSuccess + , return $ HookFailed $ "git configured command '" ++ basecmd ++ "'" + ) gencmd = massReplace [ (pathtoken, shellEscape p') ] p' = fromOsPath p diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -19,6 +19,7 @@ uninitialize, probeCrippledFileSystem, probeCrippledFileSystem', + isCrippledFileSystem, ) where import Annex.Common @@ -75,10 +76,10 @@ checkInitializeAllowed :: (InitializeAllowed -> Annex a) -> Annex a checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case Nothing -> runAnnexHook' preInitAnnexHook annexPreInitCommand >>= \case - Nothing -> do + HookSuccess -> do checkSqliteWorks a InitializeAllowed - Just failedcommanddesc -> do + HookFailed failedcommanddesc -> do initpreventedby failedcommanddesc notinitialized Just noannexmsg -> do @@ -94,8 +95,8 @@ initializeAllowed :: Annex Bool initializeAllowed = noAnnexFileContent' >>= \case Nothing -> runAnnexHook' preInitAnnexHook annexPreInitCommand >>= \case - Nothing -> return True - Just _ -> return False + HookSuccess -> return True + HookFailed _ -> return False Just _ -> return False noAnnexFileContent' :: Annex (Maybe String) @@ -288,73 +289,116 @@ isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion {- A crippled filesystem is one that does not allow making symlinks, - - or removing write access from files. -} -probeCrippledFileSystem :: Annex Bool -probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do - (r, warnings) <- probeCrippledFileSystem' tmp + - or removing write access from files. + - + - This displays messages about problems detected with the filesystem. + - + - If a freeze or thaw hook is configured, but exits nonzero, + - this returns Nothing after displaying a message to the user about the + - problem. Such a hook can in some cases make a filesystem + - that would otherwise be detected as crippled work ok, so this avoids + - a false positive. + -} +probeCrippledFileSystem :: Annex (Maybe Bool) +probeCrippledFileSystem = do + (r, warnings) <- isCrippledFileSystem' + mapM_ (warning . UnquotedString) warnings + return r + +isCrippledFileSystem :: Annex Bool +isCrippledFileSystem = do + (r, _warnings) <- isCrippledFileSystem' + return (fromMaybe True r) + +isCrippledFileSystem' :: Annex (Maybe Bool, [String]) +isCrippledFileSystem' = withEventuallyCleanedOtherTmp $ \tmp -> + probeCrippledFileSystem' tmp (Just (freezeContent' UnShared)) (Just (thawContent' UnShared)) =<< hasFreezeHook - mapM_ (warning . UnquotedString) warnings - return r probeCrippledFileSystem' :: (MonadIO m, MonadCatch m) => OsPath - -> Maybe (OsPath -> m ()) - -> Maybe (OsPath -> m ()) + -> Maybe (OsPath -> m HookResult) + -> Maybe (OsPath -> m HookResult) -> Bool - -> m (Bool, [String]) + -> m (Maybe Bool, [String]) #ifdef mingw32_HOST_OS -probeCrippledFileSystem' _ _ _ _ = return (True, []) +probeCrippledFileSystem' _ _ _ _ = return (Just True, []) #else probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do let f = tmp literalOsPath "gaprobe" liftIO $ F.writeFile' f "" - r <- probe f - void $ tryNonAsync $ (fromMaybe (liftIO . allowWrite) thawcontent) f + r <- freezethaw f probe liftIO $ removeFile f return r where - probe f = catchDefaultIO (True, []) $ do + fallbackfreezecontent f = do + liftIO $ preventWrite f + return HookSuccess + + fallbackthawcontent f = do + liftIO $ allowWrite f + return HookSuccess + + freezethaw f cont = + (fromMaybe fallbackfreezecontent freezecontent) f >>= \case + HookFailed failedcommanddesc -> + return (Nothing, [hookfailed failedcommanddesc]) + HookSuccess -> do + r <- cont f + tryNonAsync ((fromMaybe fallbackthawcontent thawcontent) f) + >>= return . \case + Right (HookFailed failedcommanddesc) -> + let (_, warnings) = r + in (Nothing, hookfailed failedcommanddesc : warnings) + _ -> r + + hookfailed failedcommanddesc = "Failed to run " ++ failedcommanddesc + ++ ". Unable to initialize until this is fixed." + + probe f = catchDefaultIO (Just True, []) $ do let f2 = f <> literalOsPath "2" liftIO $ removeWhenExistsWith removeFile f2 liftIO $ R.createSymbolicLink (fromOsPath f) (fromOsPath f2) liftIO $ removeWhenExistsWith removeFile f2 - (fromMaybe (liftIO . preventWrite) freezecontent) f -- Should be unable to write to the file (unless -- running as root). But some crippled -- filesystems ignore write bit removals or ignore -- permissions entirely. ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared f Nothing hasfreezehook)) - ( return (True, ["Filesystem does not allow removing write bit from files."]) + ( return (Just True, ["Filesystem does not allow removing write bit from files."]) , liftIO $ ifM ((== 0) <$> getRealUserID) - ( return (False, []) + ( return (Just False, []) , do r <- catchBoolIO $ do F.writeFile' f "2" return True if r - then return (True, ["Filesystem allows writing to files whose write bit is not set."]) - else return (False, []) + then return (Just True, ["Filesystem allows writing to files whose write bit is not set."]) + else return (Just False, []) ) ) #endif checkCrippledFileSystem :: Annex () -checkCrippledFileSystem = whenM probeCrippledFileSystem $ do - warning "Detected a crippled filesystem." - setCrippledFileSystem True +checkCrippledFileSystem = probeCrippledFileSystem >>= \case + Just True -> do + warning "Detected a crippled filesystem." + setCrippledFileSystem True - {- Normally git disables core.symlinks itself when the:w - - - - filesystem does not support them. But, even if symlinks are - - supported, we don't use them by default in a crippled - - filesystem. -} - whenM (coreSymlinks <$> Annex.getGitConfig) $ do - warning "Disabling core.symlinks." - setConfig "core.symlinks" - (Git.Config.boolConfig False) + {- Normally git disables core.symlinks itself when the + - + - filesystem does not support them. But, even if symlinks are + - supported, we don't use them by default in a crippled + - filesystem. -} + whenM (coreSymlinks <$> Annex.getGitConfig) $ do + warning "Disabling core.symlinks." + setConfig "core.symlinks" + (Git.Config.boolConfig False) + Just False -> noop + Nothing -> giveup "Not initialized." probeLockSupport :: Annex Bool #ifdef mingw32_HOST_OS diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -161,13 +161,12 @@ - that happens with write permissions. -} freezeContent :: OsPath -> Annex () -freezeContent file = - withShared $ \sr -> freezeContent' sr file +freezeContent file = withShared $ \sr -> void $ freezeContent' sr file -freezeContent' :: SharedRepository -> OsPath -> Annex () +freezeContent' :: SharedRepository -> OsPath -> Annex HookResult freezeContent' sr file = freezeContent'' sr file =<< getVersion -freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex () +freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex HookResult freezeContent'' sr file rv = do fastDebug "Annex.Perms" ("freezing content " ++ fromOsPath file) unlessM crippledFileSystem $ go sr @@ -255,9 +254,9 @@ {- Allows writing to an annexed file that freezeContent was called on - before. -} thawContent :: OsPath -> Annex () -thawContent file = withShared $ \sr -> thawContent' sr file +thawContent file = withShared $ \sr -> void $ thawContent' sr file -thawContent' :: SharedRepository -> OsPath -> Annex () +thawContent' :: SharedRepository -> OsPath -> Annex HookResult thawContent' sr file = do fastDebug "Annex.Perms" ("thawing content " ++ fromOsPath file) thawPerms (go sr) (thawHook file) @@ -272,10 +271,10 @@ - fail on a crippled filesystem. But, if file modes are supported on a - crippled filesystem, the file may be frozen, so try to thaw its - permissions. -} -thawPerms :: Annex () -> Annex () -> Annex () +thawPerms :: Annex () -> Annex HookResult -> Annex HookResult thawPerms a hook = ifM crippledFileSystem - ( hook >> void (tryNonAsync a) - , hook >> a + ( void (tryNonAsync a) `after` hook + , a `after` hook ) {- Blocks writing to the directory an annexed file is in, to prevent the @@ -287,7 +286,7 @@ freezeContentDir file = do fastDebug "Annex.Perms" ("freezing content directory " ++ fromOsPath dir) unlessM crippledFileSystem $ withShared go - freezeHook dir + void $ freezeHook dir where dir = parentDir file go UnShared = liftIO $ preventWrite dir @@ -303,7 +302,7 @@ thawContentDir :: OsPath -> Annex () thawContentDir file = do fastDebug "Annex.Perms" ("thawing content directory " ++ fromOsPath dir) - thawPerms (withShared (liftIO . go)) (thawHook dir) + void $ thawPerms (withShared (liftIO . go)) (thawHook dir) where dir = parentDir file go UnShared = allowWrite dir @@ -318,7 +317,7 @@ unlessM (liftIO $ doesDirectoryExist dir) $ createAnnexDirectory dir -- might have already existed with restricted perms - thawHook dir + void $ thawHook dir unlessM crippledFileSystem $ liftIO $ allowWrite dir where dir = parentDir dest @@ -354,12 +353,12 @@ <||> (doesAnnexHookExist thawContentAnnexHook) -freezeHook :: OsPath -> Annex () -freezeHook = void . runAnnexPathHook "%path" +freezeHook :: OsPath -> Annex HookResult +freezeHook = runAnnexPathHook "%path" freezeContentAnnexHook annexFreezeContentCommand -thawHook :: OsPath -> Annex () -thawHook = void . runAnnexPathHook "%path" +thawHook :: OsPath -> Annex HookResult +thawHook = runAnnexPathHook "%path" thawContentAnnexHook annexThawContentCommand {- Calculate mode to use for a directory from the mode to use for a file. diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -147,17 +147,10 @@ <$> getFileSize lf getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles go [] = return () - go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromOsPath . fst) l)) - ( do - waitforit "to check stale git lock file" - l' <- getsizes - if l' == l - then liftIO $ mapM_ (removeWhenExistsWith removeFile . fst) l - else go l' - , do - waitforit "for git lock file writer" - go =<< getsizes - ) - waitforit why = do - debug ["Waiting for 60 seconds", why] + go l = whenM (liftIO $ null <$> Lsof.query ("--" : map (fromOsPath . fst) l)) $ do + debug ["Waiting for 60 seconds to check stale git lock file"] liftIO $ threadDelaySeconds $ Seconds 60 + l' <- getsizes + if l' == l + then liftIO $ mapM_ (removeWhenExistsWith removeFile . fst) l + else go l' diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,26 @@ +git-annex (10.20250605) upstream; urgency=medium + + * sync: Push the current branch first, rather than a synced branch, + to better support git forges (gitlab, gitea, forgejo, etc.) which + use push-to-create with the first pushed branch becoming the default + branch. + * Added annex.fastcopy and remote.name.annex-fastcopy config setting. + When set, this allows the copy_file_range syscall to be used, which + can eg allow for server-side copies on NFS. (For fastest copying, + also disable annex.verify or remote.name.annex-verify.) + * map: Support --json option. + * map: Improve display of remote names. + * When annex.freezecontent-command or annex.thawcontent-command is + configured but fails, prevent initialization. This allows the user to + fix their configuration and avoid crippled filesystem detection + entering an adjusted branch. + * assistant: Avoid hanging at startup when a process has a *.lock file + open in the .git directory. + * Windows: Fix duplicate file bug that could occur when files were + supposed to be moved across devices. + + -- Joey Hess Thu, 05 Jun 2025 14:10:36 -0400 + git-annex (10.20250520) upstream; urgency=medium * Preferred content now supports "balanced=groupname:lackingcopies" diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -1204,7 +1204,7 @@ _ -> noop void $ liftIO $ tryIO $ removeDirectory annexobjectdir - notcrippledfilesystem = not <$> probeCrippledFileSystem + notcrippledfilesystem = not <$> isCrippledFileSystem nonbuggygitversion = liftIO $ flip notElem buggygitversions <$> Git.Version.installed diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -9,8 +9,6 @@ module Command.Map where -import qualified Data.Map as M - import Command import qualified Git import qualified Git.Url @@ -25,12 +23,17 @@ import Types.TrustLevel import qualified Remote.Helper.Ssh as Ssh import qualified Utility.Dot as Dot +import qualified Messages.JSON as JSON +import Messages.JSON ((.=)) +import Utility.Aeson (packString) +import qualified Data.Map as M + -- a repo and its remotes type RepoRemotes = (Git.Repo, [Git.Repo]) cmd :: Command -cmd = dontCheck repoExists $ +cmd = dontCheck repoExists $ withAnnexOptions [jsonOptions] $ command "map" SectionQuery "generate map of repositories" paramNothing (withParams seek) @@ -44,20 +47,24 @@ umap <- uuidDescMap trustmap <- trustMapLoad - - file <- () - <$> fromRepo gitAnnexDir - <*> pure (literalOsPath "map.dot") + + ifM (outputJSONMap rs trustmap umap) + ( next $ return True + , do + file <- () + <$> fromRepo gitAnnexDir + <*> pure (literalOsPath "map.dot") - liftIO $ writeFile (fromOsPath file) (drawMap rs trustmap umap) - next $ - ifM (Annex.getRead Annex.fast) - ( runViewer file [] - , runViewer file - [ ("xdot", [File (fromOsPath file)]) - , ("dot", [Param "-Tx11", File (fromOsPath file)]) - ] - ) + liftIO $ writeFile (fromOsPath file) (drawMap rs trustmap umap) + next $ + ifM (Annex.getRead Annex.fast) + ( runViewer file [] + , runViewer file + [ ("xdot", [File (fromOsPath file)]) + , ("dot", [Param "-Tx11", File (fromOsPath file)]) + ] + ) + ) runViewer :: OsPath -> [(String, [CommandParam])] -> Annex Bool runViewer file [] = do @@ -101,10 +108,10 @@ basehostname :: Git.Repo -> String basehostname r = fromMaybe "" $ headMaybe $ splitc '.' $ hostname r -{- A name to display for a repo. Uses the name from uuid.log if available, - - or the remote name if not. -} -repoName :: UUIDDescMap -> Git.Repo -> String -repoName umap r +{- A description to display for a repo. Uses the description + - from uuid.log if available, or the remote name if not. -} +repoDesc :: UUIDDescMap -> Git.Repo -> String +repoDesc umap r | repouuid == NoUUID = fallback | otherwise = maybe fallback fromUUIDDesc $ M.lookup repouuid umap where @@ -124,7 +131,7 @@ where n = Dot.subGraph (hostname r) (basehostname r) "lightblue" $ trustDecorate trustmap (getUncachedUUID r) $ - Dot.graphNode (nodeId r) (repoName umap r) + Dot.graphNode (nodeId r) (repoDesc umap r) edges = map (edge umap fullinfo r) rs {- An edge between two repos. The second repo is a remote of the first. -} @@ -143,7 +150,7 @@ - different from its hostname. (This reduces visual clutter.) -} edgename = maybe Nothing calcname $ Git.remoteName to calcname n - | n `elem` [repoName umap fullto, hostname fullto] = Nothing + | n `elem` [repoDesc umap fullto, hostname fullto] = Nothing | otherwise = Just n trustDecorate :: TrustMap -> UUID -> String -> String @@ -182,7 +189,9 @@ | otherwise = liftIO $ do r' <- Git.Construct.fromPath =<< absPath (Git.repoPath r) r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r' - return (fromMaybe r' r'') + return $ (fromMaybe r' r'') + { Git.remoteName = Git.remoteName r + } {- Checks if two repos are the same. -} same :: Git.Repo -> Git.Repo -> Bool @@ -198,7 +207,8 @@ {- reads the config of a remote, with progress display -} scan :: Git.Repo -> Annex Git.Repo scan r = do - showStartMessage (StartMessage "map" (ActionItemOther (Just $ UnquotedString $ Git.repoDescribe r)) (SeekInput [])) + unlessM jsonOutputEnabled $ + showStartMessage (StartMessage "map" (ActionItemOther (Just $ UnquotedString $ Git.repoDescribe r)) (SeekInput [])) v <- tryScan r case v of Just r' -> do @@ -269,7 +279,7 @@ configlist ok -> return ok - sshnote = do + sshnote = unlessM jsonOutputEnabled $ do showAction "sshing" showOutput @@ -287,3 +297,33 @@ case result of Left _ -> return Nothing Right r' -> return $ Just r' + +outputJSONMap :: [RepoRemotes] -> TrustMap -> UUIDDescMap -> Annex Bool +outputJSONMap rs trustmap umap = + showFullJSON $ JSON.AesonObject $ case mapo of + JSON.Object obj -> obj + _ -> error "internal" + where + mapo = JSON.object + [ "nodes" .= map mknode (filterdead fst rs) + ] + + mknode (r, remotes) = JSON.object + [ "description" .= packString (repoDesc umap r) + , "uuid" .= mkuuid (getUncachedUUID r) + , "url" .= packString (Git.repoLocation r) + , "remotes" .= map mkremote (filterdead id remotes) + ] + + mkremote r = JSON.object + [ "remote" .= (packString <$> Git.remoteName r) + , "uuid" .= mkuuid (getUncachedUUID r) + , "url" .= packString (Git.repoLocation r) + ] + + mkuuid NoUUID = Nothing + mkuuid u = Just $ packString $ fromUUID u + + filterdead f = filter + (\i -> M.lookup (getUncachedUUID (f i)) trustmap /= Just DeadTrusted) + diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -83,7 +83,6 @@ import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse -import Utility.Process.Transcript import Utility.Tuple import Utility.Matcher @@ -706,20 +705,13 @@ - Git offers no way to tell if a remote is bare or not, so both methods - are tried. - - - The direct push is likely to spew an ugly error message, so its stderr is - - often elided. Since git progress display goes to stderr too, the - - sync push is done first, and actually sends the data. Then the - - direct push is tried, with stderr discarded, to update the branch ref - - on the remote. + - The direct push is done first, because some hosting providers like + - github may treat the first branch pushed to a new repository as the + - default branch for that repository. - - The sync push first sends the synced/master branch, - and then forces the update of the remote synced/git-annex branch. - - - Since some providers like github may treat the first branch sent - - as the default branch, it's better to make that be synced/master than - - synced/git-annex. (Although neither is ideal, it's the best that - - can be managed given the constraints on order.) - - - The forcing is necessary if a transition has rewritten the git-annex branch. - Normally any changes to the git-annex branch get pulled and merged before - this push, so this forcing is unlikely to overwrite new data pushed @@ -728,34 +720,59 @@ - But overwriting of data on synced/git-annex can happen, in a race. - The only difference caused by using a forced push in that case is that - the last repository to push wins the race, rather than the first to push. + - + - The git-annex branch is pushed last. This push may fail if the remote + - has other changes in the git-annex branch, and that is not treated as an + - error, since the synced/git-annex branch has been sent already. Since no + - new data is usually sent in this push (due to synced/git-annex already + - having been pushed), it's ok to hide git's output to avoid displaying + - a push error. -} pushBranch :: Remote -> Maybe Git.Branch -> MessageState -> Git.Repo -> IO Bool -pushBranch remote mbranch ms g = directpush `after` annexpush `after` syncpush +pushBranch remote mbranch ms g = do + directpush + annexpush `after` syncpush where - syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes - [ (refspec . origBranch) <$> mbranch - , Just $ Git.Branch.forcePush $ refspec Annex.Branch.name - ] - annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams - [ Git.fromRef $ Git.Ref.base $ Annex.Branch.name ] directpush = case mbranch of - Nothing -> noop - -- Git prints out an error message when this fails. - -- In the default configuration of receive.denyCurrentBranch, - -- the error message mentions that config setting - -- (and should even if it is localized), and is quite long, - -- and the user was not intending to update the checked out - -- branch, so in that case, avoid displaying the error - -- message. Do display other error messages though, - -- including the error displayed when - -- receive.denyCurrentBranch=updateInstead -- the user - -- will want to see that one. Just branch -> do let p = flip Git.Command.gitCreateProcess g $ pushparams [ Git.fromRef $ Git.Ref.base $ origBranch branch ] - (transcript, ok) <- processTranscript' p Nothing - when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $ - hPutStr stderr transcript + let p' = p { std_err = CreatePipe } + bracket (createProcess p') cleanupProcess $ \h -> do + filterstderr [] (stderrHandle h) (processHandle h) + void $ waitForProcess (processHandle h) + Nothing -> noop + + syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes + [ (syncrefspec . origBranch) <$> mbranch + , Just $ Git.Branch.forcePush $ syncrefspec Annex.Branch.name + ] + + annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams + [ Git.fromRef $ Git.Ref.base $ Annex.Branch.name ] + + -- In the default configuration of receive.denyCurrentBranch, + -- git's stderr message mentions that config setting + -- (and should even if it is localized), and is quite long, + -- and the user was not intending to update the checked out + -- branch, so in that case, avoid displaying the error + -- message. Do display other error messages though, + -- including the error displayed when + -- receive.denyCurrentBranch=updateInstead; the user + -- will want to see that one. Also display progress messages. + filterstderr buf herr pid = hGetLineUntilExitOrEOF pid herr >>= \case + Just l + | "remote: " `isPrefixOf` l || not (null buf)-> + filterstderr (l:buf) herr pid + | otherwise -> do + hPutStrLn stderr l + filterstderr [] herr pid + Nothing -> displaybuf + where + displaybuf = + unless (any ("receive.denyCurrentBranch" `isInfixOf`) buf) $ + mapM_ (hPutStrLn stderr) (reverse buf) + pushparams branches = catMaybes [ Just $ Param "push" , if commandProgressDisabled' ms @@ -763,7 +780,8 @@ else Nothing , Just $ Param $ Remote.name remote ] ++ map Param branches - refspec b = concat + + syncrefspec b = concat [ Git.fromRef $ Git.Ref.base b , ":" , Git.fromRef $ Git.Ref.base $ syncBranch b @@ -1139,9 +1157,9 @@ where showwarning = earlyWarning $ "git-annex sync will change default behavior in the future to" - <> " send content to repositories that have" + <> " sync content with repositories that have" <> " preferred content configured. If you do not want this to" - <> " send any content, use --no-content (or -g)" + <> " sync any content, use --no-content (or -g)" <> " to prepare for that change." <> " (Or you can configure annex.synccontent)" preferredcontentconfigured m u = diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -84,11 +84,12 @@ cst <- remoteCost gc c cheapRemoteCost let chunkconfig = getChunkConfig c cow <- liftIO newCopyCoWTried + fastcopy <- getFastCopy gc let ii = IgnoreInodes $ fromMaybe True $ getRemoteConfigValue ignoreinodesField c return $ Just $ specialRemote c - (storeKeyM dir chunkconfig cow) - (retrieveKeyFileM dir chunkconfig cow) + (storeKeyM dir chunkconfig cow fastcopy) + (retrieveKeyFileM dir chunkconfig cow fastcopy) (removeKeyM dir) (checkPresentM dir chunkconfig) Remote @@ -105,8 +106,8 @@ , checkPresent = checkPresentDummy , checkPresentCheap = True , exportActions = ExportActions - { storeExport = storeExportM dir cow - , retrieveExport = retrieveExportM dir cow + { storeExport = storeExportM dir cow fastcopy + , retrieveExport = retrieveExportM dir cow fastcopy , removeExport = removeExportM dir , checkPresentExport = checkPresentExportM dir -- Not needed because removeExportLocation @@ -118,7 +119,7 @@ { listImportableContents = listImportableContentsM ii dir , importKey = Just (importKeyM ii dir) , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM ii dir cow - , storeExportWithContentIdentifier = storeExportWithContentIdentifierM ii dir cow + , storeExportWithContentIdentifier = storeExportWithContentIdentifierM ii dir cow fastcopy , removeExportWithContentIdentifier = removeExportWithContentIdentifierM ii dir -- Not needed because removeExportWithContentIdentifier -- auto-removes empty directories. @@ -189,8 +190,8 @@ {- Check if there is enough free disk space in the remote's directory to - store the key. Note that the unencrypted key size is checked. -} -storeKeyM :: OsPath -> ChunkConfig -> CopyCoWTried -> Storer -storeKeyM d chunkconfig cow k c m = +storeKeyM :: OsPath -> ChunkConfig -> CopyCoWTried -> FastCopy -> Storer +storeKeyM d chunkconfig cow fastcopy k c m = ifM (checkDiskSpaceDirectory d k) ( do void $ liftIO $ tryIO $ createDirectoryUnder [d] tmpdir @@ -210,7 +211,7 @@ in byteStorer go k c m NoChunks -> let go _k src p = liftIO $ do - void $ fileCopier cow src tmpf p Nothing + void $ fileCopier cow fastcopy src tmpf p Nothing finalizeStoreGeneric d tmpdir destdir in fileStorer go k c m _ -> @@ -247,12 +248,12 @@ mapM_ preventWrite =<< dirContents dest preventWrite dest -retrieveKeyFileM :: OsPath -> ChunkConfig -> CopyCoWTried -> Retriever -retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations' d -retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do +retrieveKeyFileM :: OsPath -> ChunkConfig -> CopyCoWTried -> FastCopy -> Retriever +retrieveKeyFileM d (LegacyChunks _) _ _ = Legacy.retrieve locations' d +retrieveKeyFileM d NoChunks cow fastcopy = fileRetriever' $ \dest k p iv -> do src <- liftIO $ getLocation d k - void $ liftIO $ fileCopier cow src dest p iv -retrieveKeyFileM d _ _ = byteRetriever $ \k sink -> + void $ liftIO $ fileCopier cow fastcopy src dest p iv +retrieveKeyFileM d _ _ _ = byteRetriever $ \k sink -> sink =<< liftIO (F.readFile =<< getLocation d k) retrieveKeyFileCheapM :: OsPath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> OsPath -> Annex ()) @@ -327,8 +328,8 @@ ) ) -storeExportM :: OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () -storeExportM d cow src _k loc p = do +storeExportM :: OsPath -> CopyCoWTried -> FastCopy -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex () +storeExportM d cow fastcopy src _k loc p = do liftIO $ createDirectoryUnder [d] (takeDirectory dest) -- Write via temp file so that checkPresentGeneric will not -- see it until it's fully stored. @@ -336,12 +337,12 @@ where dest = exportPath d loc go tmp () = void $ liftIO $ - fileCopier cow src tmp p Nothing + fileCopier cow fastcopy src tmp p Nothing -retrieveExportM :: OsPath -> CopyCoWTried -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification -retrieveExportM d cow k loc dest p = +retrieveExportM :: OsPath -> CopyCoWTried -> FastCopy -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification +retrieveExportM d cow fastcopy k loc dest p = verifyKeyContentIncrementally AlwaysVerify k $ \iv -> - void $ liftIO $ fileCopier cow src dest p iv + void $ liftIO $ fileCopier cow fastcopy src dest p iv where src = exportPath d loc @@ -533,13 +534,13 @@ =<< R.getSymbolicLinkStatus f' guardSameContentIdentifiers cont cids currcid -storeExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier -storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do +storeExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> CopyCoWTried -> FastCopy -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier +storeExportWithContentIdentifierM ii dir cow fastcopy src _k loc overwritablecids p = do liftIO $ createDirectoryUnder [dir] destdir withTmpFileIn destdir template $ \tmpf tmph -> do let tmpf' = fromOsPath tmpf liftIO $ hClose tmph - void $ liftIO $ fileCopier cow src tmpf p Nothing + void $ liftIO $ fileCopier cow fastcopy src tmpf p Nothing resetAnnexFilePerm tmpf liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf >>= \case Nothing -> giveup "unable to generate content identifier" diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -440,7 +440,7 @@ inAnnex' repo rmt st key inAnnex' :: Git.Repo -> Remote -> State -> Key -> Annex Bool -inAnnex' repo rmt st@(State connpool duc _ _ _) key +inAnnex' repo rmt st@(State connpool duc _ _ _ _) key | isP2PHttp rmt = checkp2phttp | Git.repoIsHttp repo = checkhttp | Git.repoIsUrl repo = checkremote @@ -482,7 +482,7 @@ dropKey' repo r st proof key dropKey' :: Git.Repo -> Remote -> State -> Maybe SafeDropProof -> Key -> Annex () -dropKey' repo r st@(State connpool duc _ _ _) proof key +dropKey' repo r st@(State connpool duc _ _ _ _) proof key | isP2PHttp r = clientRemoveWithProof proof key unabletoremove r >>= \case RemoveResultPlus True fanoutuuids -> @@ -531,7 +531,7 @@ lockKey' repo r st key callback lockKey' :: Git.Repo -> Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r -lockKey' repo r st@(State connpool duc _ _ _) key callback +lockKey' repo r st@(State connpool duc _ _ _ _) key callback | isP2PHttp r = do showLocking r p2pHttpClient r giveup (clientLockContent key) >>= \case @@ -566,7 +566,7 @@ copyFromRemote'' repo r st key file dest meterupdate vc copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification -copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc +copyFromRemote'' repo r st@(State connpool _ _ _ _ _) key af dest meterupdate vc | isP2PHttp r = copyp2phttp | Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do gc <- Annex.getGitConfig @@ -642,7 +642,7 @@ copyToRemote' repo r st key af o meterupdate copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex () -copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate +copyToRemote' repo r st@(State connpool duc _ _ _ _) key af o meterupdate | isP2PHttp r = prepsendwith copyp2phttp | not $ Git.repoIsUrl repo = ifM duc ( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $ @@ -753,7 +753,7 @@ - when possible. -} onLocal :: State -> Annex a -> Annex a -onLocal (State _ _ _ _ lra) = onLocal' lra +onLocal (State _ _ _ _ _ lra) = onLocal' lra onLocalRepo :: Git.Repo -> Annex a -> Annex a onLocalRepo repo a = do @@ -830,7 +830,7 @@ -- done. Also returns Verified if the key's content is verified while -- copying it. mkFileCopier :: Bool -> State -> Annex FileCopier -mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do +mkFileCopier remotewanthardlink (State _ _ copycowtried fastcopy _ _) = do localwanthardlink <- wantHardLink let linker = \src dest -> R.createLink (fromOsPath src) (fromOsPath dest) >> return True if remotewanthardlink || localwanthardlink @@ -848,7 +848,7 @@ where copier src dest k p check verifyconfig = do iv <- startVerifyKeyContentIncrementally verifyconfig k - liftIO (fileCopier copycowtried src dest p iv) >>= \case + liftIO (fileCopier copycowtried fastcopy src dest p iv) >>= \case Copied -> ifM check ( finishVerifyKeyContentIncrementally iv , do @@ -864,24 +864,25 @@ - This returns False when the repository UUID is not as expected. -} type DeferredUUIDCheck = Annex Bool -data State = State Ssh.P2PShellConnectionPool DeferredUUIDCheck CopyCoWTried (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex +data State = State Ssh.P2PShellConnectionPool DeferredUUIDCheck CopyCoWTried FastCopy (Annex (Git.Repo, GitConfig)) LocalRemoteAnnex getRepoFromState :: State -> Annex Git.Repo -getRepoFromState (State _ _ _ a _) = fst <$> a +getRepoFromState (State _ _ _ _ a _) = fst <$> a #ifndef mingw32_HOST_OS {- The config of the remote git repository, cached for speed. -} getGitConfigFromState :: State -> Annex GitConfig -getGitConfigFromState (State _ _ _ a _) = snd <$> a +getGitConfigFromState (State _ _ _ _ a _) = snd <$> a #endif mkState :: Git.Repo -> UUID -> RemoteGitConfig -> Annex State mkState r u gc = do pool <- Ssh.mkP2PShellConnectionPool copycowtried <- liftIO newCopyCoWTried + fastcopy <- getFastCopy gc lra <- mkLocalRemoteAnnex r (duc, getrepo) <- go - return $ State pool duc copycowtried getrepo lra + return $ State pool duc copycowtried fastcopy getrepo lra where go | remoteAnnexCheckUUID gc = return diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -804,9 +804,10 @@ go Nothing = summarizeresults $ withConcurrentOutput $ do ensuredir tmpdir - crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem' - (toOsPath tmpdir) - Nothing Nothing False + crippledfilesystem <- fromMaybe False . fst + <$> Annex.Init.probeCrippledFileSystem' + (toOsPath tmpdir) + Nothing Nothing False adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported let ts = mkts numparts crippledfilesystem adjustedbranchok opts let warnings = fst (tastyParser ts) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -1,6 +1,6 @@ {- git-annex configuration - - - Copyright 2012-2024 Joey Hess + - Copyright 2012-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -135,6 +135,7 @@ , annexDifferences :: Differences , annexUsedRefSpec :: Maybe RefSpec , annexVerify :: Bool + , annexFastCopy :: Bool , annexPidLock :: Bool , annexPidLockTimeout :: Seconds , annexDbDir :: Maybe OsPath @@ -241,6 +242,7 @@ , annexUsedRefSpec = either (const Nothing) Just . parseRefSpec =<< getmaybe (annexConfig "used-refspec") , annexVerify = getbool (annexConfig "verify") True + , annexFastCopy = getbool (annexConfig "fastcopy") False , annexPidLock = getbool (annexConfig "pidlock") False , annexPidLockTimeout = Seconds $ fromMaybe 300 $ getmayberead (annexConfig "pidlocktimeout") @@ -387,6 +389,7 @@ , remoteAnnexPush :: Bool , remoteAnnexReadOnly :: Bool , remoteAnnexVerify :: Bool + , remoteAnnexFastCopy :: Bool , remoteAnnexCheckUUID :: Bool , remoteAnnexTrackingBranch :: Maybe Git.Ref , remoteAnnexTrustLevel :: Maybe String @@ -466,6 +469,7 @@ , remoteAnnexReadOnly = getbool ReadOnlyField False , remoteAnnexCheckUUID = getbool CheckUUIDField True , remoteAnnexVerify = getbool VerifyField True + , remoteAnnexFastCopy = getbool FastCopyField False , remoteAnnexTrackingBranch = Git.Ref . encodeBS <$> ( notempty (getmaybe TrackingBranchField) <|> notempty (getmaybe ExportTrackingField) -- old name @@ -574,6 +578,7 @@ | ReadOnlyField | CheckUUIDField | VerifyField + | FastCopyField | TrackingBranchField | ExportTrackingField | TrustLevelField @@ -644,6 +649,7 @@ ReadOnlyField -> inherited True "readonly" CheckUUIDField -> uninherited True "checkuuid" VerifyField -> inherited True "verify" + FastCopyField -> inherited True "fastcopy" TrackingBranchField -> uninherited True "tracking-branch" ExportTrackingField -> uninherited True "export-tracking" TrustLevelField -> uninherited True "trustlevel" diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -43,7 +43,12 @@ {- The cp command is used, because I hate reinventing the wheel, - and because this allows easy access to features like cp --reflink - - and preserving metadata. -} + - and preserving metadata. + - + - This uses --reflink=auto when supported, which allows for fast copies + - using reflinks or the copy_file_range syscall. Whatever cp thinks is + - best. --reflink=auto is the default of recent versions of cp, but is + - used explicitly to support older versions. -} copyFileExternal :: CopyMetaData -> OsPath -> OsPath -> IO Bool copyFileExternal meta src dest = do -- Delete any existing dest file because an unwritable file @@ -81,8 +86,8 @@ | otherwise = return False where -- Note that in coreutils 9.0, cp uses CoW by default, - -- without needing an option. This s only needed to support - -- older versions. + -- without needing an option. But, this makes it fail if it is + -- unable to make a CoW copy. params = Param "--reflink=always" : copyMetaDataParams meta {- Create a hard link if the filesystem allows it, and fall back to copying diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -65,10 +65,12 @@ let (ok, e') = case r of Left err -> (False, err) Right _ -> (True, e) + when ok $ + void $ tryIO $ removeFile src #endif unless ok $ do -- delete any partial - _ <- tryIO $ removeFile tmp + void $ tryIO $ removeFile tmp throwM e' #ifndef mingw32_HOST_OS 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.20250520 +Version: 10.20250605 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess