git-annex 10.20260115 → 10.20260213
raw patch · 58 files changed
+571/−498 lines, 58 filesdep +crypton-connectiondep +tlsdep ~file-io
Dependencies added: crypton-connection, tls
Dependency ranges changed: file-io
Files
- Annex.hs +3/−1
- Annex/Branch.hs +12/−6
- Annex/Concurrent.hs +4/−1
- Annex/Url.hs +22/−6
- Assistant/Install.hs +1/−1
- Backend/URL.hs +12/−2
- CHANGELOG +34/−0
- CmdLine/Action.hs +11/−7
- CmdLine/GitAnnex.hs +0/−8
- CmdLine/GitAnnex/Options.hs +16/−1
- Command/AddUrl.hs +9/−9
- Command/Direct.hs +0/−21
- Command/FromKey.hs +1/−1
- Command/Fsck.hs +39/−17
- Command/ImportFeed.hs +1/−1
- Command/Indirect.hs +0/−21
- Command/P2PHttp.hs +22/−4
- Command/Proxy.hs +0/−23
- Command/RegisterUrl.hs +8/−8
- Command/Sync.hs +60/−14
- Command/TransferKeys.hs +0/−141
- Command/Undo.hs +2/−1
- Command/UnregisterUrl.hs +13/−6
- Config.hs +10/−1
- P2P/Http/Server.hs +19/−13
- P2P/Http/State.hs +69/−9
- P2P/Proxy.hs +2/−3
- Remote.hs +1/−0
- Remote/Adb.hs +1/−0
- Remote/BitTorrent.hs +1/−0
- Remote/Borg.hs +1/−0
- Remote/Bup.hs +1/−0
- Remote/Compute.hs +1/−0
- Remote/Ddar.hs +1/−0
- Remote/Directory.hs +1/−0
- Remote/External.hs +1/−0
- Remote/GCrypt.hs +1/−0
- Remote/Git.hs +26/−7
- Remote/GitLFS.hs +1/−0
- Remote/Glacier.hs +1/−0
- Remote/Hook.hs +1/−0
- Remote/HttpAlso.hs +1/−0
- Remote/Mask.hs +1/−0
- Remote/P2P.hs +1/−0
- Remote/Rsync.hs +2/−8
- Remote/S3.hs +50/−7
- Remote/Tahoe.hs +1/−0
- Remote/Web.hs +1/−0
- Remote/WebDAV.hs +1/−0
- Types/Concurrency.hs +8/−1
- Types/GitConfig.hs +7/−0
- Types/Remote.hs +4/−4
- Utility/DirWatcher/Kqueue.hs +23/−22
- Utility/FileIO.hs +18/−45
- Utility/FileIO/CloseOnExec.hs +16/−72
- Utility/Url.hs +21/−0
- git-annex.cabal +4/−6
- stack.yaml +3/−0
Annex.hs view
@@ -1,6 +1,6 @@ {- git-annex monad -- - Copyright 2010-2024 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name> - - 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
Annex/Branch.hs view
@@ -1,6 +1,6 @@ {- management of the git-annex branch -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - 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
Annex/Concurrent.hs view
@@ -1,6 +1,6 @@ {- git-annex concurrent state -- - Copyright 2015-2022 Joey Hess <id@joeyh.name>+ - Copyright 2015-2026 Joey Hess <id@joeyh.name> - - 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.
Annex/Url.hs view
@@ -1,12 +1,12 @@ {- Url downloading, with git-annex user agent and configured http - headers, security restrictions, etc. -- - Copyright 2013-2022 Joey Hess <id@joeyh.name>+ - Copyright 2013-2026 Joey Hess <id@joeyh.name> - - 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
Assistant/Install.hs view
@@ -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
Backend/URL.hs view
@@ -1,13 +1,14 @@ {- git-annex URL backend -- keys whose content is available from urls. -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - 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
CHANGELOG view
@@ -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 <id@joeyh.name> Fri, 13 Feb 2026 12:53:48 -0400+ git-annex (10.20260115) upstream; urgency=medium * New git configs annex.initwanted, annex.initrequired, and
CmdLine/Action.hs view
@@ -1,6 +1,6 @@ {- git-annex command-line actions and concurrency -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name> - - 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
CmdLine/GitAnnex.hs view
@@ -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
CmdLine/GitAnnex/Options.hs view
@@ -1,6 +1,6 @@ {- git-annex command-line option parsing -- - Copyright 2010-2024 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name> - - 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 )
Command/AddUrl.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - 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
− Command/Direct.hs
@@ -1,21 +0,0 @@-{- git-annex command- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - 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."
Command/FromKey.hs view
@@ -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
Command/Fsck.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2010-2025 Joey Hess <id@joeyh.name>+ - Copyright 2010-2026 Joey Hess <id@joeyh.name> - - 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
Command/ImportFeed.hs view
@@ -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.
− Command/Indirect.hs
@@ -1,21 +0,0 @@-{- git-annex command- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - 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
Command/P2PHttp.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2024-2025 Joey Hess <id@joeyh.name>+ - Copyright 2024-2026 Joey Hess <id@joeyh.name> - - 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
− Command/Proxy.hs
@@ -1,23 +0,0 @@-{- git-annex command- -- - Copyright 2014 Joey Hess <id@joeyh.name>- -- - 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)
Command/RegisterUrl.hs view
@@ -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))
Command/Sync.hs view
@@ -1,7 +1,7 @@ {- git-annex command - - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - 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
− Command/TransferKeys.hs
@@ -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 <id@joeyh.name>- -- - 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
Command/Undo.hs view
@@ -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)
Command/UnregisterUrl.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2015-2022 Joey Hess <id@joeyh.name>+ - Copyright 2015-2026 Joey Hess <id@joeyh.name> - - 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.
Config.hs view
@@ -1,6 +1,6 @@ {- Git configuration -- - Copyright 2011-2023 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - 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)
P2P/Http/Server.hs view
@@ -2,7 +2,7 @@ - - https://git-annex.branchable.com/design/p2p_protocol_over_http/ -- - Copyright 2024 Joey Hess <id@joeyh.name>+ - Copyright 2024-2026 Joey Hess <id@joeyh.name> - - 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
P2P/Http/State.hs view
@@ -2,7 +2,7 @@ - - https://git-annex.branchable.com/design/p2p_protocol_over_http/ -- - Copyright 2024-2025 Joey Hess <id@joeyh.name>+ - Copyright 2024-2026 Joey Hess <id@joeyh.name> - - 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 ()+
P2P/Proxy.hs view
@@ -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
Remote.hs view
@@ -21,6 +21,7 @@ hasKey, hasKeyCheap, whereisKey,+ repairKey, remoteFsck, remoteTypes,
Remote/Adb.hs view
@@ -108,6 +108,7 @@ } , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/BitTorrent.hs view
@@ -81,6 +81,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , gitconfig = gc
Remote/Borg.hs view
@@ -107,6 +107,7 @@ } , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/Bup.hs view
@@ -90,6 +90,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/Compute.hs view
@@ -122,6 +122,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , gitconfig = gc
Remote/Ddar.hs view
@@ -92,6 +92,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/Directory.hs view
@@ -128,6 +128,7 @@ } , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/External.hs view
@@ -143,6 +143,7 @@ , importActions = importUnsupported , whereisKey = towhereis , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , localpath = Nothing
Remote/GCrypt.hs view
@@ -148,6 +148,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , localpath = localpathCalc r
Remote/Git.hs view
@@ -1,6 +1,6 @@ {- Standard git remotes. -- - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - 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
Remote/GitLFS.hs view
@@ -126,6 +126,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/Glacier.hs view
@@ -96,6 +96,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/Hook.hs view
@@ -75,6 +75,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , localpath = Nothing
Remote/HttpAlso.hs view
@@ -88,6 +88,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , gitconfig = gc
Remote/Mask.hs view
@@ -66,6 +66,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/P2P.hs view
@@ -70,6 +70,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , localpath = Nothing
Remote/Rsync.hs view
@@ -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
Remote/S3.hs view
@@ -1,6 +1,6 @@ {- S3 remotes -- - Copyright 2011-2025 Joey Hess <id@joeyh.name>+ - Copyright 2011-2026 Joey Hess <id@joeyh.name> - - 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
Remote/Tahoe.hs view
@@ -108,6 +108,7 @@ , importActions = importUnsupported , whereisKey = Just (getWhereisKey rs) , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Remote/Web.hs view
@@ -89,6 +89,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , gitconfig = gc
Remote/WebDAV.hs view
@@ -109,6 +109,7 @@ , importActions = importUnsupported , whereisKey = Nothing , remoteFsck = Nothing+ , repairKey = Nothing , repairRepo = Nothing , config = c , getRepo = return r
Types/Concurrency.hs view
@@ -1,4 +1,4 @@-{- Copyright 2016 Joey Hess <id@joeyh.name>+{- Copyright 2016-2026 Joey Hess <id@joeyh.name> - - 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+
Types/GitConfig.hs view
@@ -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"
Types/Remote.hs view
@@ -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,
Utility/DirWatcher/Kqueue.hs view
@@ -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)))
Utility/FileIO.hs view
@@ -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
Utility/FileIO/CloseOnExec.hs view
@@ -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 <id@joeyh.name>+ - Copyright 2025-2026 Joey Hess <id@joeyh.name> - 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
Utility/Url.hs view
@@ -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)
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20260115+Version: 10.20260213 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -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
stack.yaml view
@@ -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