diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -39,20 +39,24 @@ import Annex.Hook import Utility.Hash (IncrementalVerifier) import Utility.IPAddress -import Network.HTTP.Client.Restricted import Utility.Metered +import Utility.Env import Git.Credential import qualified BuildInfo import Network.Socket import Network.HTTP.Client import Network.HTTP.Client.TLS +import Network.HTTP.Client.Restricted +import Network.Connection import Text.Read import qualified Data.Set as S #if MIN_VERSION_tls(2,0,0) import qualified Network.Connection as NC import qualified Network.TLS as TLS #endif +import Network.Connection.Internal (ConnectionContext(..)) +import Data.X509.CertificateStore defaultUserAgent :: U.UserAgent defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion @@ -100,8 +104,9 @@ then U.DownloadWithConduit $ U.DownloadWithCurlRestricted mempty else U.DownloadWithCurl curlopts + ctx <- mkconnectioncontext manager <- liftIO $ U.newManager $ - avoidtimeout managersettings + avoidtimeout $ managersettings ctx return (urldownloader, manager) allowedaddrsports -> do addrmatcher <- liftIO $ @@ -122,8 +127,9 @@ if isallowed (addrAddress addr) then Nothing else Just (connectionrestricted addr) - (settings, pr) <- liftIO $ - mkRestrictedManagerSettings r Nothing tlssettings + ctx <- mkconnectioncontext + (settings, pr) <- liftIO $ + mkRestrictedManagerSettings r (Just ctx) tlssettings case pr of Nothing -> return () Just ProxyRestricted -> toplevelWarning True @@ -146,10 +152,26 @@ def { TLS.supportedExtendedMainSecret = TLS.AllowEMS } #endif | otherwise = Nothing - managersettings = case tlssettings of - Nothing -> tlsManagerSettings - Just v -> mkManagerSettings v Nothing + managersettings ctx = case tlssettings of + Nothing -> mkManagerSettingsContext (Just ctx) def Nothing + Just v -> mkManagerSettingsContext (Just ctx) v Nothing + + mkconnectioncontext = + getCAPath >>= \case + Just p -> liftIO $ mkconnectioncontext' p + Nothing -> liftIO $ initConnectionContext + mkconnectioncontext' p = + ConnectionContext . fromMaybe mempty + <$> readCertificateStore p + + getCAPath = getM id + [ liftIO (getEnv "GIT_SSL_CAINFO") + , liftIO (getEnv "GIT_SSL_CAPATH") + , httpSslCAInfo <$> Annex.getGitConfig + , httpSslCAPath <$> Annex.getGitConfig + ] + -- http-client defailts to timing out a request after 30 seconds -- or so, but some web servers are slower and git-annex has its own -- separate timeout controls, so disable that. diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -14,9 +14,6 @@ import Utility.FreeDesktop #ifdef darwin_HOST_OS import Utility.OSX -import Utility.Path -import Utility.SystemDirectory -import Utility.FileSystemEncoding #endif installAutoStart :: String -> OsPath -> IO () diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,32 @@ -git-annex (10.20260420) upstream; urgency=medium +git-annex (10.20260520) upstream; urgency=medium + + * Behavior change: git-annex sync now defaults to syncing content, + for consistency with push and pull. However, to avoid surprising + behavior, this only affects repositories that have preferred content + configured. + (Use --no-content or configure annex.synccontent to avoid this.) + * Behavior change to git-annex pull and push's handling of unwanted + files. While previously both commands dropped unwanted files from + both the remote and the local repository, now pull only drops unwanted + files from the local repository, and push only drops unwanted files + from the remote. + * info: Report the total size of unused keys found by the last run + of git-annex unused. + * push: When pushing to a bare git repository, display git push + progress before the display of pushed branches. + * push, pull, assist: Fix behavior of --content to override the + annex.synccontent configuration. + * Send git-annex (or other configured) User-Agent when connecting to + annex+http remotes. + * Support GIT_SSL_CAINFO, GIT_SSL_CAPATH, http.sslCAPath, and http.sslCAPath + when connecting to https servers. + * Linux standalone builds now bundle CA certs. They are used only when + the system does not have its own CA cert store. + * Linux standalone build supports using Fedora's CA cert store location. + + -- Joey Hess Wed, 20 May 2026 09:16:07 -0400 + +git-annex (10.20260421) upstream; urgency=medium * disableremote: New command. * Fix annexUrl to inherit any password that is set in the remote url. diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011-2025 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -33,6 +33,7 @@ import Logs.UUID import Logs.Trust import Logs.Location +import Logs.Unused import Annex.Branch (UnmergedBranches(..), getUnmergedRefs) import Annex.NumCopies import Git.Config (boolConfig) @@ -293,6 +294,7 @@ global_slow_stats = [ tmp_size , bad_data_size + , unused_data_size , local_annex_keys , local_annex_size , known_annex_files True @@ -469,11 +471,16 @@ treeDesc False = "tree" tmp_size :: Stat -tmp_size = staleSize "temporary object directory size" gitAnnexTmpObjectDir +tmp_size = staleDirSize "temporary object directory size" gitAnnexTmpObjectDir bad_data_size :: Stat -bad_data_size = staleSize "bad keys size" gitAnnexBadDir +bad_data_size = staleDirSize "bad keys size" gitAnnexBadDir +unused_data_size :: Stat +unused_data_size = staleSize "unused keys size" + (M.keys <$> readUnusedLog (literalOsPath "")) + (pure (calcRepo . gitAnnexLocation)) + key_size :: Key -> Stat key_size k = simpleStat "size" $ showSizeKeys $ addKey k emptyKeyInfo @@ -829,11 +836,18 @@ "+ " ++ show (unknownSizeKeys d) ++ " unknown size" -staleSize :: String -> (Git.Repo -> OsPath) -> Stat -staleSize label dirspec = Stat label $ do - keys <- lift $ dirKeys dirspec - onsize =<< sum <$> keysizes keys +staleDirSize :: String -> (Git.Repo -> OsPath) -> Stat +staleDirSize label dirspec = staleSize label (dirKeys dirspec) getpath where + getpath = do + dir <- fromRepo dirspec + return (\k -> pure (dir keyFile k)) + +staleSize :: String -> Annex [Key] -> (Annex (Key -> Annex OsPath)) -> Stat +staleSize label listkeys getpath = Stat label $ do + keys <- lift listkeys + onsize =<< sum <$> lift (keysizes keys) + where onsize 0 = return Nothing onsize size = return $ Just $ let val = do @@ -841,9 +855,10 @@ return $ sizer storageUnits False size in json (++ aside "clean up with git-annex unused") val label keysizes keys = do - dir <- lift $ fromRepo dirspec - liftIO $ forM keys $ \k -> - catchDefaultIO 0 $ getFileSize (dir keyFile k) + getpath' <- getpath + forM keys $ \k -> do + p <- getpath' k + liftIO $ catchDefaultIO 0 $ getFileSize p aside :: String -> String aside s = " (" ++ s ++ ")" diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -12,8 +12,8 @@ import Command import RemoteDaemon.Core import Utility.Daemon -import qualified Annex #ifndef mingw32_HOST_OS +import qualified Annex import Annex.Path import Utility.OpenFd #endif diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -273,7 +273,6 @@ ] remotes <- mapM (pushToCreate o) =<< syncRemotes (syncWith o) - warnSyncContentTransition o remotes -- Remotes that git can push to and pull from. let gitremotes = filter Remote.gitSyncableRemote remotes -- Remotes that contain annex object content. @@ -290,14 +289,16 @@ , [ mergeAnnex ] ] - content <- shouldSyncContent o + (content, syncwith) <- shouldSyncContent o + changehere <- syncwith <$> getUUID + let pushremotes = filter (syncwith . Remote.uuid) contentremotes when content $ whenM (annexSyncMigrations <$> Annex.getGitConfig) $ Command.Migrate.seekDistributedMigrations True forM_ (filter isImport contentremotes) $ - withbranch . importRemote content o + withbranch . importRemote changehere o forM_ (filter isThirdPartyPopulated contentremotes) $ pullThirdPartyPopulated o @@ -306,7 +307,7 @@ -- repositories, in case that lets content -- be dropped from other repositories. exportedcontent <- withbranch $ - seekExportContent (Just o) contentremotes + seekExportContent (Just o) pushremotes -- Sync content with remotes, including -- importing from import remotes (since @@ -319,6 +320,8 @@ syncedcontent <- withbranch $ seekSyncContent o (filter shouldsynccontent contentremotes) + (filter shouldsynccontent pushremotes) + changehere -- Transferring content can take a while, -- and other changes can be pushed to the @@ -736,25 +739,36 @@ -} pushBranch :: Remote -> Maybe Git.Branch -> MessageState -> Git.Repo -> IO Bool pushBranch remote mbranch ms g = do - directpush - annexpush `after` syncpush + directpushed <- directpush + annexpush `after` syncpush directpushed where directpush = case mbranch of Just branch -> do - let p = flip Git.Command.gitCreateProcess g $ pushparams - [ Git.fromRef $ Git.Ref.base $ origBranch branch ] + let p = flip Git.Command.gitCreateProcess g $ + pushparams True + [ Git.fromRef $ Git.Ref.base $ origBranch branch ] let p' = p { std_err = CreatePipe } bracket (createProcess p') cleanupProcess $ \h -> do filterstderr [] (stderrHandle h) (processHandle h) void $ waitForProcess (processHandle h) - Nothing -> noop + return True + Nothing -> return False - syncpush = flip Git.Command.runBool g $ pushparams $ catMaybes - [ (syncrefspec . origBranch) <$> mbranch - , Just $ Git.Branch.forcePush $ syncrefspec Annex.Branch.name - ] + syncpush directpushed = do + let p = flip Git.Command.gitCreateProcess g $ + pushparams (not directpushed) $ catMaybes + [ (syncrefspec . origBranch) <$> mbranch + , Just $ Git.Branch.forcePush $ syncrefspec Annex.Branch.name + ] + -- stderr is relayed through a pipe so that the push + -- progress is not displayed a second time when the + -- directpush already displayed push progress. + let p' = p { std_err = CreatePipe } + bracket (createProcess p') cleanupProcess $ \h -> do + relaystderr (stderrHandle h) (processHandle h) + checkSuccessProcess (processHandle h) - annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams + annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams False [ Git.fromRef $ Git.Ref.base $ Annex.Branch.name ] -- In the default configuration of receive.denyCurrentBranch, @@ -779,11 +793,19 @@ unless (any ("receive.denyCurrentBranch" `isInfixOf`) buf) $ mapM_ (hPutStrLn stderr) (reverse buf) - pushparams branches = catMaybes + relaystderr herr pid = hGetLineUntilExitOrEOF pid herr >>= \case + Just l -> do + hPutStrLn stderr l + relaystderr herr pid + Nothing -> return () + + pushparams forceprogress branches = catMaybes [ Just $ Param "push" , if commandProgressDisabled' ms then Just $ Param "--quiet" - else Nothing + else if forceprogress + then Just $ Param "--progress" + else Nothing , Just $ Param $ Remote.name remote ] ++ map Param branches @@ -833,9 +855,10 @@ - - When concurrency is enabled, files are processed concurrently. -} -seekSyncContent :: SyncOptions -> [Remote] -> CurrBranch -> Annex Bool -seekSyncContent _ [] _ = return False -seekSyncContent o rs currbranch = do +seekSyncContent :: SyncOptions -> [Remote] -> [Remote] -> Bool -> CurrBranch -> Annex Bool +seekSyncContent _ [] _ _ _ = return False +seekSyncContent _ _ [] False _ = return False +seekSyncContent o rs pushrs changehere currbranch = do mvar <- liftIO newEmptyMVar bloom <- case keyOptions o of Just WantAllKeys -> ifM preferredcontentmatchesfilenames @@ -894,7 +917,7 @@ go ebloom mvar af k = do let ai = OnlyActionOn k (ActionItemKey k) startingNoMessage ai $ do - whenM (syncFile o ebloom rs af k) $ + whenM (syncFile o ebloom rs pushrs changehere af k) $ void $ liftIO $ tryPutMVar mvar () next $ return True @@ -907,21 +930,23 @@ {- If it's preferred content, and we don't have it, get it from one of the - listed remotes (preferring the cheaper earlier ones). - - - Send it to each remote that doesn't have it, and for which it's + - Send it to each pushrs that doesn't have it, and for which it's - preferred content. - - - Drop it locally if it's not preferred content (honoring numcopies). - - - - Drop it from each remote that has it, where it's not preferred content + - When pulling, drop it locally if it's not preferred content - (honoring numcopies). + - + - When pushing, drop it from each remote that has it, where it's + - not preferred content (honoring numcopies). - - Returns True if any file transfers were made. -} -syncFile :: SyncOptions -> Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool -syncFile o ebloom rs af k = do +syncFile :: SyncOptions -> Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> [Remote] -> Bool -> AssociatedFile -> Key -> Annex Bool +syncFile o ebloom rs pushrs changehere af k = do inhere <- inAnnex k locs <- map Remote.uuid <$> Remote.keyPossibilities (Remote.IncludeIgnored False) k - let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs + let have = filter (\r -> Remote.uuid r `elem` locs) rs + let lack = filter (\r -> Remote.uuid r `notElem` locs) pushrs got <- anyM id =<< handleget have inhere let inhere' = inhere || got @@ -949,29 +974,32 @@ -- includeCommandAction for drops, -- because a failure to drop does not mean -- the sync failed. - handleDropsFrom locs' rs "unwanted" True k af si [] + handleDropsFrom locs' dropfromrs "unwanted" dropfromhere + k af si [] callCommandAction return (got || not (null putrs)) where wantget lu have inhere = allM id - [ pure (pullOption o || operationMode o == SatisfyMode) + [ pure (pullOption o || satisfymode) , pure (not $ null have) , pure (not inhere) , wantGet lu True (Just k) af ] - handleget have inhere = do - lu <- prepareLiveUpdate Nothing k AddingKey - ifM (wantget lu have inhere) - ( return [ get lu have ] - , return [] - ) + handleget have inhere + | changehere = do + lu <- prepareLiveUpdate Nothing k AddingKey + ifM (wantget lu have inhere) + ( return [ get lu have ] + , return [] + ) + | otherwise = return [] get lu have = includeCommandAction $ starting "get" ai si $ stopUnless (getKey' lu k af have) $ next $ return True wantput lu r - | pushOption o == False && operationMode o /= SatisfyMode = return False + | pushOption o == False && not satisfymode = return False | Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False | isImport r && not (isExport r) = return False | isExport r && not (exportHasAnnexObjects r) = return False @@ -989,7 +1017,15 @@ | otherwise = return [] put lu dest = includeCommandAction $ Command.Move.toStart' lu dest Command.Move.RemoveNever af k ai si + + dropfromhere = changehere && (pullOption o || satisfymode) + dropfromrs + | pushOption o || satisfymode = pushrs + | otherwise = [] + + satisfymode = operationMode o == SatisfyMode + ai = mkActionItem (k, af) si = SeekInput [] @@ -1128,48 +1164,43 @@ ai = ActionItemOther (Just (UnquotedString (Remote.name remote))) si = SeekInput [] -shouldSyncContent :: SyncOptions -> Annex Bool +getAnnexSyncContent :: Annex (Maybe Bool) +getAnnexSyncContent = + getGitConfigVal' annexSyncContent >>= return . \case + HasGlobalConfig (Just c) -> Just c + HasGitConfig (Just c) -> Just c + _ -> Nothing + +{- Should content be synced at all, and given a UUID, should it be synced + - with that uuid? -} +shouldSyncContent :: SyncOptions -> Annex (Bool, UUID -> Bool) shouldSyncContent o - | fromMaybe False (noContentOption o) = pure False - | operationMode o == SatisfyMode = pure True - -- For git-annex pull and git-annex push and git-annex assist, - -- annex.syncontent defaults to True unless set - | operationMode o /= SyncMode = annexsynccontent True - | fromMaybe False (contentOption o) || not (null (contentOfOption o)) = pure True - -- For git-annex sync, - -- annex.syncontent defaults to False unless set - | otherwise = annexsynccontent False <||> onlyAnnex o + | fromMaybe False (noContentOption o) = neversync + | fromMaybe False (contentOption o) = alwayssync + | not (null (contentOfOption o)) = alwayssync + | operationMode o == SatisfyMode = alwayssync + | operationMode o == SyncMode = + ifM (onlyAnnex o) + ( alwayssync + , getAnnexSyncContent >>= \case + Just b -> syncwhen b + Nothing -> syncwhenpreferredcontentconfigured + ) + | otherwise = syncwhen =<< fromMaybe True <$> getAnnexSyncContent where - annexsynccontent d = - getGitConfigVal' annexSyncContent >>= \case - HasGlobalConfig (Just c) -> return c - HasGitConfig (Just c) -> return c - _ -> return d + syncwhen b = pure (b, const b) + alwayssync = syncwhen True + neversync = syncwhen False --- See doc/todo/finish_sync_content_transition.mdwn -warnSyncContentTransition :: SyncOptions -> [Remote] -> Annex () -warnSyncContentTransition o remotes - | operationMode o /= SyncMode = noop - | isJust (noContentOption o) || isJust (contentOption o) = noop - | not (null (contentOfOption o)) = noop - | otherwise = getGitConfigVal' annexSyncContent >>= \case - HasGlobalConfig (Just _) -> noop - HasGitConfig (Just _) -> noop - _ -> do - m <- preferredContentMap - hereu <- getUUID - when (any (preferredcontentconfigured m) (hereu:map Remote.uuid remotes)) $ - showwarning - where - showwarning = earlyWarning $ - "git-annex sync will change default behavior in the future to" - <> " sync content with repositories that have" - <> " preferred content configured. If you do not want this to" - <> " sync any content, use --no-content (or -g)" - <> " to prepare for that change." - <> " (Or you can configure annex.synccontent)" - preferredcontentconfigured m u = - maybe False (not . isEmpty . fst) (M.lookup u m) + {- This handles the special case of git-annex sync defaulting to only + - syncing content with repositories that have preferred content + - configured. -} + syncwhenpreferredcontentconfigured = do + m <- preferredContentMap + let checkisconfigured u = + maybe False (not . isEmpty . fst) + (M.lookup u m) + return (True, checkisconfigured) notOnlyAnnex :: SyncOptions -> Annex Bool notOnlyAnnex o = not <$> onlyAnnex o @@ -1179,7 +1210,7 @@ | notOnlyAnnexOption o = pure False | onlyAnnexOption o = pure True | otherwise = getGitConfigVal annexSyncOnlyAnnex - + isExport :: Remote -> Bool isExport = exportTree . Remote.config diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -150,7 +150,7 @@ unusedMsg' u mheader mtrailer = unlines $ mheader ++ table u ++ - ["(To see where this data was previously used, run: git annex whereused --historical --unused"] ++ + ["(To see where this data was previously used, run: git annex whereused --historical --unused)"] ++ mtrailer remoteUnusedMsg :: Maybe Remote -> RemoteName -> [(Int, Key)] -> String diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -94,14 +94,19 @@ case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of Nothing -> error "internal" Just baseurl -> do - mgr <- httpManager <$> getUrlOptions Nothing - let clientenv = mkClientEnv mgr baseurl + uo <- getUrlOptions (Just (gitconfig rmt)) + let clientenv = mkClientEnv (httpManager uo) baseurl + let clientenv' = clientenv + { makeClientRequest = \u r -> + applyRequest uo + <$> makeClientRequest clientenv u r + } ccv <- Annex.getRead Annex.gitcredentialcache Git.CredentialCache cc <- liftIO $ atomically $ readTMVar ccv case M.lookup (Git.CredentialBaseURL credentialbaseurl) cc of - Nothing -> go clientenv Nothing False Nothing versions - Just cred -> go clientenv (Just cred) True (credauth cred) versions + Nothing -> go clientenv' Nothing False Nothing versions + Just cred -> go clientenv' (Just cred) True (credauth cred) versions where versions = filter allowedversion allProtocolVersions go clientenv mcred credcached mauth (v:vs) = do diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -165,6 +165,8 @@ , coreSharedRepository :: SharedRepository , coreQuotePath :: QuotePath , receiveDenyCurrentBranch :: DenyCurrentBranch + , httpSslCAInfo :: Maybe String + , httpSslCAPath :: Maybe String , gcryptId :: Maybe String , gpgCmd :: GpgCmd , mergeDirectoryRenames :: Maybe String @@ -296,6 +298,8 @@ , coreSharedRepository = getSharedRepository r , coreQuotePath = QuotePath (getbool "core.quotepath" True) , receiveDenyCurrentBranch = getDenyCurrentBranch r + , httpSslCAInfo = getmaybe "http.sslcainfo" + , httpSslCAPath = getmaybe "http.sslcapath" , gcryptId = getmaybe "core.gcrypt-id" , gpgCmd = mkGpgCmd (getmaybe "gpg.program") , mergeDirectoryRenames = getmaybe "directoryrenames" diff --git a/Utility/Env.hs b/Utility/Env.hs --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -19,7 +19,6 @@ #ifdef mingw32_HOST_OS import Utility.Exception -import Control.Applicative import Data.Maybe import qualified System.Environment as E #else diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -80,5 +80,7 @@ (Right s) -> return $ isDirectory s #endif +#ifndef mingw32_HOST_OS copyright :: Copyright copyright = author JoeyHess (2022-11) +#endif 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.20260421 +Version: 10.20260520 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -232,7 +232,7 @@ edit-distance, resourcet, http-client (>= 0.5.3), - http-client-tls, + http-client-tls (>= 0.3.2), http-types (>= 0.7), http-conduit (>= 2.3.0), http-client-restricted (>= 0.0.2), @@ -274,7 +274,8 @@ git-lfs (>= 1.2.0), clock (>= 0.3.0), crypton, - crypton-connection, + crypton-connection (>= 0.4.3), + crypton-x509-store, tls, servant, servant-server,