diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -1,6 +1,6 @@ {- git-annex monad - - - Copyright 2010-2024 Joey Hess + - Copyright 2010-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -190,6 +190,7 @@ , remotes :: [Types.Remote.RemoteA Annex] , output :: MessageState , concurrency :: ConcurrencySetting + , cpus :: Maybe Cpus , daemon :: Bool , repoqueue :: Maybe (Git.Queue.Queue Annex) , catfilehandles :: CatFileHandles @@ -248,6 +249,7 @@ , remotes = [] , output = o , concurrency = ConcurrencyCmdLine NonConcurrent + , cpus = Nothing , daemon = False , repoqueue = Nothing , catfilehandles = catFileHandlesNonConcurrent diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,6 +1,6 @@ {- management of the git-annex branch - - - Copyright 2011-2024 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -13,6 +13,7 @@ hasOrigin, hasSibling, siblingBranches, + remoteTrackingBranch, create, getBranch, UpdateMade(..), @@ -105,13 +106,18 @@ fullname :: Git.Ref fullname = Git.Ref $ "refs/heads/" <> fromRef' name -{- Branch's name in origin. -} -originname :: Git.Ref -originname = Git.Ref $ "refs/remotes/origin/" <> fromRef' name +{- The remote tracking branch for origin. -} +originTrackingBranch :: Git.Ref +originTrackingBranch = Git.Ref $ "refs/remotes/origin/" <> fromRef' name +{- Name of the remote tracking branch for a remote. -} +remoteTrackingBranch :: RemoteName -> Git.Ref +remoteTrackingBranch remotename = Git.Ref $ + "refs/remotes/" <> encodeBS remotename <> "/" <> fromRef' name + {- Does origin/git-annex exist? -} hasOrigin :: Annex Bool -hasOrigin = inRepo $ Git.Ref.exists originname +hasOrigin = inRepo $ Git.Ref.exists originTrackingBranch {- Does the git-annex branch or a sibling foo/git-annex branch exist? -} hasSibling :: Annex Bool @@ -135,7 +141,7 @@ [ Param "branch" , Param "--no-track" , Param $ fromRef name - , Param $ fromRef originname + , Param $ fromRef originTrackingBranch ] fromMaybe (giveup $ "failed to create " ++ fromRef name) <$> branchsha diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -1,6 +1,6 @@ {- git-annex concurrent state - - - Copyright 2015-2022 Joey Hess + - Copyright 2015-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -61,6 +61,9 @@ , Annex.hashobjecthandle = Just hoh , Annex.checkignorehandle = Just cih } + +setCpus :: Cpus -> Annex () +setCpus n = Annex.changeState $ \s -> s { Annex.cpus = Just n } {- Allows forking off a thread that uses a copy of the current AnnexState - to run an Annex action. diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -1,12 +1,12 @@ {- Url downloading, with git-annex user agent and configured http - headers, security restrictions, etc. - - - Copyright 2013-2022 Joey Hess + - Copyright 2013-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, CPP #-} module Annex.Url ( withUrlOptions, @@ -48,6 +48,8 @@ import Network.HTTP.Client.TLS import Text.Read import qualified Data.Set as S +import qualified Network.Connection as NC +import qualified Network.TLS as TLS defaultUserAgent :: U.UserAgent defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion @@ -66,7 +68,7 @@ return uo where mk = do - (urldownloader, manager) <- checkallowedaddr + (urldownloader, manager) <- mk' =<< Annex.getGitConfig U.mkUrlOptions <$> (Just <$> getUserAgent) <*> headers @@ -87,7 +89,7 @@ pure (remoteAnnexWebOptions gc) _ -> annexWebOptions <$> Annex.getGitConfig - checkallowedaddr = words . annexAllowedIPAddresses <$> Annex.getGitConfig >>= \case + mk' gc = case words (annexAllowedIPAddresses gc) of ["all"] -> do curlopts <- map Param <$> getweboptions allowedurlschemes <- annexAllowedUrlSchemes <$> Annex.getGitConfig @@ -96,7 +98,7 @@ U.DownloadWithCurlRestricted mempty else U.DownloadWithCurl curlopts manager <- liftIO $ U.newManager $ - avoidtimeout $ tlsManagerSettings + avoidtimeout managersettings return (urldownloader, manager) allowedaddrsports -> do addrmatcher <- liftIO $ @@ -118,7 +120,7 @@ then Nothing else Just (connectionrestricted addr) (settings, pr) <- liftIO $ - mkRestrictedManagerSettings r Nothing Nothing + mkRestrictedManagerSettings r Nothing tlssettings case pr of Nothing -> return () Just ProxyRestricted -> toplevelWarning True @@ -130,6 +132,20 @@ let urldownloader = U.DownloadWithConduit $ U.DownloadWithCurlRestricted r return (urldownloader, manager) + where + -- When configured, allow TLS 1.2 without EMS. + -- In tls-2.0, the default was changed from + -- TLS.AllowEMS to TLS.RequireEMS. + tlssettings +#if MIN_VERSION_tls(2,0,0) + | annexAllowInsecureHttps gc = Just $ + NC.TLSSettingsSimple False False False + def { TLS.supportedExtendedMainSecret = TLS.AllowEMS } +#endif + | otherwise = Nothing + managersettings = case tlssettings of + Nothing -> tlsManagerSettings + Just v -> mkManagerSettings v Nothing -- 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 diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -113,7 +113,7 @@ installFileManagerHooks :: OsPath -> IO () #ifdef linux_HOST_OS installFileManagerHooks program = unlessM osAndroid $ do - let actions = ["get", "drop", "undo"] + let actions = ["get", "drop"] -- Gnome nautilusScriptdir <- (\d -> d literalOsPath "nautilus" literalOsPath "scripts") <$> userDataDir diff --git a/Backend/URL.hs b/Backend/URL.hs --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -1,13 +1,14 @@ {- git-annex URL backend -- keys whose content is available from urls. - - - Copyright 2011-2024 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Backend.URL ( backends, - fromUrl + fromUrl, + otherUrlKey, ) where import Annex.Common @@ -41,3 +42,12 @@ , keyVariety = if verifiable then VURLKey else URLKey , keySize = size } + +{- From an URL key to a VURL key and vice-versa. -} +otherUrlKey :: Key -> Maybe Key +otherUrlKey k + | fromKey keyVariety k == URLKey = Just $ + alterKey k $ \kd -> kd { keyVariety = VURLKey } + | fromKey keyVariety k == VURLKey = Just $ + alterKey k $ \kd -> kd { keyVariety = URLKey } + | otherwise = Nothing diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,37 @@ +git-annex (10.20260213) upstream; urgency=medium + + * When used with git forges that allow Push to Create, the remote's + annex-uuid is re-probed after the initial push. + * addurl, importfeed: Enable --verifiable by default. + * fromkey, registerurl: When passed an url, generate a VURL key. + * unregisterurl: Unregister both VURL and URL keys. + * Fix behavior of local git remotes that have annex-ignore + set to be the same as ssh git remotes. + * Added annex.security.allow-insecure-https config, which allows + using old http servers that use TLS 1.2 without Extended Main + Secret support. + * p2phttp: Commit git-annex branch changes promptly. + * p2phttp: Fix a server stall by disabling warp's slowloris attack + prevention. + * p2phttp: Added --cpus option. + * Avoid ever starting more capabilities than the number of cpus. + * fsck: Support repairing a corrupted file in a versioned S3 remote. + * Fix incorrect transfer direction in remote transfer log when + downloading from a local git remote. + * Fix bug that prevented 2 clones of a local git remote + from concurrently downloading the same file. + * rsync: Avoid deleting contents of a non-empty directory when + removing the last exported file from the directory. + * unregisterurl: Fix display of action to not be "registerurl". + * The OsPath build flag requires file-io 0.2.0, which fixes several + issues. + * Remove deprecated commands direct, indirect, proxy, and transferkeys. + * Deprecate undo command. + * Remove undo action from kde and nautilus integrations. + * Fix build on BSDs. Thanks, Greg Steuck + + -- Joey Hess Fri, 13 Feb 2026 12:53:48 -0400 + git-annex (10.20260115) upstream; urgency=medium * New git configs annex.initwanted, annex.initrequired, and diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -1,6 +1,6 @@ {- git-annex command-line actions and concurrency - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -247,7 +247,7 @@ goconcurrentpercpu where goconcurrent n = do - raisecapabilitiesto n + raiseCapabilitiesForJobs n withMessageState $ \s -> case outputType s of NormalOutput -> ifM (liftIO concurrentOutputSupported) ( Regions.displayConsoleRegions $ @@ -269,11 +269,6 @@ setconcurrentoutputenabled b = Annex.changeState $ \s -> s { Annex.output = (Annex.output s) { concurrentOutputEnabled = b } } - - raisecapabilitiesto n = do - c <- liftIO getNumCapabilities - when (n > c) $ - liftIO $ setNumCapabilities n initworkerpool n = do tv <- liftIO newEmptyTMVarIO @@ -345,3 +340,12 @@ else reachedlimit reachedlimit = Annex.changeState $ \s -> s { Annex.reachedlimit = True } + +raiseCapabilitiesForJobs :: Int -> Annex () +raiseCapabilitiesForJobs njobs = do + ncpus <- maybe (liftIO getNumProcessors) (\(Cpus n) -> return n) + =<< Annex.getState Annex.cpus + let n = min ncpus njobs + c <- liftIO getNumCapabilities + when (n > c) $ + liftIO $ setNumCapabilities n diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -39,7 +39,6 @@ import qualified Command.DropKey import qualified Command.Transferrer import qualified Command.TransferKey -import qualified Command.TransferKeys import qualified Command.SetPresentKey import qualified Command.ReadPresentKey import qualified Command.CheckPresentKey @@ -112,14 +111,11 @@ import qualified Command.Import import qualified Command.Export import qualified Command.Map -import qualified Command.Direct -import qualified Command.Indirect import qualified Command.Upgrade import qualified Command.Forget import qualified Command.OldKeys import qualified Command.P2P import qualified Command.P2PHttp -import qualified Command.Proxy import qualified Command.DiffDriver import qualified Command.Smudge import qualified Command.FilterProcess @@ -212,7 +208,6 @@ , Command.DropKey.cmd , Command.Transferrer.cmd , Command.TransferKey.cmd - , Command.TransferKeys.cmd , Command.SetPresentKey.cmd , Command.ReadPresentKey.cmd , Command.CheckPresentKey.cmd @@ -245,14 +240,11 @@ , Command.Inprogress.cmd , Command.Migrate.cmd , Command.Map.cmd - , Command.Direct.cmd - , Command.Indirect.cmd , Command.Upgrade.cmd , Command.Forget.cmd , Command.OldKeys.cmd , Command.P2P.cmd , Command.P2PHttp.cmd - , Command.Proxy.cmd , Command.DiffDriver.cmd , Command.Smudge.cmd , Command.FilterProcess.cmd diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -1,6 +1,6 @@ {- git-annex command-line option parsing - - - Copyright 2010-2024 Joey Hess + - Copyright 2010-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -541,6 +541,21 @@ ( long "jobs" <> short 'J' <> metavar (paramNumber `paramOr` "cpus") <> help "enable concurrent jobs" + <> hidden + ) + +cpusOption :: [AnnexOption] +cpusOption = + [ annexOption (setAnnexState . setCpus) + cpusOptionParser + ] + +cpusOptionParser :: Parser Cpus +cpusOptionParser = + option (maybeReader parseCpus) + ( long "cpus" + <> metavar paramNumber + <> help "how many cpus to run jobs on" <> hidden ) diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011-2024 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -61,7 +61,7 @@ data DownloadOptions = DownloadOptions { relaxedOption :: Bool - , verifiableOption :: Bool + , oldVerifiableOption :: Bool -- no longer configurable , rawOption :: Bool , noRawOption :: Bool , rawExceptOption :: Maybe (DeferredParse Remote) @@ -101,7 +101,7 @@ <*> switch ( long "verifiable" <> short 'V' - <> help "improve later verification of --fast or --relaxed content" + <> help "no longer needed, verifiable urls are used by default" ) <*> switch ( long "raw" @@ -221,7 +221,7 @@ downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> OsPath -> Maybe Integer -> Annex (Maybe Key) downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do - let urlkey = Backend.URL.fromUrl uri sz (verifiableOption o) + let urlkey = Backend.URL.fromUrl uri sz True createWorkTreeDirectory (parentDir file) ifM (Annex.getRead Annex.fast <||> pure (relaxedOption o)) ( do @@ -351,7 +351,7 @@ downloadWeb addunlockedmatcher o url urlinfo file = go =<< downloadWith' downloader urlkey webUUID url file where - urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing (verifiableOption o) + urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing True downloader f p = Url.withUrlOptions Nothing $ downloadUrl False urlkey p Nothing [url] f go Nothing = return Nothing @@ -395,7 +395,7 @@ warning (UnquotedString youtubeDlCommand <> " did not download anything") return Nothing mediaurl = setDownloader url YoutubeDownloader - mediakey = Backend.URL.fromUrl mediaurl Nothing (verifiableOption o) + mediakey = Backend.URL.fromUrl mediaurl Nothing True -- Does the already annexed file have the mediaurl -- as an url? If so nothing to do. alreadyannexed dest k = do @@ -443,7 +443,7 @@ -- used to prevent two threads running concurrently when that would -- likely fail. ai = OnlyActionOn urlkey (ActionItemOther (Just (UnquotedString url))) - urlkey = Backend.URL.fromUrl url Nothing (verifiableOption (downloadOptions o)) + urlkey = Backend.URL.fromUrl url Nothing True showDestinationFile :: OsPath -> Annex () showDestinationFile file = do @@ -546,12 +546,12 @@ return Nothing where nomedia = do - let key = Backend.URL.fromUrl url (Url.urlSize urlinfo) (verifiableOption o) + let key = Backend.URL.fromUrl url (Url.urlSize urlinfo) True nodownloadWeb' o addunlockedmatcher url key file usemedia mediafile = do let dest = youtubeDlDestFile o file mediafile let mediaurl = setDownloader url YoutubeDownloader - let mediakey = Backend.URL.fromUrl mediaurl Nothing (verifiableOption o) + let mediakey = Backend.URL.fromUrl mediaurl Nothing True nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest youtubeDlDestFile :: DownloadOptions -> OsPath -> OsPath -> OsPath diff --git a/Command/Direct.hs b/Command/Direct.hs deleted file mode 100644 --- a/Command/Direct.hs +++ /dev/null @@ -1,21 +0,0 @@ -{- git-annex command - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Command.Direct where - -import Command - -cmd :: Command -cmd = notBareRepo $ noDaemonRunning $ - command "direct" SectionSetup "switch repository to direct mode (deprecated)" - paramNothing (withParams seek) - -seek :: CmdParams -> CommandSeek -seek = withNothing (commandAction start) - -start :: CommandStart -start = giveup "Direct mode is not supported by this repository version. Use git-annex unlock instead." diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -93,7 +93,7 @@ keyOpt' :: String -> Either String Key keyOpt' s = case parseURIPortable s of Just u | not (isKeyPrefix (uriScheme u)) -> - Right $ Backend.URL.fromUrl s Nothing False + Right $ Backend.URL.fromUrl s Nothing True _ -> case deserializeKey s of Just k -> Right k Nothing -> Left $ "bad key/url " ++ s 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-2025 Joey Hess + - Copyright 2010-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -200,7 +200,7 @@ let tmp = t literalOsPath "fsck" <> toOsPath (show pid) <> literalOsPath "." <> keyFile key let cleanup = liftIO $ catchIO (removeFile tmp) (const noop) cleanup - cleanup `after` a tmp + a tmp `finally` cleanup getfile tmp = ifM (checkDiskSpace Nothing (Just (takeDirectory tmp)) key 0 True) ( ifM (getcheap tmp) ( return (Just (Right UnVerified)) @@ -337,28 +337,34 @@ warning $ "** Despite annex.securehashesonly being set, " <> QuotedPath obj <> " has content present in the annex using an insecure " <> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key))) <> " key" verifyLocationLog' key ai present u (logChange NoLiveUpdate key u) + (pure False) verifyLocationLogRemote :: Key -> ActionItem -> Remote -> Bool -> Annex Bool verifyLocationLogRemote key ai remote present = verifyLocationLog' key ai present (Remote.uuid remote) (Remote.logStatus NoLiveUpdate remote key) + (repairKeyRemote key remote) -verifyLocationLog' :: Key -> ActionItem -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool -verifyLocationLog' key ai present u updatestatus = do +verifyLocationLog' :: Key -> ActionItem -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool -> Annex Bool +verifyLocationLog' key ai present u updatestatus repairmissing = do uuids <- loggedLocations key case (present, u `elem` uuids) of (True, False) -> do fix InfoPresent -- There is no data loss, so do not fail. return True - (False, True) -> do - fix InfoMissing - warning $ - "** Based on the location log, " <> - actionItemDesc ai <> - "\n** was expected to be present, " <> - "but its content is missing." - return False + (False, True) -> + ifM repairmissing + ( return True + , do + fix InfoMissing + warning $ + "** Based on the location log, " <> + actionItemDesc ai <> + "\n** was expected to be present, " <> + "but its content is missing." + return False + ) (False, False) -> do -- When the location log for the key is not present, -- create it, so that the key will be known. @@ -622,13 +628,29 @@ dest <- moveBad key return $ "moved to " ++ fromOsPath dest +badContentRemote :: Remote -> OsPath -> Key -> Annex String +badContentRemote remote localcopy key = + ifM (repairKeyRemote key remote) + ( do + liftIO $ removeFile localcopy + return "repaired problem with remote" + , badContentRemote' remote localcopy key + ) + +repairKeyRemote :: Key -> Remote -> Annex Bool +repairKeyRemote key remote = case Remote.repairKey remote of + Nothing -> return False + Just a -> do + showSideAction "repairing problem with remote" + a key + {- Bad content is dropped from the remote. We have downloaded a copy - from the remote to a temp file already (in some cases, it's just a - symlink to a file in the remote). To avoid any further data loss, - that temp file is moved to the bad content directory unless - the local annex has a copy of the content. -} -badContentRemote :: Remote -> OsPath -> Key -> Annex String -badContentRemote remote localcopy key = do +badContentRemote' :: Remote -> OsPath -> Key -> Annex String +badContentRemote' remote localcopy key = do bad <- fromRepo gitAnnexBadDir let destbad = bad keyFile key movedbad <- ifM (inAnnex key <||> liftIO (doesFileExist destbad)) @@ -651,7 +673,7 @@ (True, Right ()) -> "moved from " ++ Remote.name remote ++ " to " ++ fromOsPath destbad (False, Right ()) -> "dropped from " ++ Remote.name remote - (_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e + (_, Left e) -> "failed to drop from " ++ Remote.name remote ++ ": " ++ show e runFsck :: Incremental -> SeekInput -> ActionItem -> Key -> Annex Bool -> CommandStart runFsck inc si ai key a = stopUnless (needFsck inc key) $ @@ -790,7 +812,7 @@ let r' = r { Git.mainWorkTreePath = Nothing } let dir = gitAnnexDir r' whenM (liftIO $ dirnotsymlink dir) $ do - showSideAction $ "Cleaning up directory " + showSideAction $ "Cleaning up directory " <> QuotedPath dir <> " created by buggy version of git-annex" (st, rd) <- liftIO $ Annex.new' (\r'' _c -> pure r'') r' @@ -803,7 +825,7 @@ void $ tryNonAsync $ liftIO $ removeDirectoryRecursive dir where - dirnotsymlink dir = + dirnotsymlink dir = tryIO (R.getSymbolicLinkStatus (fromOsPath dir)) >>= \case Right st -> return $ not (isSymbolicLink st) Left _ -> return False diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -275,7 +275,7 @@ Enclosure url -> startdownloadenclosure url MediaLink linkurl -> do let mediaurl = setDownloader linkurl YoutubeDownloader - let mediakey = Backend.URL.fromUrl mediaurl Nothing (verifiableOption (downloadOptions opts)) + let mediakey = Backend.URL.fromUrl mediaurl Nothing True -- Old versions of git-annex that used quvi might have -- used the quviurl for this, so check if it's known -- to avoid adding it a second time. diff --git a/Command/Indirect.hs b/Command/Indirect.hs deleted file mode 100644 --- a/Command/Indirect.hs +++ /dev/null @@ -1,21 +0,0 @@ -{- git-annex command - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Command.Indirect where - -import Command - -cmd :: Command -cmd = notBareRepo $ noDaemonRunning $ - command "indirect" SectionSetup "switch repository to indirect mode (deprecated)" - paramNothing (withParams seek) - -seek :: CmdParams -> CommandSeek -seek = withNothing (commandAction start) - -start :: CommandStart -start = stop 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-2025 Joey Hess + - Copyright 2024-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -11,7 +11,7 @@ module Command.P2PHttp where -import Command hiding (jobsOption) +import Command hiding (jobsOption, cpusOption) import P2P.Http.Server import P2P.Http.Url import qualified P2P.Protocol as P2P @@ -21,6 +21,7 @@ import qualified Git.Construct import qualified Annex import Types.Concurrency +import Types.Messages import qualified Utility.RawFilePath as R import Utility.FileMode @@ -57,6 +58,7 @@ , proxyConnectionsOption :: Maybe Integer , jobsOption :: Maybe Concurrency , clusterJobsOption :: Maybe Int + , cpusOption :: Maybe Cpus , lockedFilesOption :: Maybe Integer , directoryOption :: [FilePath] } @@ -120,6 +122,7 @@ ( long "clusterjobs" <> metavar paramNumber <> help "number of concurrent node accesses per connection" )) + <*> optional cpusOptionParser <*> optional (option auto ( long "lockedfiles" <> metavar paramNumber <> help "number of content files that can be locked" @@ -163,6 +166,7 @@ } mkstannex authenv oldst lockedfilesqsem = do + Annex.setOutput QuietOutput u <- getUUID if u == NoUUID then return mempty @@ -182,12 +186,26 @@ <> serverShutdownCleanup oldst } +-- Disable Warp's slowloris attack prevention. Since the web server +-- only allows serving -J jobs at a time, and blocks when an additional +-- request is received, that can result in there being no network traffic +-- for a period of time, which triggers the slowloris attack prevention. +-- +-- The implementation of the P2P http server is not exception safe enough +-- to deal with Response handlers being killed at any point by warp. +-- +-- It would be better to use setTimeout, so that slowloris attacks in +-- making the request are prevented. But, it does not work! See +-- https://github.com/yesodweb/wai/issues/1058 +disableSlowlorisPrevention :: Warp.Settings -> Warp.Settings +disableSlowlorisPrevention = Warp.setTimeout maxBound + runServer :: Options -> P2PHttpServerState -> IO () runServer o mst = go `finally` serverShutdownCleanup mst where go = do let settings = Warp.setPort port $ Warp.setHost host $ - Warp.defaultSettings + disableSlowlorisPrevention $ Warp.defaultSettings mstv <- newTMVarIO mst let app = p2pHttpApp mstv case (certFileOption o, privateKeyFileOption o) of @@ -223,7 +241,7 @@ mkServerState :: Options -> M.Map Auth P2P.ServerMode -> LockedFilesQSem -> Annex P2PHttpServerState mkServerState o authenv lockedfilesqsem = - withAnnexWorkerPool (jobsOption o) $ + withAnnexWorkerPool (jobsOption o) (cpusOption o) $ mkP2PHttpServerState (mkGetServerMode authenv o) return diff --git a/Command/Proxy.hs b/Command/Proxy.hs deleted file mode 100644 --- a/Command/Proxy.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- git-annex command - - - - Copyright 2014 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Command.Proxy where - -import Command - -cmd :: Command -cmd = notBareRepo $ - command "proxy" SectionPlumbing - "safely bypass direct mode guard (deprecated)" - ("-- git command") (withParams seek) - -seek :: CmdParams -> CommandSeek -seek = withWords (commandAction . start) - -start :: [String] -> CommandStart -start [] = giveup "Did not specify command to run." -start (c:ps) = liftIO $ exitWith =<< safeSystem c (map Param ps) diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -37,12 +37,12 @@ (Batch fmt, _) -> seekBatch registerUrl o fmt -- older way of enabling batch input, does not support BatchNull (NoBatch, []) -> seekBatch registerUrl o (BatchFormat BatchLine (BatchKeys False)) - (NoBatch, ps) -> commandAction (start registerUrl o ps) + (NoBatch, ps) -> commandAction (start "registerurl" registerUrl o ps) seekBatch :: (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> BatchFormat -> CommandSeek seekBatch a o fmt = batchOnly Nothing (keyUrlPairs o) $ batchInput fmt (pure . parsebatch) $ - batchCommandAction . start' a o + batchCommandAction . start' "registerurl" a o where parsebatch l = let (keyname, u) = separate (== ' ') l @@ -52,15 +52,15 @@ Left e -> Left e Right k -> Right (k, u) -start :: (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> [String] -> CommandStart -start a o (keyname:url:[]) = start' a o (si, (keyOpt keyname, url)) +start :: String -> (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> [String] -> CommandStart +start msg a o (keyname:url:[]) = start' msg a o (si, (keyOpt keyname, url)) where si = SeekInput [keyname, url] -start _ _ _ = giveup "specify a key and an url" +start _ _ _ _ = giveup "specify a key and an url" -start' :: (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> (SeekInput, (Key, URLString)) -> CommandStart -start' a o (si, (key, url)) = - starting "registerurl" ai si $ +start' :: String -> (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> (SeekInput, (Key, URLString)) -> CommandStart +start' msg a o (si, (key, url)) = + starting msg ai si $ perform a o key url where ai = ActionItemOther (Just (UnquotedString url)) diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -1,7 +1,7 @@ {- git-annex command - - Copyright 2011 Joachim Breitner - - Copyright 2011-2024 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -264,7 +264,15 @@ seek' o = startConcurrency transferStages $ do let withbranch a = a =<< getCurrentBranch - remotes <- syncRemotes (syncWith o) + mc <- mergeConfig (allowUnrelatedHistories o) + + unless (cleanupOption o) $ + includeactions + [ [ commit o ] + , [ withbranch (mergeLocal mc o) ] + ] + + 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 @@ -277,16 +285,8 @@ commandAction (withbranch cleanupLocal) mapM_ (commandAction . withbranch . cleanupRemote) gitremotes else do - mc <- mergeConfig (allowUnrelatedHistories o) - - -- Syncing involves many actions, any of which - -- can independently fail, without preventing - -- the others from running. - -- These actions cannot be run concurrently. - mapM_ includeCommandAction $ concat - [ [ commit o ] - , [ withbranch (mergeLocal mc o) ] - , map (withbranch . pullRemote o mc) gitremotes + includeactions + [ map (withbranch . pullRemote o mc) gitremotes , [ mergeAnnex ] ] @@ -325,8 +325,8 @@ -- git-annex branch on the remotes in the -- meantime, so pull and merge again to -- avoid our push overwriting those changes. - when (syncedcontent || exportedcontent) $ do - mapM_ includeCommandAction $ concat + when (syncedcontent || exportedcontent) $ + includeactions [ map (withbranch . pullRemote o mc) gitremotes , [ commitAnnex, mergeAnnex ] ] @@ -334,6 +334,12 @@ void $ includeCommandAction $ withbranch $ pushLocal o -- Pushes to remotes can run concurrently. mapM_ (commandAction . withbranch . pushRemote o) gitremotes + where + -- Syncing involves many actions, any of which + -- can independently fail, without preventing + -- the others from running. + -- These actions cannot be run concurrently. + includeactions = mapM_ includeCommandAction . concat {- Merging may delete the current directory, so go to the top - of the repo. This also means that sync always acts on all files in the @@ -1188,3 +1194,43 @@ isThirdPartyPopulated :: Remote -> Bool isThirdPartyPopulated = Remote.thirdPartyPopulated . Remote.remotetype + +{- Support for push-to-create of git repositories. + - + - When the remote does not exist yet, annex-ignore and + - annex-ignore-auto will be set. In that case, try to push. + - + - After a successful push, clear annex-ignore and regenerate the remote. + - That may re-set annex-ignore. Then annex-ignore-auto is cleared, so + - this will not run again, even when annex-ignore remains set. + -} +pushToCreate :: SyncOptions -> Remote -> Annex Remote +pushToCreate o r + | not (pushOption o) = return r + | Remote.gitSyncableRemote r && remoteAnnexIgnoreAuto (Remote.gitconfig r) = + ifM (liftIO $ getDynamicConfig $ remoteAnnexIgnore $ Remote.gitconfig r) + ( getCurrentBranch >>= \case + currbranch@(Just _, _) -> do + pushed <- includeCommandAction $ + pushRemote o r currbranch + if pushed + then do + repo <- Remote.getRepo r + unsetRemoteIgnore repo + reloadConfig + r' <- regenremote + unsetRemoteIgnoreAuto repo + return r' + else return r + _ -> return r + , return r + ) + | otherwise = return r + where + regenremote = do + -- Regenerating the remote list involves some extra work, + -- but push-to-create only happens once per remote. + rs <- Remote.remoteList' False + case filter (\r' -> Remote.name r' == Remote.name r) rs of + (r':_) -> return r' + _ -> return r diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs deleted file mode 100644 --- a/Command/TransferKeys.hs +++ /dev/null @@ -1,141 +0,0 @@ -{- git-annex command, used internally by assistant in version - - 8.20201127 and older and provided only to avoid upgrade breakage. - - Remove at some point when such old versions of git-annex are unlikely - - to be running any longer. - - - - Copyright 2012, 2013 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} - -module Command.TransferKeys where - -import Command -import Annex.Content -import Logs.Location -import Annex.Transfer -import qualified Remote -import Utility.SimpleProtocol (dupIoHandles) -import qualified Database.Keys -import Annex.BranchState - -data TransferRequest = TransferRequest Direction Remote Key AssociatedFile - -cmd :: Command -cmd = command "transferkeys" SectionPlumbing "transfers keys (deprecated)" - paramNothing (withParams seek) - -seek :: CmdParams -> CommandSeek -seek = withNothing (commandAction start) - -start :: CommandStart -start = do - enableInteractiveBranchAccess - (readh, writeh) <- liftIO dupIoHandles - runRequests readh writeh runner - stop - where - runner (TransferRequest direction remote key af) - | direction == Upload = notifyTransfer direction af $ - upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do - tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case - Left e -> do - warning (UnquotedString (show e)) - return False - Right () -> do - Remote.logStatus NoLiveUpdate remote key InfoPresent - return True - | otherwise = notifyTransfer direction af $ - download' (Remote.uuid remote) key af Nothing stdRetry $ \p -> - logStatusAfter NoLiveUpdate key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key Nothing $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key af t p (RemoteVerify remote)) >>= \case - Left e -> do - warning (UnquotedString (show e)) - return (False, UnVerified) - Right v -> return (True, v) - -- Make sure we get the current - -- associated files data for the key, - -- not old cached data. - Database.Keys.closeDb - return r - -runRequests - :: Handle - -> Handle - -> (TransferRequest -> Annex Bool) - -> Annex () -runRequests readh writeh a = do - liftIO $ hSetBuffering readh NoBuffering - go =<< readrequests - where - go (d:rn:k:f:rest) = do - case (deserialize d, deserialize rn, deserialize k, deserialize f) of - (Just direction, Just remotename, Just key, Just file) -> do - mremote <- Remote.byName' remotename - case mremote of - Left _ -> sendresult False - Right remote -> sendresult =<< a - (TransferRequest direction remote key file) - _ -> sendresult False - go rest - go [] = noop - go [""] = noop - go v = giveup $ "transferkeys protocol error: " ++ show v - - readrequests = liftIO $ split fieldSep <$> hGetContents readh - sendresult b = liftIO $ do - hPutStrLn writeh $ serialize b - hFlush writeh - -sendRequest :: Transfer -> TransferInfo -> Handle -> IO () -sendRequest t tinfo h = do - hPutStr h $ intercalate fieldSep - [ serialize (transferDirection t) - , maybe (serialize ((fromUUID (transferUUID t)) :: String)) - (serialize . Remote.name) - (transferRemote tinfo) - , serialize (transferKey t) - , serialize (associatedFile tinfo) - , "" -- adds a trailing null - ] - hFlush h - -readResponse :: Handle -> IO Bool -readResponse h = fromMaybe False . deserialize <$> hGetLine h - -fieldSep :: String -fieldSep = "\0" - -class TCSerialized a where - serialize :: a -> String - deserialize :: String -> Maybe a - -instance TCSerialized Bool where - serialize True = "1" - serialize False = "0" - deserialize "1" = Just True - deserialize "0" = Just False - deserialize _ = Nothing - -instance TCSerialized Direction where - serialize Upload = "u" - serialize Download = "d" - deserialize "u" = Just Upload - deserialize "d" = Just Download - deserialize _ = Nothing - -instance TCSerialized AssociatedFile where - serialize (AssociatedFile (Just f)) = fromOsPath f - serialize (AssociatedFile Nothing) = "" - deserialize "" = Just (AssociatedFile Nothing) - deserialize f = Just (AssociatedFile (Just (toOsPath f))) - -instance TCSerialized RemoteName where - serialize n = n - deserialize n = Just n - -instance TCSerialized Key where - serialize = serializeKey - deserialize = deserializeKey diff --git a/Command/Undo.hs b/Command/Undo.hs --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -22,11 +22,12 @@ cmd :: Command cmd = notBareRepo $ withAnnexOptions [jsonOptions] $ command "undo" SectionCommon - "undo last change to a file or directory" + "undo last change to a file or directory (deprecated)" paramPaths (withParams seek) seek :: CmdParams -> CommandSeek seek ps = do + warning "git-annex undo is deprecated and will be removed from a future version of git-annex" -- Safety first; avoid any undo that would touch files that are not -- in the index. (fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toOsPath ps) diff --git a/Command/UnregisterUrl.hs b/Command/UnregisterUrl.hs --- a/Command/UnregisterUrl.hs +++ b/Command/UnregisterUrl.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2015-2022 Joey Hess + - Copyright 2015-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,6 +12,7 @@ import Command import Logs.Web import Command.RegisterUrl (seekBatch, start, optParser, RegisterUrlOptions(..)) +import Backend.URL cmd :: Command cmd = withAnnexOptions [jsonOptions] $ command "unregisterurl" @@ -22,17 +23,23 @@ seek :: RegisterUrlOptions -> CommandSeek seek o = case (batchOption o, keyUrlPairs o) of (Batch fmt, _) -> seekBatch unregisterUrl o fmt - (NoBatch, ps) -> commandAction (start unregisterUrl o ps) + (NoBatch, ps) -> commandAction (start "unregisterurl" unregisterUrl o ps) unregisterUrl :: Remote -> Key -> String -> Annex () unregisterUrl _remote key url = do + unregisterUrl' url key + maybe noop (unregisterUrl' url) (otherUrlKey key) + +unregisterUrl' :: String -> Key -> Annex () +unregisterUrl' url key = do -- Remove the url no matter what downloader; -- registerurl can set OtherDownloader, and this should also -- be able to remove urls added by addurl, which may use -- YoutubeDownloader. forM_ [minBound..maxBound] $ \dl -> setUrlMissing key (setDownloader url dl) - -- Unlike unregisterurl, this does not update location tracking - -- for remotes other than the web special remote. Doing so with - -- a remote that git-annex can drop content from would rather - -- unexpectedly leave content stranded on that remote. + -- Unlike registerurl, this does not update location + -- tracking for remotes other than the web special remote. + -- Doing so with a remote that git-annex can drop content + -- from would rather unexpectedly leave content stranded + -- on that remote. diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -1,6 +1,6 @@ {- Git configuration - - - Copyright 2011-2023 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -77,6 +77,15 @@ setRemoteIgnore :: Git.Repo -> Bool -> Annex () setRemoteIgnore r b = setConfig (remoteAnnexConfig r "ignore") (Git.Config.boolConfig b) + +unsetRemoteIgnore :: Git.Repo -> Annex () +unsetRemoteIgnore r = unsetConfig (remoteAnnexConfig r "ignore") + +setRemoteIgnoreAuto :: Git.Repo -> Bool -> Annex () +setRemoteIgnoreAuto r b = setConfig (remoteAnnexConfig r "ignore-auto") (Git.Config.boolConfig b) + +unsetRemoteIgnoreAuto :: Git.Repo -> Annex () +unsetRemoteIgnoreAuto r = unsetConfig (remoteAnnexConfig r "ignore-auto") setRemoteBare :: Git.Repo -> Bool -> Annex () setRemoteBare r b = setConfig (remoteAnnexConfig r "bare") (Git.Config.boolConfig b) diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs --- a/P2P/Http/Server.hs +++ b/P2P/Http/Server.hs @@ -2,7 +2,7 @@ - - https://git-annex.branchable.com/design/p2p_protocol_over_http/ - - - Copyright 2024 Joey Hess + - Copyright 2024-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -44,7 +44,6 @@ import Control.Concurrent.STM import Control.Concurrent import System.IO.Unsafe -import Data.Either p2pHttpApp :: TMVar P2PHttpServerState -> Application p2pHttpApp = serve p2pHttpAPI . serveP2pHttp @@ -145,8 +144,9 @@ (Len len, bs) <- liftIO $ atomically $ takeTMVar bsv bv <- liftIO $ newMVar (filter (not . B.null) (L.toChunks bs)) szv <- liftIO $ newMVar 0 - let streamer = S.SourceT $ \s -> s =<< return - (stream (bv, szv, len, endv, validityv, finalv)) + let streamer = S.SourceT $ do + \s -> s (stream (bv, szv, len, endv, validityv, finalv)) + `onException` streamexception finalv return $ addHeader (DataLength len) streamer where stream (bv, szv, len, endv, validityv, finalv) = @@ -189,7 +189,7 @@ atomically $ putTMVar endv () validity <- atomically $ takeTMVar validityv sz <- takeMVar szv - atomically $ putTMVar finalv () + atomically $ putTMVar finalv True void $ atomically $ tryPutTMVar endv () return $ case validity of Nothing -> True @@ -197,14 +197,15 @@ Just Invalid -> sz /= len , pure True ) - + waitfinal endv finalv conn annexworker = do -- Wait for everything to be transferred before -- stopping the annexworker. The finalv will usually -- be written to at the end. If the client disconnects - -- early that does not happen, so catch STM exception. - alltransferred <- isRight - <$> tryNonAsync (liftIO $ atomically $ takeTMVar finalv) + -- early that does not happen, so catch STM exceptions. + alltransferred <- + either (const False) id + <$> liftIO (tryNonAsync $ atomically $ takeTMVar finalv) -- Make sure the annexworker is not left blocked on endv -- if the client disconnected early. void $ liftIO $ atomically $ tryPutTMVar endv () @@ -213,6 +214,11 @@ else closeP2PConnection conn void $ tryNonAsync $ wait annexworker + -- Slowloris attack prevention can cancel the streamer. Be sure to + -- close the P2P connection when that happens. + streamexception finalv = + liftIO $ atomically $ putTMVar finalv False + sizer = pure $ Len $ case startat of Just (Offset o) -> fromIntegral o Nothing -> 0 @@ -251,7 +257,7 @@ -> IsSecure -> Maybe Auth -> Handler t -serveRemove st resultmangle su apiver (B64Key k) cu bypass sec auth = do +serveRemove st resultmangle su apiver (B64Key k) cu bypass sec auth = changesBranch st su $ do res <- withP2PConnection apiver WorkerPoolRunner st cu su bypass sec auth RemoveAction id $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ remove Nothing k @@ -273,7 +279,7 @@ -> IsSecure -> Maybe Auth -> Handler RemoveResultPlus -serveRemoveBefore st su apiver (B64Key k) cu bypass (Timestamp ts) sec auth = do +serveRemoveBefore st su apiver (B64Key k) cu bypass (Timestamp ts) sec auth = changesBranch st su $ do res <- withP2PConnection apiver WorkerPoolRunner st cu su bypass sec auth RemoveAction id $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ @@ -320,7 +326,7 @@ -> IsSecure -> Maybe Auth -> Handler t -servePut mst resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = do +servePut mst resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = changesBranch mst su $ do res <- withP2PConnection' apiver WorkerPoolRunner mst cu su bypass sec auth WriteAction (\cst -> cst { connectionWaitVar = False }) (liftIO . protoaction) servePutResult resultmangle res @@ -328,7 +334,7 @@ protoaction conn = servePutAction conn k baf $ \_offset -> do net $ sendMessage DATA_PRESENT checkSuccessPlus -servePut mst resultmangle su apiver _datapresent (DataLength len) k cu bypass baf moffset stream sec auth = do +servePut mst resultmangle su apiver _datapresent (DataLength len) k cu bypass baf moffset stream sec auth = changesBranch mst su $ do validityv <- liftIO newEmptyTMVarIO let validitycheck = local $ runValidityCheck $ liftIO $ atomically $ readTMVar validityv diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -2,7 +2,7 @@ - - https://git-annex.branchable.com/design/p2p_protocol_over_http/ - - - Copyright 2024-2025 Joey Hess + - Copyright 2024-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -36,6 +36,7 @@ import Logs.Proxy import Annex.Proxy import Annex.Cluster +import qualified Annex.Branch import qualified P2P.Proxy as Proxy import qualified Types.Remote as Remote import Remote.List @@ -82,6 +83,7 @@ , getServerMode :: GetServerMode , openLocks :: TMVar (M.Map LockID Locker) , lockedFilesQSem :: LockedFilesQSem + , branchChangesInProgress :: TMVar Bool } type AnnexWorkerPool = TMVar (WorkerPool (Annex.AnnexState, Annex.AnnexRead)) @@ -90,7 +92,7 @@ data ServerMode = ServerMode - { serverMode :: P2P.ServerMode + { serverMode :: P2P.ServerMode , unauthenticatedLockingAllowed :: Bool , authenticationAllowed :: Bool } @@ -105,6 +107,7 @@ <*> pure getservermode <*> newTMVarIO mempty <*> pure lockedfilesqsem + <*> newEmptyTMVarIO data ActionClass = ReadAction | WriteAction | RemoveAction | LockAction deriving (Eq) @@ -318,15 +321,18 @@ proxypool <- liftIO $ newTMVarIO (0, mempty) asyncservicer <- liftIO $ async $ servicer myuuid myproxies proxypool reqv relv endv - let endit = do - liftIO $ atomically $ putTMVar endv () - liftIO $ wait asyncservicer let servinguuids = myuuid : map proxyRemoteUUID (maybe [] S.toList myproxies) annexstate <- liftIO . newTMVarIO =<< dupState annexread <- Annex.getRead id st <- liftIO $ mkPerRepoServerState (acquireconn reqv annexstate annexread) workerpool annexstate annexread getservermode lockedfilesqsem + asynccommitter <- liftIO $ async $ + branchCommitter st endv + let endit = do + liftIO $ atomically $ putTMVar endv () + liftIO $ wait asyncservicer + liftIO $ wait asynccommitter return $ P2PHttpServerState { servedRepos = M.fromList $ zip servinguuids (repeat st) , serverShutdownCleanup = endit @@ -347,7 +353,7 @@ `orElse` (Left . Right <$> takeTMVar relv) `orElse` - (Left . Left <$> takeTMVar endv) + (Left . Left <$> readTMVar endv) case reqrel of Right (runnertype, annexstate, annexread, connparams, ready, respvar) -> do servicereq runnertype annexstate annexread myuuid myproxies proxypool relv connparams ready @@ -636,9 +642,10 @@ Nothing -> return () Just locker -> wait (lockerThread locker) -withAnnexWorkerPool :: (Maybe Concurrency) -> (AnnexWorkerPool -> Annex a) -> Annex a -withAnnexWorkerPool mc a = do - maybe noop (setConcurrency . ConcurrencyCmdLine) mc +withAnnexWorkerPool :: Maybe Concurrency -> Maybe Cpus -> (AnnexWorkerPool -> Annex a) -> Annex a +withAnnexWorkerPool mconc mcpus a = do + maybe noop setCpus mcpus + maybe noop (setConcurrency . ConcurrencyCmdLine) mconc startConcurrency transferStages $ Annex.getState Annex.workers >>= \case Nothing -> giveup "Use -Jn or set annex.jobs to configure the number of worker threads." @@ -818,3 +825,56 @@ , connectionBypass connparams , connectionProtocolVersion connparams ) + +-- Use when running an action which may journal git-annex branch changes. +-- This arranges for the journalled changes to be committed to the branch +-- in a timely fashion, so that eg, soon after one client has sent a file, +-- another client can pull the branch and see that the file is present in +-- the server. +changesBranch :: TMVar P2PHttpServerState -> B64UUID ServerSide -> Handler t -> Handler t +changesBranch mstv su a = liftIO (getPerRepoServerState mstv su) >>= \case + Just st -> bracket_ (send st True) (send st False) a + Nothing -> a + where + send st b = liftIO $ atomically $ + putTMVar (branchChangesInProgress st) b + +branchCommitter :: PerRepoServerState -> TMVar () -> IO () +branchCommitter st endv = do + idlev <- newEmptyTMVarIO + void $ async $ committer idlev + go idlev (0 :: Integer) + where + waitchangeorend = (Right <$> takeTMVar (branchChangesInProgress st)) + `orElse` (Left <$> readTMVar endv) + go idlev n = atomically waitchangeorend >>= \case + Right True -> do + let !n' = succ n + -- Not idle. + void $ atomically $ tryTakeTMVar idlev + go idlev n' + Right False -> do + let n' = pred n + when (n' == 0) $ + -- Idle. + atomically $ writeTMVar idlev () + go idlev n' + Left () -> return () + waitidleorend idlev = + (Right <$> readTMVar idlev) + `orElse` (Left <$> readTMVar endv) + committer idlev = + -- Wait until a change has completed and it's idle. + atomically (waitidleorend idlev) >>= \case + Right () -> do + threadDelaySeconds (Seconds 1) + -- Once it's been idle for a second, + -- commit the journalled changes. + atomically (tryTakeTMVar idlev) >>= \case + Just () -> + void $ handleRequestAnnex st $ + Annex.Branch.commit =<< Annex.Branch.commitMessage + Nothing -> noop + committer idlev + Left () -> return () + diff --git a/P2P/Proxy.hs b/P2P/Proxy.hs --- a/P2P/Proxy.hs +++ b/P2P/Proxy.hs @@ -20,6 +20,7 @@ import Types.Concurrency import Annex.Concurrent import qualified Remote +import CmdLine.Action import Data.Either import Control.Concurrent.STM @@ -718,9 +719,7 @@ ConcurrentPerCpu -> go =<< liftIO getNumProcessors where go n = do - c <- liftIO getNumCapabilities - when (n > c) $ - liftIO $ setNumCapabilities n + raiseCapabilitiesForJobs n setConcurrency (ConcurrencyGitConfig (Concurrent n)) mkConcurrencyConfig n diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -21,6 +21,7 @@ hasKey, hasKeyCheap, whereisKey, + repairKey, remoteFsck, remoteTypes, diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -108,6 +108,7 @@ } , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -81,6 +81,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , gitconfig = gc diff --git a/Remote/Borg.hs b/Remote/Borg.hs --- a/Remote/Borg.hs +++ b/Remote/Borg.hs @@ -107,6 +107,7 @@ } , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -90,6 +90,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/Compute.hs b/Remote/Compute.hs --- a/Remote/Compute.hs +++ b/Remote/Compute.hs @@ -122,6 +122,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , gitconfig = gc diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -92,6 +92,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -128,6 +128,7 @@ } , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -143,6 +143,7 @@ , importActions = importUnsupported , whereisKey = towhereis , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , localpath = Nothing diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -148,6 +148,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , localpath = localpathCalc r diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -1,6 +1,6 @@ {- Standard git remotes. - - - Copyright 2011-2024 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,6 +21,7 @@ import qualified Git import qualified Git.Config import qualified Git.Construct +import qualified Git.Ref import qualified Git.Command import qualified Git.GCrypt import qualified Git.Types as Git @@ -177,7 +178,10 @@ - annex-checkuuid is false. - - The config of other URL remotes is only read when there is no - - cached UUID value. + - cached UUID value. To handle push-to-create, the first time that + - the remote tracking branch for the git-annex branch exists, the + - config is re-read to discover if the remote has been created and has a + - UUID. -} configRead :: Bool -> Git.Repo -> Annex Git.Repo configRead autoinit r = do @@ -185,14 +189,27 @@ hasuuid <- (/= NoUUID) <$> getRepoUUID r annexignore <- liftIO $ getDynamicConfig (remoteAnnexIgnore gc) case (repoCheap r, annexignore, hasuuid) of - (_, True, _) -> return r (True, _, _) | remoteAnnexCheckUUID gc -> tryGitConfigRead gc autoinit r hasuuid | otherwise -> return r - (False, _, False) -> configSpecialGitRemotes r >>= \case - Nothing -> tryGitConfigRead gc autoinit r False - Just r' -> return r' + (_, True, _) + | remoteAnnexIgnoreAuto gc -> + checkpushedtocreate gc + | otherwise -> return r + (False, _, False) -> go gc _ -> return r + where + go gc = configSpecialGitRemotes r >>= \case + Nothing -> tryGitConfigRead gc autoinit r False + Just r' -> return r' + checkpushedtocreate gc = + ifM (inRepo $ Git.Ref.exists $ Annex.Branch.remoteTrackingBranch $ getRemoteName r) + ( do + unsetRemoteIgnore r + reloadConfig + unsetRemoteIgnoreAuto r `after` go gc + , return r + ) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs @@ -228,6 +245,7 @@ , remoteFsck = if Git.repoIsUrl r then Nothing else Just $ fsckOnRemote r + , repairKey = Nothing , repairRepo = if Git.repoIsUrl r then Nothing else Just $ repairRemote r @@ -368,6 +386,7 @@ when longmessage $ warning $ UnquotedString $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git annex enableremote " ++ n setremote setRemoteIgnore True + setremote setRemoteIgnoreAuto True setremote setter v = case Git.remoteName r of Nothing -> noop @@ -586,7 +605,7 @@ Just err -> giveup err Nothing -> return True copier <- mkFileCopier hardlink st - (ok, v) <- runTransfer (Transfer Download u (fromKey id key)) + (ok, v) <- alwaysRunTransfer (Transfer Upload u (fromKey id key)) Nothing af Nothing stdRetry $ \p -> metered (Just (combineMeterUpdate p meterupdate)) key bwlimit $ \_ p' -> copier object dest key p' checksuccess vc diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -126,6 +126,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -96,6 +96,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -75,6 +75,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , localpath = Nothing diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -88,6 +88,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , gitconfig = gc diff --git a/Remote/Mask.hs b/Remote/Mask.hs --- a/Remote/Mask.hs +++ b/Remote/Mask.hs @@ -66,6 +66,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/P2P.hs b/Remote/P2P.hs --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -70,6 +70,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , localpath = Nothing diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -113,6 +113,7 @@ , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing + , repairKey = Nothing , config = c , getRepo = return r , gitconfig = gc @@ -343,14 +344,7 @@ Just f' -> includes f' removeExportDirectoryM :: RsyncOpts -> ExportDirectory -> Annex () -removeExportDirectoryM o ed = removeGeneric o $ - map fromOsPath (allbelow d : includes d) - where - d = fromExportDirectory ed - allbelow f = f literalOsPath "***" - includes f = f : case upFrom f of - Nothing -> [] - Just f' -> includes f' +removeExportDirectoryM o ed = removeGeneric o [] renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM _ _ _ _ = return Nothing diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -1,6 +1,6 @@ {- S3 remotes - - - Copyright 2011-2025 Joey Hess + - Copyright 2011-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -68,7 +68,7 @@ import Utility.DataUnits import Annex.Content import qualified Annex.Url as Url -import Utility.Url (extractFromResourceT, UserAgent) +import Utility.Url (extractFromResourceT, UserAgent, sinkResponseIncrementalVerifier) import Annex.Url (getUserAgent, getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env import Annex.Verify @@ -253,6 +253,7 @@ } , whereisKey = Just (getPublicWebUrls rs info c) , remoteFsck = Nothing + , repairKey = repairKeyS3 info hdl this rs , repairRepo = Nothing , config = c , getRepo = return r @@ -1392,15 +1393,18 @@ setS3VersionID :: S3Info -> RemoteStateHandle -> Key -> Maybe S3VersionID -> Annex () setS3VersionID info rs k vid - | versioning info = maybe noop (setS3VersionID' rs k) vid + | versioning info = maybe noop (setS3VersionID' rs k (CurrentlySet True)) vid | otherwise = noop -setS3VersionID' :: RemoteStateHandle -> Key -> S3VersionID -> Annex () -setS3VersionID' rs k vid = addRemoteMetaData k rs $ +setS3VersionID' :: RemoteStateHandle -> Key -> CurrentlySet -> S3VersionID -> Annex () +setS3VersionID' rs k currentlyset vid = addRemoteMetaData k rs $ updateMetaData s3VersionField v emptyMetaData where - v = mkMetaValue (CurrentlySet True) (formatS3VersionID vid) + v = mkMetaValue currentlyset (formatS3VersionID vid) +unsetS3VersionID :: RemoteStateHandle -> Key -> S3VersionID -> Annex () +unsetS3VersionID rs k vid = setS3VersionID' rs k (CurrentlySet False) vid + getS3VersionID :: RemoteStateHandle -> Key -> Annex [S3VersionID] getS3VersionID rs k = do (RemoteMetaData _ m) <- getCurrentRemoteMetaData rs k @@ -1418,7 +1422,7 @@ [] -> if exportTree c then Left "Remote is configured to use versioning, but no S3 version ID is recorded for this key" else Right (Left fallback) - -- It's possible for a key to be stored multiple timees in + -- It's possible for a key to be stored multiple times in -- a bucket with different version IDs; only use one of them. (v:_) -> Right (Right v) | otherwise = return (Right (Left fallback)) @@ -1487,3 +1491,42 @@ [] -> giveup "Remote is configured to use versioning, but no S3 version ID is recorded for this key, so it cannot safely be modified." _ -> return () | otherwise = return () + +{- Recover from a bad upload that a S3 version id points to. -} +repairKeyS3 :: S3Info -> S3HandleVar -> Remote -> RemoteStateHandle -> Maybe (Key -> Annex Bool) +repairKeyS3 info hdl r rs + | versioning info = Just $ \k -> + getS3VersionID rs k >>= \case + -- With only one S3 version id, it must be bad, so no need + -- to download it. + (s3vid:[]) -> do + unsetS3VersionID rs k s3vid + return False + -- Try to repair each S3 version id, if any are valid + -- the repair succeeded. + vs -> or <$> mapM (repairvid k) vs + | otherwise = Nothing + where + {- Download and verify the content, and if it's invalid, + - unset the S3 version id. + -} + repairvid k s3vid@(S3VersionID o vid) = do + miv <- startVerifyKeyContentIncrementally AlwaysVerify k + downloaded <- case miv of + Just iv -> withS3Handle hdl $ \case + Right h -> liftIO $ runResourceT $ do + S3.GetObjectResponse { S3.gorResponse = rsp } + <- sendS3Handle h $ (S3.getObject (bucket info) o) + { S3.goVersionId = Just vid } + sinkResponseIncrementalVerifier nullMeterUpdate iv rsp + return True + Left problem -> giveupS3HandleProblem problem (uuid r) + Nothing -> return False + v <- snd <$> finishVerifyKeyContentIncrementally' True miv + case v of + Verified -> return True + _ + | downloaded -> do + unsetS3VersionID rs k s3vid + return False + | otherwise -> return False diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -108,6 +108,7 @@ , importActions = importUnsupported , whereisKey = Just (getWhereisKey rs) , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -89,6 +89,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , gitconfig = gc diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -109,6 +109,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing + , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r diff --git a/Types/Concurrency.hs b/Types/Concurrency.hs --- a/Types/Concurrency.hs +++ b/Types/Concurrency.hs @@ -1,4 +1,4 @@ -{- Copyright 2016 Joey Hess +{- Copyright 2016-2026 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,3 +23,10 @@ = ConcurrencyCmdLine Concurrency | ConcurrencyGitConfig Concurrency deriving (Eq) + +newtype Cpus = Cpus Int + deriving (Eq) + +parseCpus :: String -> Maybe Cpus +parseCpus s = Cpus <$> readish s + diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -147,6 +147,7 @@ , annexRetryDelay :: Maybe Seconds , annexAllowedUrlSchemes :: S.Set Scheme , annexAllowedIPAddresses :: String + , annexAllowInsecureHttps :: Bool , annexAllowUnverifiedDownloads :: Bool , annexAllowedComputePrograms :: Maybe String , annexMaxExtensionLength :: Maybe Int @@ -268,6 +269,8 @@ getmaybe (annexConfig "security.allowed-ip-addresses") <|> getmaybe (annexConfig "security.allowed-http-addresses") -- old name + , annexAllowInsecureHttps = (== Just "tls-1.2-no-EMS") $ + getmaybe (annexConfig "security.allow-insecure-https") , annexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe (annexConfig "security.allow-unverified-downloads") , annexAllowedComputePrograms = @@ -396,6 +399,7 @@ data RemoteGitConfig = RemoteGitConfig { remoteAnnexCost :: DynamicConfig (Maybe Cost) , remoteAnnexIgnore :: DynamicConfig Bool + , remoteAnnexIgnoreAuto :: Bool , remoteAnnexSync :: DynamicConfig Bool , remoteAnnexPull :: Bool , remoteAnnexPush :: Bool @@ -477,6 +481,7 @@ return $ RemoteGitConfig { remoteAnnexCost = annexcost , remoteAnnexIgnore = annexignore + , remoteAnnexIgnoreAuto = getbool IgnoreAutoField False , remoteAnnexSync = annexsync , remoteAnnexPull = getbool PullField True , remoteAnnexPush = getbool PushField True @@ -586,6 +591,7 @@ = CostField | CostCommandField | IgnoreField + | IgnoreAutoField | IgnoreCommandField | SyncField | SyncCommandField @@ -659,6 +665,7 @@ CostField -> inherited True "cost" CostCommandField -> inherited True "cost-command" IgnoreField -> inherited True "ignore" + IgnoreAutoField -> inherited True "ignore-auto" IgnoreCommandField -> inherited True "ignore-command" SyncField -> inherited True "sync" SyncCommandField -> inherited True "sync-command" diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -140,6 +140,10 @@ -- without transferring all the data to the local repo -- The parameters are passed to the fsck command on the remote. , remoteFsck :: Maybe ([CommandParam] -> a (IO Bool)) + -- Fsck calls this when it finds a problem with a key on a remote. + -- If the remote is able to repair the problem, so that the key can + -- once more be downloaded from it, it can return True. + , repairKey :: Maybe (Key -> a Bool) -- Runs an action to repair the remote's git repository. , repairRepo :: Maybe (a Bool -> a (IO Bool)) -- a Remote has a persistent configuration store @@ -361,10 +365,6 @@ -> a (Key, Verification) -- Exports content to an ExportLocation, and returns the -- ContentIdentifier corresponding to the content it stored. - -- - -- This is used rather than storeExport when a special remote - -- supports imports, since files on such a special remote can be - -- changed at any time. -- -- Since other things can modify the same file on the special -- remote, this must take care to not overwrite such modifications, diff --git a/Utility/DirWatcher/Kqueue.hs b/Utility/DirWatcher/Kqueue.hs --- a/Utility/DirWatcher/Kqueue.hs +++ b/Utility/DirWatcher/Kqueue.hs @@ -20,6 +20,7 @@ import Common import Utility.DirWatcher.Types import Utility.OpenFd +import qualified Utility.RawFilePath as R import System.Posix.Types import Foreign.C.Types @@ -33,9 +34,9 @@ import Control.Concurrent data Change - = Deleted FilePath - | DeletedDir FilePath - | Added FilePath + = Deleted OsPath + | DeletedDir OsPath + | Added OsPath deriving (Show) isAdd :: Change -> Bool @@ -43,26 +44,26 @@ isAdd (Deleted _) = False isAdd (DeletedDir _) = False -changedFile :: Change -> FilePath +changedFile :: Change -> OsPath changedFile (Added f) = f changedFile (Deleted f) = f changedFile (DeletedDir f) = f -data Kqueue = Kqueue +data Kqueue = Kqueue { kqueueFd :: Fd - , kqueueTop :: FilePath + , kqueueTop :: OsPath , kqueueMap :: DirMap , _kqueuePruner :: Pruner } -type Pruner = FilePath -> Bool +type Pruner = OsPath -> Bool type DirMap = M.Map Fd DirInfo {- Enough information to uniquely identify a file in a directory, - but not too much. -} data DirEnt = DirEnt - { dirEnt :: FilePath -- relative to the parent directory + { dirEnt :: OsPath -- relative to the parent directory , _dirInode :: FileID -- included to notice file replacements , isSubDir :: Bool } @@ -70,20 +71,20 @@ {- A directory, and its last known contents. -} data DirInfo = DirInfo - { dirName :: FilePath + { dirName :: OsPath , dirCache :: S.Set DirEnt } deriving (Show) -getDirInfo :: FilePath -> IO DirInfo +getDirInfo :: OsPath -> IO DirInfo getDirInfo dir = do - l <- filter (not . dirCruft . toRawFilePath) <$> getDirectoryContents dir + l <- filter (`notElem` dirCruft) <$> getDirectoryContents dir contents <- S.fromList . catMaybes <$> mapM getDirEnt l return $ DirInfo dir contents where getDirEnt f = catchMaybeIO $ do - s <- getSymbolicLinkStatus (dir f) - return $ DirEnt f (fileID s) (isDirectory s) + s <- R.getSymbolicLinkStatus $ fromOsPath $ dir f + return $ DirEnt f (Posix.fileID s) (Posix.isDirectory s) {- Difference between the dirCaches of two DirInfos. -} (//) :: DirInfo -> DirInfo -> [Change] @@ -99,7 +100,7 @@ {- Builds a map of directories in a tree, possibly pruning some. - Opens each directory in the tree, and records its current contents. -} -scanRecursive :: FilePath -> Pruner -> IO DirMap +scanRecursive :: OsPath -> Pruner -> IO DirMap scanRecursive topdir prune = M.fromList <$> walk [] [topdir] where walk c [] = return c @@ -111,7 +112,7 @@ Nothing -> walk c rest Just info -> do mfd <- catchMaybeIO $ - openFdWithMode (toRawFilePath dir) Posix.ReadOnly Nothing + openFdWithMode (fromOsPath dir) Posix.ReadOnly Nothing Posix.defaultFileFlags (CloseOnExecFlag True) case mfd of @@ -124,22 +125,22 @@ {- Adds a list of subdirectories (and all their children), unless pruned to a - directory map. Adding a subdirectory that's already in the map will - cause its contents to be refreshed. -} -addSubDirs :: DirMap -> Pruner -> [FilePath] -> IO DirMap +addSubDirs :: DirMap -> Pruner -> [OsPath] -> IO DirMap addSubDirs dirmap prune dirs = do newmap <- foldr M.union M.empty <$> mapM (\d -> scanRecursive d prune) dirs return $ M.union newmap dirmap -- prefer newmap {- Removes a subdirectory (and all its children) from a directory map. -} -removeSubDir :: DirMap -> FilePath -> IO DirMap +removeSubDir :: DirMap -> OsPath -> IO DirMap removeSubDir dirmap dir = do mapM_ Posix.closeFd $ M.keys toremove return rest where - (toremove, rest) = M.partition (dirContains (toRawFilePath dir) . toRawFilePath . dirName) dirmap + (toremove, rest) = M.partition (dirContains dir . dirName) dirmap -findDirContents :: DirMap -> FilePath -> [FilePath] -findDirContents dirmap dir = concatMap absolutecontents $ search +findDirContents :: DirMap -> OsPath -> [OsPath] +findDirContents dirmap dir = concatMap absolutecontents search where absolutecontents i = map (dirName i ) (map dirEnt $ S.toList $ dirCache i) @@ -154,7 +155,7 @@ :: Fd -> IO Fd {- Initializes a Kqueue to watch a directory, and all its subdirectories. -} -initKqueue :: FilePath -> Pruner -> IO Kqueue +initKqueue :: OsPath -> Pruner -> IO Kqueue initKqueue dir pruned = do dirmap <- scanRecursive dir pruned h <- c_init_kqueue @@ -268,4 +269,4 @@ Just a -> a (changedFile change) s withstatus change a = maybe noop (a change) =<< - (catchMaybeIO (getSymbolicLinkStatus (changedFile change))) + catchMaybeIO (R.getSymbolicLinkStatus (fromOsPath (changedFile change))) diff --git a/Utility/FileIO.hs b/Utility/FileIO.hs --- a/Utility/FileIO.hs +++ b/Utility/FileIO.hs @@ -2,8 +2,7 @@ - readFileString, writeFileString, and appendFileString. - - When building with file-io, all exported functions set the close-on-exec - - flag. Also, some other issues are handled that file-io does not handle - - correctly. + - flag. - - When not building with file-io, this provides equvilant - RawFilePath versions. Note that those versions do not currently @@ -46,11 +45,8 @@ import Utility.FileIO.CloseOnExec import Utility.FileIO.String #else --- On Windows, System.File.OsPath does not handle UNC-style conversion itself, --- so that has to be done when calling it. See --- https://github.com/haskell/file-io/issues/39 -import Utility.Path.Windows import Utility.OsPath +import Utility.Path.Windows import System.IO (IO, Handle, IOMode) import Prelude (String, return) import qualified Utility.FileIO.CloseOnExec as O @@ -60,55 +56,38 @@ import Control.Applicative withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r -withFile f m a = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.withFile f' m a +withFile = O.withFile openFile :: OsPath -> IOMode -> IO Handle -openFile f m = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.openFile f' m +openFile = O.openFile withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r -withBinaryFile f m a = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.withBinaryFile f' m a +withBinaryFile = O.withBinaryFile openBinaryFile :: OsPath -> IOMode -> IO Handle -openBinaryFile f m = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.openBinaryFile f' m +openBinaryFile = O.openBinaryFile readFile :: OsPath -> IO L.ByteString -readFile f = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.readFile f' +readFile = O.readFile readFile' :: OsPath -> IO B.ByteString -readFile' f = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.readFile' f' +readFile' = O.readFile' writeFile :: OsPath -> L.ByteString -> IO () -writeFile f b = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.writeFile f' b +writeFile = O.writeFile writeFile' :: OsPath -> B.ByteString -> IO () -writeFile' f b = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.writeFile' f' b +writeFile' = O.writeFile' appendFile :: OsPath -> L.ByteString -> IO () -appendFile f b = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.appendFile f' b +appendFile = O.appendFile appendFile' :: OsPath -> B.ByteString -> IO () -appendFile' f b = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.appendFile' f' b +appendFile' = O.appendFile' +-- On Windows, System.File.OsPath does not handle UNC-style conversion itself +-- for this function, so that has to be done when calling it. See +-- https://github.com/haskell/file-io/issues/39 openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle) openTempFile p s = do p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p) @@ -118,19 +97,13 @@ return (t', h) readFileString :: OsPath -> IO String -readFileString p = do - p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p) - O.readFileString p' +readFileString = O.readFileString writeFileString :: OsPath -> String -> IO () -writeFileString f txt = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.writeFileString f' txt +writeFileString = O.writeFileString appendFileString :: OsPath -> String -> IO () -appendFileString f txt = do - f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) - O.appendFileString f' txt +appendFileString = O.appendFileString #endif #else diff --git a/Utility/FileIO/CloseOnExec.hs b/Utility/FileIO/CloseOnExec.hs --- a/Utility/FileIO/CloseOnExec.hs +++ b/Utility/FileIO/CloseOnExec.hs @@ -3,11 +3,7 @@ - All functions have been modified to set the close-on-exec - flag to True. - - - Also, functions that return a Handle (for a non-binary file) - - have been modified to use the locale encoding, working around - - this bug: https://github.com/haskell/file-io/issues/45 - - - - Copyright 2025 Joey Hess + - Copyright 2025-2026 Joey Hess - Copyright 2024 Julian Ospald - - License: BSD-3-clause @@ -39,34 +35,29 @@ import System.File.OsPath.Internal (withOpenFile', augmentError) import qualified System.File.OsPath.Internal as I -import System.IO (IO, Handle, IOMode(..), hSetEncoding) -import GHC.IO.Encoding (getLocaleEncoding) +import System.IO (IO, Handle, IOMode(..)) import System.OsPath (OsPath, OsString) import Prelude (Bool(..), pure, either, (.), (>>=), ($)) import Control.Exception import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL -#ifndef mingw32_HOST_OS -import System.Posix.IO -import Utility.Process -#endif closeOnExec :: Bool closeOnExec = True withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r withFile osfp iomode act = (augmentError "withFile" osfp - $ withOpenFileEncoding osfp iomode False False closeOnExec (try . act) True) + $ withOpenFile' osfp iomode False False closeOnExec (try . act) True) >>= either ioError pure withFile' :: OsPath -> IOMode -> (Handle -> IO r) -> IO r withFile' osfp iomode act = (augmentError "withFile'" osfp - $ withOpenFileEncoding osfp iomode False False closeOnExec (try . act) False) + $ withOpenFile' osfp iomode False False closeOnExec (try . act) False) >>= either ioError pure openFile :: OsPath -> IOMode -> IO Handle openFile osfp iomode = augmentError "openFile" osfp $ - withOpenFileEncoding osfp iomode False False closeOnExec pure False + withOpenFile' osfp iomode False False closeOnExec pure False withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r withBinaryFile osfp iomode act = (augmentError "withBinaryFile" osfp @@ -78,71 +69,24 @@ withOpenFile' osfp iomode True False closeOnExec pure False readFile :: OsPath -> IO BSL.ByteString -readFile fp = withFileNoEncoding' fp ReadMode BSL.hGetContents +readFile fp = withFile' fp ReadMode BSL.hGetContents -readFile' - :: OsPath -> IO BS.ByteString -readFile' fp = withFileNoEncoding fp ReadMode BS.hGetContents +readFile' :: OsPath -> IO BS.ByteString +readFile' fp = withFile fp ReadMode BS.hGetContents writeFile :: OsPath -> BSL.ByteString -> IO () -writeFile fp contents = withFileNoEncoding fp WriteMode (`BSL.hPut` contents) +writeFile fp contents = withFile fp WriteMode (`BSL.hPut` contents) -writeFile' - :: OsPath -> BS.ByteString -> IO () -writeFile' fp contents = withFileNoEncoding fp WriteMode (`BS.hPut` contents) +writeFile' :: OsPath -> BS.ByteString -> IO () +writeFile' fp contents = withFile fp WriteMode (`BS.hPut` contents) appendFile :: OsPath -> BSL.ByteString -> IO () -appendFile fp contents = withFileNoEncoding fp AppendMode (`BSL.hPut` contents) +appendFile fp contents = withFile fp AppendMode (`BSL.hPut` contents) -appendFile' - :: OsPath -> BS.ByteString -> IO () -appendFile' fp contents = withFileNoEncoding fp AppendMode (`BS.hPut` contents) +appendFile' :: OsPath -> BS.ByteString -> IO () +appendFile' fp contents = withFile fp AppendMode (`BS.hPut` contents) -{- Re-implementing openTempFile is difficult due to the current - - structure of file-io. See this issue for discussion about improving - - that: https://github.com/haskell/file-io/issues/44 - - So, instead this uses noCreateProcessWhile. - - -} openTempFile :: OsPath -> OsString -> IO (OsPath, Handle) -openTempFile tmp_dir template = do -#ifdef mingw32_HOST_OS - (p, h) <- I.openTempFile tmp_dir template - getLocaleEncoding >>= hSetEncoding h - pure (p, h) -#else - noCreateProcessWhile $ do - (p, h) <- I.openTempFile tmp_dir template - fd <- handleToFd h - setFdOption fd CloseOnExec True - h' <- fdToHandle fd - getLocaleEncoding >>= hSetEncoding h' - pure (p, h') -#endif - -{- Wrapper around withOpenFile' that sets the locale encoding on the - - Handle. -} -withOpenFileEncoding :: OsPath -> IOMode -> Bool -> Bool -> Bool -> (Handle -> IO r) -> Bool -> IO r -withOpenFileEncoding fp iomode binary existing cloExec action close_finally = - withOpenFile' fp iomode binary existing cloExec action' close_finally - where - action' h = do - getLocaleEncoding >>= hSetEncoding h - action h - -{- Variant of withFile above that does not have the overhead of setting the - - locale encoding. Faster to use when the Handle is not used in a way that - - needs any encoding. -} -withFileNoEncoding :: OsPath -> IOMode -> (Handle -> IO r) -> IO r -withFileNoEncoding osfp iomode act = (augmentError "withFile" osfp - $ withOpenFile' osfp iomode False False closeOnExec (try . act) True) - >>= either ioError pure - -{- Variant of withFile' above that does not have the overhead of setting the - - locale encoding. Faster to use when the Handle is not used in a way that - - needs any encoding. -} -withFileNoEncoding' :: OsPath -> IOMode -> (Handle -> IO r) -> IO r -withFileNoEncoding' osfp iomode act = (augmentError "withFile'" osfp - $ withOpenFile' osfp iomode False False closeOnExec (try . act) False) - >>= either ioError pure - +openTempFile tmp_dir template = + I.openTempFile' "openTempFile" tmp_dir template False 0o600 closeOnExec #endif diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -31,6 +31,7 @@ download, downloadConduit, sinkResponseFile, + sinkResponseIncrementalVerifier, downloadPartial, matchStatusCodeException, matchHttpExceptionContent, @@ -591,6 +592,26 @@ () <- ui bs B.hPut fh bs go ui sofar' fh + +-- Sends a Response's body to an IncrementalVerifier, without writing it to +-- a file. +sinkResponseIncrementalVerifier + :: MonadResource m + => MeterUpdate + -> IncrementalVerifier + -> Response (ConduitM () B8.ByteString m ()) + -> m () +sinkResponseIncrementalVerifier meterupdate iv resp = + runConduit $ responseBody resp .| go zeroBytesProcessed + where + go sofar = await >>= \case + Nothing -> return () + Just bs -> do + let sofar' = addBytesProcessed sofar (B.length bs) + liftIO $ do + void $ meterupdate sofar' + updateIncrementalVerifier iv bs + go sofar' {- Downloads at least the specified number of bytes from an url. -} downloadPartial :: URLString -> UrlOptions -> Int -> IO (Maybe L.ByteString) 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.20260115 +Version: 10.20260213 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -274,6 +274,8 @@ git-lfs (>= 1.2.0), clock (>= 0.3.0), crypton, + crypton-connection, + tls, servant, servant-server, servant-client, @@ -311,7 +313,7 @@ os-string (>= 2.0.0), directory (>= 1.3.8.3), filepath (>= 1.5.2.0), - file-io (>= 0.1.3) + file-io (>= 0.2.0) CPP-Options: -DWITH_OSPATH else Build-Depends: @@ -638,7 +640,6 @@ Command.Dead Command.Describe Command.DiffDriver - Command.Direct Command.Drop Command.DropKey Command.DropUnused @@ -667,7 +668,6 @@ Command.Import Command.ImportFeed Command.InAnnex - Command.Indirect Command.Info Command.Init Command.InitCluster @@ -695,7 +695,6 @@ Command.P2PStdIO Command.PostReceive Command.PreCommit - Command.Proxy Command.Pull Command.Push Command.Recompute @@ -727,7 +726,6 @@ Command.TestRemote Command.Transferrer Command.TransferKey - Command.TransferKeys Command.Trust Command.Unannex Command.Undo diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -9,8 +9,11 @@ debuglocks: false benchmark: true ospath: true + file-io: + os-string: true packages: - '.' resolver: lts-24.26 extra-deps: - aws-0.25.2 +- file-io-0.2.0