packages feed

git-annex 10.20241031 → 10.20241202

raw patch · 24 files changed

+687/−304 lines, 24 files

Files

Annex/Path.hs view
@@ -1,6 +1,6 @@ {- git-annex program path  -- - Copyright 2013-2022 Joey Hess <id@joeyh.name>+ - Copyright 2013-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -18,9 +18,11 @@ import Config.Files import Utility.Env import Annex.PidLock+import CmdLine.Multicall import qualified Annex  import System.Environment (getExecutablePath, getArgs, getProgName)+import qualified Data.Map as M  {- A fully qualified path to the currently running git-annex program.  - @@ -33,23 +35,35 @@  - getExecutablePath. It sets GIT_ANNEX_DIR to the location of the  - standalone build directory, and there are wrapper scripts for git-annex  - and git-annex-shell in that directory.+ -+ - When the currently running program is not git-annex, but is instead eg+ - git-annex-shell or git-remote-annex, this finds a git-annex program+ - instead.  -} programPath :: IO FilePath programPath = go =<< getEnv "GIT_ANNEX_DIR"   where 	go (Just dir) = do-		name <- getProgName+		name <- reqgitannex <$> getProgName 		return (dir </> name) 	go Nothing = do-		exe <- getExecutablePath+		name <- getProgName+		exe <- if isgitannex name+			then getExecutablePath+			else pure "git-annex" 		p <- if isAbsolute exe 			then return exe 			else fromMaybe exe <$> readProgramFile 		maybe cannotFindProgram return =<< searchPath p +	reqgitannex name+		| isgitannex name = name+		| otherwise = "git-annex"+	isgitannex = flip M.notMember otherMulticallCommands+ {- Returns the path for git-annex that is recorded in the programFile. -} readProgramFile :: IO (Maybe FilePath)-readProgramFile = do+readProgramFile = catchDefaultIO Nothing $ do 	programfile <- programFile 	headMaybe . lines <$> readFile programfile
Assistant/Threads/Committer.hs view
@@ -45,6 +45,7 @@ import Utility.Tuple import Utility.Metered import qualified Utility.RawFilePath as R+import Git.FilePath  import Data.Time.Clock import qualified Data.Set as S@@ -319,15 +320,19 @@ 					(LinkChange (Just key)) 	 	checksmall change-		| not annexdotfiles && dotfile f =-			return (Right change)-		| otherwise =-			ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f)-				( return (Left change)-				, return (Right change)-				)+		| not annexdotfiles = do+			topfile <- liftAnnex $ +				getTopFilePath <$> inRepo (toTopFilePath f)+			if dotfile topfile+				then return (Right change)+				else checkmatcher+		| otherwise = checkmatcher 	  where 		f = toRawFilePath (changeFile change)+		checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f)+			( return (Left change)+			, return (Right change)+			)  	addsmall [] = noop 	addsmall toadd = liftAnnex $ void $ tryIO $
CHANGELOG view
@@ -1,3 +1,35 @@+git-annex (10.20241202) upstream; urgency=medium++  * add: Consistently treat files in a dotdir as dotfiles, even+    when ran inside that dotdir.+  * add: When adding a dotfile as a non-large file, mention that it's a+    dotfile.+  * p2phttp: Added --directory option which serves multiple git-annex+    repositories located inside a directory.+  * When remote.name.annexUrl is an annex+http(s) url, that+    uses the same hostname as remote.name.url, which is itself a http(s)+    url, they are assumed to share a username and password. This avoids+    unnecessary duplicate password prompts.+  * git-remote-annex: Fix a reversion introduced in version 10.20241031+    that broke cloning from a special remote.+  * git-remote-annex: Fix cloning from a special remote on a crippled+    filesystem.+  * git-remote-annex: Fix buggy behavior when annex.stalldetection is+    configured.+  * git-remote-annex: Require git version 2.31 or newer, since old+    ones had a buggy git bundle command.+  * S3: Support versioning=yes with a readonly bucket.+    (Needs aws-0.24.3)+  * S3: Send git-annex or other configured User-Agent.+    (Needs aws-0.24.3)+  * S3: Fix infinite loop and memory blowup when importing from an+    unversioned S3 bucket that is large enough to need pagination.+  * S3: Use significantly less memory when importing from a+    versioned S3 bucket.+  * vpop: Only update state after successful checkout.++ -- Joey Hess <id@joeyh.name>  Mon, 02 Dec 2024 12:31:08 -0400+ git-annex (10.20241031) upstream; urgency=medium    * Sped up proxied downloads from special remotes, by streaming.
CmdLine/GitAnnex/Options.hs view
@@ -511,14 +511,18 @@ -- action in `allowConcurrentOutput`. jobsOption :: [AnnexOption] jobsOption = -	[ annexOption (setAnnexState . setConcurrency . ConcurrencyCmdLine) $ -		option (maybeReader parseConcurrency)-			( long "jobs" <> short 'J' -			<> metavar (paramNumber `paramOr` "cpus")-			<> help "enable concurrent jobs"-			<> hidden-			)+	[ annexOption (setAnnexState . setConcurrency . ConcurrencyCmdLine)+		jobsOptionParser 	]++jobsOptionParser :: Parser Concurrency+jobsOptionParser = +	option (maybeReader parseConcurrency)+		( long "jobs" <> short 'J' +		<> metavar (paramNumber `paramOr` "cpus")+		<> help "enable concurrent jobs"+		<> hidden+		)  timeLimitOption :: [AnnexOption] timeLimitOption =
CmdLine/GitRemoteAnnex.hs view
@@ -48,6 +48,7 @@ import Annex.UUID import Annex.Content import Annex.Perms+import Annex.Tmp import Annex.SpecialRemote.Config import Remote.List import Remote.List.Util@@ -69,6 +70,8 @@  run :: [String] -> IO () run (remotename:url:[]) = do+	unlessM Git.Bundle.versionSupported $+		giveup "git-remote-annex needs a newer version of git" 	repo <- getRepo 	state <- Annex.new repo 	Annex.eval state $@@ -82,7 +85,7 @@ 		case parseSpecialRemoteNameUrl remotename u of 			Right src -> checkallowed src >>= run' u 			Left e -> giveup e-run (_remotename:[]) = giveup "remote url not configured"+run (remotename:[]) = giveup $ "remote url not configured for " ++ remotename run _ = giveup "expected remote name and url parameters"  run' :: String -> SpecialRemoteConfig -> Annex ()@@ -719,13 +722,14 @@ 	-- directory. The content of manifests is not stable, and so 	-- it needs to re-download it fresh every time, and the object 	-- file should not be stored locally.-	gettotmp dl = withTmpFile "GITMANIFEST" $ \tmp tmph -> do-		liftIO $ hClose tmph-		_ <- dl tmp-		b <- liftIO (B.readFile tmp)-		case parseManifest b of-			Right m -> Just <$> verifyManifest rmt m-			Left err -> giveup err+	gettotmp dl = withOtherTmp $ \othertmp ->+		withTmpFileIn (fromRawFilePath othertmp) "GITMANIFEST" $ \tmp tmph -> do+			liftIO $ hClose tmph+			_ <- dl tmp+			b <- liftIO (B.readFile tmp)+			case parseManifest b of+				Right m -> Just <$> verifyManifest rmt m+				Left err -> giveup err  	getexport _ [] = return Nothing 	getexport mk (loc:locs) =@@ -1127,7 +1131,7 @@ -- If the git-annex branch did not exist when this command started, -- it was created empty by this command, and this command has avoided -- making any other commits to it, writing any temporary annex branch--- changes to thre alternateJournal, which can now be discarded. +-- changes to the alternateJournal, which can now be discarded.  --  -- If nothing else has written to the branch while this command was running, -- the branch will be deleted. That allows for the git-annex branch that is@@ -1150,6 +1154,11 @@ -- does not contain any hooks. Since initialization installs -- hooks, have to work around that by not initializing, and  -- delete the git bundle objects.+--+-- Similarly, when on a crippled filesystem, doing initialization would+-- involve checking out an adjusted branch. But git clone wants to do its+-- own checkout. So no initialization is done then, and the git bundle+-- objects are deleted. cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex () cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do 	liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir@@ -1171,7 +1180,7 @@ 					Nothing -> return () 					Just _ -> void $ tryNonAsync $ 						inRepo $ Git.Branch.delete Annex.Branch.fullname-	ifM (Annex.Branch.hasSibling <&&> nonbuggygitversion)+	ifM (Annex.Branch.hasSibling <&&> nonbuggygitversion <&&> notcrippledfilesystem) 		( do 			autoInitialize' (pure True) startupAnnex remoteList 			differences <- allDifferences <$> recordedDifferences@@ -1187,6 +1196,8 @@                 	GitBundleKey -> lockContentForRemoval k noop removeAnnex 			_ -> noop 		void $ liftIO $ tryIO $ removeDirectory (decodeBS annexobjectdir)++	notcrippledfilesystem = not <$> probeCrippledFileSystem  	nonbuggygitversion = liftIO $ 		flip notElem buggygitversions <$> Git.Version.installed
+ CmdLine/Multicall.hs view
@@ -0,0 +1,28 @@+{- git-annex multicall binary+ -+ - Copyright 2024 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module CmdLine.Multicall where++import qualified Data.Map as M++-- Commands besides git-annex that can be run by the multicall binary.+--+-- The reason git-annex itself is not included here is because the program+-- can be renamed to any other name than these and will behave the same as+-- git-annex.+data OtherMultiCallCommand+	= GitAnnexShell+	| GitRemoteAnnex+	| GitRemoteTorAnnex++otherMulticallCommands :: M.Map String OtherMultiCallCommand+otherMulticallCommands = M.fromList+	[ ("git-annex-shell", GitAnnexShell)+	, ("git-remote-annex", GitRemoteAnnex)+	, ("git-remote-tor-annex", GitRemoteTorAnnex)+	]+
Command/Add.hs view
@@ -94,17 +94,21 @@ 	addunlockedmatcher <- addUnlockedMatcher 	annexdotfiles <- getGitConfigVal annexDotFiles  	let gofile includingsmall (si, file) = case largeFilesOverride o of-		Nothing -> ifM (pure (annexdotfiles || not (dotfile file))-			<&&> (checkFileMatcher NoLiveUpdate largematcher file -			<||> Annex.getRead Annex.force))-			( start dr si file addunlockedmatcher-			, if includingsmall-				then ifM (annexAddSmallFiles <$> Annex.getGitConfig)-					( startSmall dr si file-					, stop-					)-				else stop-			)+		Nothing -> do+			isdotfile <- if annexdotfiles+				then pure False+				else dotfile . getTopFilePath+					<$> inRepo (toTopFilePath file)+			islarge <- checkFileMatcher NoLiveUpdate largematcher file+				<||> Annex.getRead Annex.force+			if (not isdotfile && islarge)+				then start dr si file addunlockedmatcher+				else if includingsmall+					then ifM (annexAddSmallFiles <$> Annex.getGitConfig)+						( startSmall isdotfile dr si file+						, stop+						)+					else stop 		Just True -> start dr si file addunlockedmatcher 		Just False -> startSmallOverridden dr si file 	case batchOption o of@@ -136,17 +140,18 @@ 	dr = dryRunOption o  {- Pass file off to git-add. -}-startSmall :: DryRun -> SeekInput -> RawFilePath -> CommandStart-startSmall dr si file =+startSmall :: Bool -> DryRun -> SeekInput -> RawFilePath -> CommandStart+startSmall isdotfile dr si file = 	liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case 		Just s ->  			starting "add" (ActionItemTreeFile file) si $-				addSmall dr file s+				addSmall isdotfile dr file s 		Nothing -> stop -addSmall :: DryRun -> RawFilePath -> FileStatus -> CommandPerform-addSmall dr file s = do-	showNote "non-large file; adding content to git repository"+addSmall :: Bool -> DryRun -> RawFilePath -> FileStatus -> CommandPerform+addSmall isdotfile dr file s = do+	showNote $ (if isdotfile then "dotfile" else "non-large file")+		<> "; adding content to git repository" 	skipWhenDryRun dr $ next $ addFile Small file s  startSmallOverridden :: DryRun -> SeekInput -> RawFilePath -> CommandStart
Command/AddUrl.hs view
@@ -519,7 +519,7 @@ 				-- than the work tree file. 				liftIO $ moveFile file tmp 				go-			else Command.Add.addSmall (DryRun False) file s+			else Command.Add.addSmall False (DryRun False) file s 				>>= maybe noop void   where 	go = do
Command/Import.hs view
@@ -261,7 +261,7 @@ 				>>= maybe 					stop 					(\addedk -> next $ Command.Add.cleanup addedk True)-			, Command.Add.addSmall (DryRun False) destfile s+			, Command.Add.addSmall False (DryRun False) destfile s 			) 	notoverwriting why = do 		warning $ "not overwriting existing " <> QuotedPath destfile <> " " <> UnquotedString why
Command/P2PHttp.hs view
@@ -11,11 +11,16 @@  module Command.P2PHttp where -import Command+import Command hiding (jobsOption) import P2P.Http.Server import P2P.Http.Url import qualified P2P.Protocol as P2P import Utility.Env+import Annex.UUID+import qualified Git+import qualified Git.Construct+import qualified Annex+import Types.Concurrency  import Servant import qualified Network.Wai.Handler.Warp as Warp@@ -23,12 +28,14 @@ import Network.Socket (PortNumber) import qualified Data.Map as M import Data.String+import Control.Concurrent.STM  cmd :: Command-cmd = noMessages $ withAnnexOptions [jobsOption] $-	command "p2phttp" SectionPlumbing-		"communicate in P2P protocol over http"-		paramNothing (seek <$$> optParser)+cmd = noMessages $ dontCheck repoExists $ +	noRepo (startIO <$$> optParser) $+		command "p2phttp" SectionPlumbing+			"communicate in P2P protocol over http"+			paramNothing (startAnnex <$$> optParser)  data Options = Options 	{ portOption :: Maybe PortNumber@@ -43,7 +50,9 @@ 	, unauthNoLockingOption :: Bool 	, wideOpenOption :: Bool 	, proxyConnectionsOption :: Maybe Integer+	, jobsOption :: Maybe Concurrency 	, clusterJobsOption :: Maybe Int+	, directoryOption :: [FilePath] 	}  optParser :: CmdParamsDesc -> Parser Options@@ -96,32 +105,80 @@ 		( long "proxyconnections" <> metavar paramNumber 		<> help "maximum number of idle connections when proxying" 		))+	<*> optional jobsOptionParser 	<*> optional (option auto 		( long "clusterjobs" <> metavar paramNumber 		<> help "number of concurrent node accesses per connection" 		))+	<*> many (strOption+		( long "directory" <> metavar paramPath+		<> help "serve repositories in subdirectories of a directory"+		)) -seek :: Options -> CommandSeek-seek o = getAnnexWorkerPool $ \workerpool ->-	withP2PConnections workerpool-		(fromMaybe 1 $ proxyConnectionsOption o)-		(fromMaybe 1 $ clusterJobsOption o)-		(go workerpool)-  where-	go workerpool acquireconn = liftIO $ do+startAnnex :: Options -> Annex ()+startAnnex o+	| null (directoryOption o) = ifM ((/=) NoUUID <$> getUUID)+		( do+			authenv <- liftIO getAuthEnv+			st <- mkServerState o authenv+			liftIO $ runServer o st+		-- Run in a git repository that is not a git-annex repository.+		, liftIO $ startIO o +		)+	| otherwise = liftIO $ startIO o++startIO :: Options -> IO ()+startIO o+	| null (directoryOption o) = +		giveup "Use the --directory option to specify which git-annex repositories to serve."+	| otherwise = do 		authenv <- getAuthEnv-		st <- mkP2PHttpServerState acquireconn workerpool $-			mkGetServerMode authenv o+		st <- mkst authenv mempty+		runServer o st+  where+	mkst authenv oldst = do+		repos <- findRepos o+		sts <- forM repos $ \r -> do+			strd <- Annex.new r+			Annex.eval strd (mkstannex authenv oldst)+		return (mconcat sts)+			{ updateRepos = updaterepos authenv+			}+	+	mkstannex authenv oldst = do+		u <- getUUID+		if u == NoUUID+			then return mempty+			else case M.lookup u (servedRepos oldst) of+				Nothing -> mkServerState o authenv+				Just old -> return $ P2PHttpServerState+					{ servedRepos = M.singleton u old+					, serverShutdownCleanup = mempty+					, updateRepos = mempty+					}+	+	updaterepos authenv oldst = do+		newst <- mkst authenv oldst+		return $ newst+			{ serverShutdownCleanup = +				serverShutdownCleanup newst +					<> serverShutdownCleanup oldst+			}++runServer :: Options -> P2PHttpServerState -> IO ()+runServer o mst = go `finally` serverShutdownCleanup mst+  where+	go = do 		let settings = Warp.setPort port $ Warp.setHost host $ 			Warp.defaultSettings+		mstv <- newTMVarIO mst 		case (certFileOption o, privateKeyFileOption o) of-			(Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp st)+			(Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp mstv) 			(Just certfile, Just privatekeyfile) -> do 				let tlssettings = Warp.tlsSettingsChain 					certfile (chainFileOption o) privatekeyfile-				Warp.runTLS tlssettings settings (p2pHttpApp st)+				Warp.runTLS tlssettings settings (p2pHttpApp mstv) 			_ -> giveup "You must use both --certfile and --privatekeyfile options to enable HTTPS."-	 	port = maybe 		(fromIntegral defaultP2PHttpProtocolPort) 		fromIntegral@@ -131,6 +188,15 @@ 		fromString 		(bindOption o) +mkServerState :: Options -> M.Map Auth P2P.ServerMode -> Annex P2PHttpServerState+mkServerState o authenv = +	withAnnexWorkerPool (jobsOption o) $+		mkP2PHttpServerState+			(mkGetServerMode authenv o)+			return+			(fromMaybe 1 $ proxyConnectionsOption o)+			(fromMaybe 1 $ clusterJobsOption o)+ mkGetServerMode :: M.Map Auth P2P.ServerMode -> Options -> GetServerMode mkGetServerMode _ o _ Nothing 	| wideOpenOption o = ServerMode@@ -197,3 +263,11 @@ 		case M.lookup user permmap of 			Nothing -> (auth, P2P.ServeReadWrite) 			Just perms -> (auth, perms)++findRepos :: Options -> IO [Git.Repo]+findRepos o = do+	files <- map toRawFilePath . concat+		<$> mapM dirContents (directoryOption o)+	map Git.Construct.newFrom . catMaybes +		<$> mapM Git.Construct.checkForRepo files+
Command/Smudge.hs view
@@ -239,12 +239,14 @@ 		, checkunchanged checkwasannexed 		)   where-	checkmatcher d-		| dotfile file = ifM (getGitConfigVal annexDotFiles)-			( go-			, d-			)-		| otherwise = go+	checkmatcher d = do+		topfile <- getTopFilePath <$> inRepo (toTopFilePath file)+		if dotfile topfile+			then ifM (getGitConfigVal annexDotFiles)+				( go+				, d+				)+			else go 	  where 		go = do 			matcher <- largeFilesMatcher
Command/VPop.hs view
@@ -28,22 +28,29 @@   where 	go Nothing = giveup "Not in a view." 	go (Just (v, madj)) = starting "vpop" ai si $ do-		removeView v-		(oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v)+		(oldvs, vs) <- splitAt (num - 1) +			. filter (sameparentbranch v)+			. filter (/= v) 			<$> recentViews-		mapM_ removeView oldvs-		case vs of-			(oldv:_) -> next $ do+		let removeview = mapM_ removeView (v : oldvs)+		ok <- case vs of+			(oldv:_) -> do 				showOutput 				checkoutViewBranch oldv madj 					(\v' madj' -> return (branchView v' madj'))-			_ -> next $ do+			_ -> do 				showOutput 				inRepo $ Git.Command.runBool 					[ Param "checkout" 					, Param $ Git.fromRef $ Git.Ref.base $ 						viewParentBranch v 					]+		if ok+			then+				next $ do+					removeview+					return True+			else next $ return False 	sameparentbranch a b = viewParentBranch a == viewParentBranch b  	num = fromMaybe 1 $ readish =<< headMaybe ps
Git/Bundle.hs view
@@ -12,9 +12,15 @@ import Common import Git import Git.Command+import qualified Git.Version  import Data.Char (ord) import qualified Data.ByteString.Char8 as S8++-- Older versions of git had a git bundle command that sometimes omitted+-- refs, and that did not properly support --stdin.+versionSupported :: IO Bool+versionSupported = not <$> Git.Version.older "2.31"  listHeads :: FilePath -> Repo -> IO [(Sha, Ref)] listHeads bundle repo = map gen . S8.lines <$>
P2P/Http/Client.hs view
@@ -24,13 +24,13 @@ import Utility.Metered import Utility.FileSize import Types.NumCopies-+import Types.Remote import Annex.Common+import qualified Git #ifdef WITH_SERVANT import qualified Annex import Annex.UUID import Annex.Url-import Types.Remote import P2P.Http import P2P.Http.Url import Annex.Concurrent@@ -83,8 +83,19 @@ 	-> (String -> Annex a) 	-> ClientAction a 	-> Annex (Maybe a)+p2pHttpClientVersions allowedversion rmt fallback clientaction = do+	rmtrepo <- getRepo rmt+	p2pHttpClientVersions' allowedversion rmt rmtrepo fallback clientaction++p2pHttpClientVersions'+	:: (ProtocolVersion -> Bool)+	-> Remote+	-> Git.Repo+	-> (String -> Annex a)+	-> ClientAction a+	-> Annex (Maybe a) #ifdef WITH_SERVANT-p2pHttpClientVersions allowedversion rmt fallback clientaction =+p2pHttpClientVersions' allowedversion rmt rmtrepo fallback clientaction = 	case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of 		Nothing -> error "internal" 		Just baseurl -> do@@ -139,9 +150,13 @@ 			++ " " ++ 		decodeBS (statusMessage (responseStatusCode resp)) -	credentialbaseurl = case p2pHttpUrlString <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of+	credentialbaseurl = case remoteAnnexP2PHttpUrl (gitconfig rmt) of+		Just p2phttpurl +			| isP2PHttpSameHost p2phttpurl rmtrepo ->+				Git.repoLocation rmtrepo+			| otherwise ->+				p2pHttpUrlString p2phttpurl 		Nothing -> error "internal"-		Just url -> url  	credauth cred = do 		ba <- Git.credentialBasicAuth cred@@ -159,7 +174,7 @@ 					M.insert (Git.CredentialBaseURL credentialbaseurl) cred cc 		Nothing -> noop #else-p2pHttpClientVersions _ _ fallback () = Just <$> fallback+p2pHttpClientVersions' _ _ _ fallback () = Just <$> fallback 	"This remote uses an annex+http url, but this version of git-annex is not built with support for that." #endif @@ -420,7 +435,7 @@ 		_ :<|> _ :<|> 		v4 :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI #else-clientPut _ _ _ _ _ _ _ = ()+clientPut _ _ _ _ _ _ _ _ = () #endif  clientPutOffset
P2P/Http/Server.hs view
@@ -45,10 +45,10 @@ import System.IO.Unsafe import Data.Either -p2pHttpApp :: P2PHttpServerState -> Application+p2pHttpApp :: TMVar P2PHttpServerState -> Application p2pHttpApp = serve p2pHttpAPI . serveP2pHttp -serveP2pHttp :: P2PHttpServerState -> Server P2PHttpAPI+serveP2pHttp :: TMVar P2PHttpServerState -> Server P2PHttpAPI serveP2pHttp st 	=    serveGet st 	:<|> serveGet st@@ -91,7 +91,7 @@ 	:<|> serveGetGeneric st  serveGetGeneric-	:: P2PHttpServerState+	:: TMVar P2PHttpServerState 	-> B64UUID ServerSide 	-> B64Key 	-> Maybe (B64UUID ClientSide)@@ -109,7 +109,7 @@  serveGet 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> B64UUID ServerSide 	-> v 	-> B64Key@@ -120,8 +120,8 @@ 	-> IsSecure 	-> Maybe Auth 	-> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString))-serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do-	conn <- getP2PConnection apiver st cu su bypass sec auth ReadAction id+serveGet mst su apiver (B64Key k) cu bypass baf startat sec auth = do+	(conn, st) <- getP2PConnection apiver mst cu su bypass sec auth ReadAction id 	bsv <- liftIO newEmptyTMVarIO 	endv <- liftIO newEmptyTMVarIO 	validityv <- liftIO newEmptyTMVarIO@@ -222,7 +222,7 @@  serveCheckPresent 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> B64UUID ServerSide 	-> v 	-> B64Key@@ -233,14 +233,14 @@ 	-> Handler CheckPresentResult serveCheckPresent st su apiver (B64Key k) cu bypass sec auth = do 	res <- withP2PConnection apiver st cu su bypass sec auth ReadAction id-		$ \conn -> liftIO $ proxyClientNetProto conn $ checkPresent k+		$ \(conn, _) -> liftIO $ proxyClientNetProto conn $ checkPresent k 	case res of 		Right b -> return (CheckPresentResult b) 		Left err -> throwError $ err500 { errBody = encodeBL err }  serveRemove 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> (RemoveResultPlus -> t) 	-> B64UUID ServerSide 	-> v@@ -252,7 +252,7 @@ 	-> Handler t serveRemove st resultmangle su apiver (B64Key k) cu bypass sec auth = do 	res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction id-		$ \conn ->+		$ \(conn, _) -> 			liftIO $ proxyClientNetProto conn $ remove Nothing k 	case res of 		(Right b, plusuuids) -> return $ resultmangle $ @@ -262,7 +262,7 @@  serveRemoveBefore 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> B64UUID ServerSide 	-> v 	-> B64Key@@ -274,7 +274,7 @@ 	-> Handler RemoveResultPlus serveRemoveBefore st su apiver (B64Key k) cu bypass (Timestamp ts) sec auth = do 	res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction id-		$ \conn ->+		$ \(conn, _) -> 			liftIO $ proxyClientNetProto conn $ 				removeBeforeRemoteEndTime ts k 	case res of@@ -285,7 +285,7 @@  serveGetTimestamp 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> B64UUID ServerSide 	-> v 	-> B64UUID ClientSide@@ -295,7 +295,7 @@ 	-> Handler GetTimestampResult serveGetTimestamp st su apiver cu bypass sec auth = do 	res <- withP2PConnection apiver st cu su bypass sec auth ReadAction id-		$ \conn ->+		$ \(conn, _) -> 			liftIO $ proxyClientNetProto conn getTimestamp 	case res of 		Right ts -> return $ GetTimestampResult (Timestamp ts)@@ -304,7 +304,7 @@  servePut 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> (PutResultPlus -> t) 	-> B64UUID ServerSide 	-> v@@ -319,28 +319,28 @@ 	-> IsSecure 	-> Maybe Auth 	-> Handler t-servePut st resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = do-	res <- withP2PConnection' apiver st cu su bypass sec auth WriteAction+servePut mst resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = do+	res <- withP2PConnection' apiver mst cu su bypass sec auth WriteAction 		(\cst -> cst { connectionWaitVar = False }) (liftIO . protoaction) 	servePutResult resultmangle res   where-	protoaction conn = servePutAction st conn k baf $ \_offset -> do+	protoaction conn = servePutAction conn k baf $ \_offset -> do 		net $ sendMessage DATA_PRESENT 		checkSuccessPlus-servePut st 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 = do 	validityv <- liftIO newEmptyTMVarIO 	let validitycheck = local $ runValidityCheck $ 		liftIO $ atomically $ readTMVar validityv 	tooshortv <- liftIO newEmptyTMVarIO 	content <- liftIO $ S.unSourceT stream (gather validityv tooshortv)-	res <- withP2PConnection' apiver st cu su bypass sec auth WriteAction-		(\cst -> cst { connectionWaitVar = False }) $ \conn -> do+	res <- withP2PConnection' apiver mst cu su bypass sec auth WriteAction+		(\cst -> cst { connectionWaitVar = False }) $ \(conn, st) -> do 			liftIO $ void $ async $ checktooshort conn tooshortv-			liftIO (protoaction conn content validitycheck)+			liftIO (protoaction conn st content validitycheck) 	servePutResult resultmangle res   where-	protoaction conn content validitycheck = -		servePutAction st conn k baf $ \offset' ->+	protoaction conn st content validitycheck = +		servePutAction (conn, st) k baf $ \offset' -> 			let offsetdelta = offset' - offset 			in case compare offset' offset of 				EQ -> sendContent' nullMeterUpdate (Len len)@@ -396,13 +396,12 @@ 			closeP2PConnection conn  servePutAction-	:: P2PHttpServerState-	-> P2PConnectionPair+	:: (P2PConnectionPair, PerRepoServerState) 	-> B64Key 	-> Maybe B64FilePath 	-> (P2P.Protocol.Offset -> Proto (Maybe [UUID])) 	-> IO (Either SomeException (Either ProtoFailure (Maybe [UUID])))-servePutAction st conn (B64Key k) baf a = inAnnexWorker st $+servePutAction (conn, st) (B64Key k) baf a = inAnnexWorker st $ 	enteringStage (TransferStage Download) $ 		runFullProto (clientRunState conn) (clientP2PConnection conn) $ 			put' k af a@@ -422,7 +421,7 @@  servePut' 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> (PutResultPlus -> t) 	-> B64UUID ServerSide 	-> v@@ -440,7 +439,7 @@  servePutOffset 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> (PutOffsetResultPlus -> t) 	-> B64UUID ServerSide 	-> v@@ -452,7 +451,7 @@ 	-> Handler t servePutOffset st resultmangle su apiver (B64Key k) cu bypass sec auth = do 	res <- withP2PConnection apiver st cu su bypass sec auth WriteAction-		(\cst -> cst { connectionWaitVar = False }) $ \conn ->+		(\cst -> cst { connectionWaitVar = False }) $ \(conn, _) -> 			liftIO $ proxyClientNetProto conn $ getPutOffset k af 	case res of 		Right offset -> return $ resultmangle $@@ -464,7 +463,7 @@  serveLockContent 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> B64UUID ServerSide 	-> v 	-> B64Key@@ -473,8 +472,8 @@ 	-> IsSecure 	-> Maybe Auth 	-> Handler LockResult-serveLockContent st su apiver (B64Key k) cu bypass sec auth = do-	conn <- getP2PConnection apiver st cu su bypass sec auth LockAction id+serveLockContent mst su apiver (B64Key k) cu bypass sec auth = do+	(conn, st) <- getP2PConnection apiver mst cu su bypass sec auth LockAction id 	let lock = do 		lockresv <- newEmptyTMVarIO 		unlockv <- newEmptyTMVarIO@@ -501,7 +500,7 @@  serveKeepLocked 	:: APIVersion v-	=> P2PHttpServerState+	=> TMVar P2PHttpServerState 	-> B64UUID ServerSide 	-> v 	-> LockID@@ -513,15 +512,15 @@ 	-> Maybe KeepAlive 	-> S.SourceT IO UnlockRequest 	-> Handler LockResult-serveKeepLocked st _su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do-	checkAuthActionClass st sec auth LockAction $ \_ -> do+serveKeepLocked mst su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do+	checkAuthActionClass mst su sec auth LockAction $ \st _ -> do 		liftIO $ keepingLocked lckid st-		_ <- liftIO $ S.unSourceT unlockrequeststream go+		_ <- liftIO $ S.unSourceT unlockrequeststream (go st) 		return (LockResult False Nothing)   where-	go S.Stop = dropLock lckid st-	go (S.Error _err) = dropLock lckid st-	go (S.Skip s)    = go s-	go (S.Effect ms) = ms >>= go-	go (S.Yield (UnlockRequest False) s) = go s-	go (S.Yield (UnlockRequest True) _) = dropLock lckid st+	go st S.Stop = dropLock lckid st+	go st (S.Error _err) = dropLock lckid st+	go st (S.Skip s)    = go st s+	go st (S.Effect ms) = ms >>= go st+	go st (S.Yield (UnlockRequest False) s) = go st s+	go st (S.Yield (UnlockRequest True) _) = dropLock lckid st
P2P/Http/State.hs view
@@ -26,6 +26,8 @@ import Types.WorkerPool import Annex.WorkerPool import Annex.BranchState+import Annex.Concurrent+import Types.Concurrency import Types.Cluster import CmdLine.Action (startConcurrency) import Utility.ThreadScheduler@@ -42,8 +44,37 @@ import qualified Data.Set as S import Control.Concurrent.Async import Data.Time.Clock.POSIX+import qualified Data.Semigroup as Sem+import Prelude  data P2PHttpServerState = P2PHttpServerState+	{ servedRepos :: M.Map UUID PerRepoServerState+	, serverShutdownCleanup :: IO ()+	, updateRepos :: UpdateRepos+	}++type UpdateRepos = P2PHttpServerState -> IO P2PHttpServerState++instance Monoid P2PHttpServerState where+	mempty = P2PHttpServerState+		{ servedRepos = mempty+		, serverShutdownCleanup = noop+		, updateRepos = const mempty+		}++instance Sem.Semigroup P2PHttpServerState where+	a <> b = P2PHttpServerState+		{ servedRepos = servedRepos a <> servedRepos b+		, serverShutdownCleanup = do+			serverShutdownCleanup a+			serverShutdownCleanup b+		, updateRepos = \st -> do+			a' <- updateRepos a st+			b' <- updateRepos b st+			return (a' <> b')+		}++data PerRepoServerState = PerRepoServerState 	{ acquireP2PConnection :: AcquireP2PConnection 	, annexWorkerPool :: AnnexWorkerPool 	, getServerMode :: GetServerMode@@ -62,8 +93,8 @@ 		} 	| CannotServeRequests -mkP2PHttpServerState :: AcquireP2PConnection -> AnnexWorkerPool -> GetServerMode -> IO P2PHttpServerState-mkP2PHttpServerState acquireconn annexworkerpool getservermode = P2PHttpServerState+mkPerRepoServerState :: AcquireP2PConnection -> AnnexWorkerPool -> GetServerMode -> IO PerRepoServerState+mkPerRepoServerState acquireconn annexworkerpool getservermode = PerRepoServerState 	<$> pure acquireconn 	<*> pure annexworkerpool 	<*> pure getservermode@@ -75,7 +106,7 @@ withP2PConnection 	:: APIVersion v 	=> v-	-> P2PHttpServerState+	-> TMVar P2PHttpServerState 	-> B64UUID ClientSide 	-> B64UUID ServerSide 	-> [B64UUID Bypass]@@ -83,10 +114,10 @@ 	-> Maybe Auth 	-> ActionClass 	-> (ConnectionParams -> ConnectionParams)-	-> (P2PConnectionPair -> Handler (Either ProtoFailure a))+	-> ((P2PConnectionPair, PerRepoServerState) -> Handler (Either ProtoFailure a)) 	-> Handler a-withP2PConnection apiver st cu su bypass sec auth actionclass fconnparams connaction =-	withP2PConnection' apiver st cu su bypass sec auth actionclass fconnparams connaction'+withP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams connaction =+	withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams connaction'   where 	connaction' conn = connaction conn >>= \case 		Right r -> return r@@ -96,7 +127,7 @@ withP2PConnection' 	:: APIVersion v 	=> v-	-> P2PHttpServerState+	-> TMVar P2PHttpServerState 	-> B64UUID ClientSide 	-> B64UUID ServerSide 	-> [B64UUID Bypass]@@ -104,17 +135,17 @@ 	-> Maybe Auth 	-> ActionClass 	-> (ConnectionParams -> ConnectionParams)-	-> (P2PConnectionPair -> Handler a)+	-> ((P2PConnectionPair, PerRepoServerState) -> Handler a) 	-> Handler a-withP2PConnection' apiver st cu su bypass sec auth actionclass fconnparams connaction = do-	conn <- getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams-	connaction conn+withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams connaction = do+	(conn, st) <- getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams+	connaction (conn, st) 		`finally` liftIO (releaseP2PConnection conn)  getP2PConnection 	:: APIVersion v 	=> v-	-> P2PHttpServerState+	-> TMVar P2PHttpServerState 	-> B64UUID ClientSide 	-> B64UUID ServerSide 	-> [B64UUID Bypass]@@ -122,16 +153,16 @@ 	-> Maybe Auth 	-> ActionClass 	-> (ConnectionParams -> ConnectionParams)-	-> Handler P2PConnectionPair-getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams =-	checkAuthActionClass st sec auth actionclass go+	-> Handler (P2PConnectionPair, PerRepoServerState)+getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams =+	checkAuthActionClass mst su sec auth actionclass go   where-	go servermode = liftIO (acquireP2PConnection st cp) >>= \case+	go st servermode = liftIO (acquireP2PConnection st cp) >>= \case 		Left (ConnectionFailed err) ->  			throwError err502 { errBody = encodeBL err } 		Left TooManyConnections -> 			throwError err503-		Right v -> return v+		Right v -> return (v, st) 	  where 		cp = fconnparams $ ConnectionParams 			{ connectionProtocolVersion = protocolVersion apiver@@ -142,30 +173,51 @@ 			, connectionWaitVar = True 			} +getPerRepoServerState :: TMVar P2PHttpServerState -> B64UUID ServerSide -> IO (Maybe PerRepoServerState)+getPerRepoServerState mstv su = do+	mst <- atomically $ readTMVar mstv+	case lookupst mst of+		Just st -> return (Just st)+		Nothing -> do+			mst' <- atomically $ takeTMVar mstv+			mst'' <- updateRepos mst' mst'+			debug "P2P.Http" $+				"Rescanned for repositories, now serving UUIDs: "+					++ show (M.keys (servedRepos mst''))+			atomically $ putTMVar mstv mst''+			return $ lookupst mst''+  where+	lookupst mst = M.lookup (fromB64UUID su) (servedRepos mst)+ checkAuthActionClass-	:: P2PHttpServerState+	:: TMVar P2PHttpServerState+	-> B64UUID ServerSide 	-> IsSecure 	-> Maybe Auth 	-> ActionClass-	-> (P2P.ServerMode -> Handler a)+	-> (PerRepoServerState -> P2P.ServerMode -> Handler a) 	-> Handler a-checkAuthActionClass st sec auth actionclass go =-	case (sm, actionclass) of+checkAuthActionClass mstv su sec auth actionclass go =+	liftIO (getPerRepoServerState mstv su) >>= \case+		Just st -> select st+		Nothing -> throwError err404+  where+	select st = case (sm, actionclass) of 		(ServerMode { serverMode = P2P.ServeReadWrite }, _) ->-			go P2P.ServeReadWrite+			go st P2P.ServeReadWrite 		(ServerMode { unauthenticatedLockingAllowed = True }, LockAction) ->-			go P2P.ServeReadOnly+			go st P2P.ServeReadOnly 		(ServerMode { serverMode = P2P.ServeAppendOnly }, RemoveAction) ->  			throwError $ forbiddenWithoutAuth sm 		(ServerMode { serverMode = P2P.ServeAppendOnly }, _) ->-			go P2P.ServeAppendOnly+			go st P2P.ServeAppendOnly 		(ServerMode { serverMode = P2P.ServeReadOnly }, ReadAction) ->-			go P2P.ServeReadOnly+			go st P2P.ServeReadOnly 		(ServerMode { serverMode = P2P.ServeReadOnly }, _) ->  			throwError $ forbiddenWithoutAuth sm 		(CannotServeRequests, _) -> throwError basicAuthRequired-  where-	sm = getServerMode st sec auth+	  where+		sm = getServerMode st sec auth  forbiddenAction :: ServerError forbiddenAction = err403@@ -204,13 +256,14 @@ 	= ConnectionParams 	-> IO (Either ConnectionProblem P2PConnectionPair) -withP2PConnections-	:: AnnexWorkerPool+mkP2PHttpServerState+	:: GetServerMode+	-> UpdateRepos 	-> ProxyConnectionPoolSize 	-> ClusterConcurrency-	-> (AcquireP2PConnection -> Annex a)-	-> Annex a-withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do+	-> AnnexWorkerPool+	-> Annex P2PHttpServerState+mkP2PHttpServerState getservermode updaterepos proxyconnectionpoolsize clusterconcurrency workerpool = do 	enableInteractiveBranchAccess 	myuuid <- getUUID 	myproxies <- M.lookup myuuid <$> getProxies@@ -223,7 +276,13 @@ 	let endit = do 		liftIO $ atomically $ putTMVar endv () 		liftIO $ wait asyncservicer-	a (acquireconn reqv) `finally` endit+	let servinguuids = myuuid : map proxyRemoteUUID (maybe [] S.toList myproxies)+	st <- liftIO $ mkPerRepoServerState (acquireconn reqv) workerpool getservermode+	return $ P2PHttpServerState+		{ servedRepos = M.fromList $ zip servinguuids (repeat st)+		, serverShutdownCleanup = endit+		, updateRepos = updaterepos+		}   where 	acquireconn reqv connparams = do 		respvar <- newEmptyTMVarIO@@ -487,13 +546,13 @@ 			wait locktid 			return Nothing -storeLock :: LockID -> Locker -> P2PHttpServerState -> IO ()+storeLock :: LockID -> Locker -> PerRepoServerState -> IO () storeLock lckid locker st = atomically $ do 	m <- takeTMVar (openLocks st) 	let !m' = M.insert lckid locker m 	putTMVar (openLocks st) m' -keepingLocked :: LockID -> P2PHttpServerState -> IO ()+keepingLocked :: LockID -> PerRepoServerState -> IO () keepingLocked lckid st = do 	m <- atomically $ readTMVar (openLocks st) 	case M.lookup lckid m of@@ -502,7 +561,7 @@ 			atomically $ void $  				tryPutTMVar (lockerTimeoutDisable locker) () -dropLock :: LockID -> P2PHttpServerState -> IO ()+dropLock :: LockID -> PerRepoServerState -> IO () dropLock lckid st = do 	v <- atomically $ do 		m <- takeTMVar (openLocks st)@@ -520,13 +579,15 @@ 		Nothing -> return () 		Just locker -> wait (lockerThread locker) -getAnnexWorkerPool :: (AnnexWorkerPool -> Annex a) -> Annex a-getAnnexWorkerPool a = startConcurrency transferStages $-	Annex.getState Annex.workers >>= \case-		Nothing -> giveup "Use -Jn or set annex.jobs to configure the number of worker threads."-		Just wp -> a wp+withAnnexWorkerPool :: (Maybe Concurrency) -> (AnnexWorkerPool -> Annex a) -> Annex a+withAnnexWorkerPool mc a = do+	maybe noop (setConcurrency . ConcurrencyCmdLine) mc+	startConcurrency transferStages $+		Annex.getState Annex.workers >>= \case+			Nothing -> giveup "Use -Jn or set annex.jobs to configure the number of worker threads."+			Just wp -> a wp -inAnnexWorker :: P2PHttpServerState -> Annex a -> IO (Either SomeException a)+inAnnexWorker :: PerRepoServerState -> Annex a -> IO (Either SomeException a) inAnnexWorker st = inAnnexWorker' (annexWorkerPool st)  inAnnexWorker' :: AnnexWorkerPool -> Annex a -> IO (Either SomeException a)
P2P/Http/Url.hs view
@@ -15,6 +15,9 @@ import System.FilePath.Posix as P import Servant.Client (BaseUrl(..), Scheme(..)) import Text.Read+import Data.Char+import qualified Git+import qualified Git.Url #endif  defaultP2PHttpProtocolPort :: Int@@ -78,4 +81,16 @@ unavailableP2PHttpUrl p = p #ifdef WITH_SERVANT 	{ p2pHttpBaseUrl = (p2pHttpBaseUrl p) { baseUrlHost = "!dne!" } }+#endif++#ifdef WITH_SERVANT+-- When a p2phttp url is on the same host as a git repo, which also uses+-- http, the same username+password is assumed to be used for both.+isP2PHttpSameHost :: P2PHttpUrl -> Git.Repo -> Bool+isP2PHttpSameHost u repo+	| not (Git.repoIsHttp repo) = False+	| otherwise = +		Just (map toLower $ baseUrlHost (p2pHttpBaseUrl u)) +			==+		(map toLower <$> (Git.Url.host repo)) #endif
Remote/S3.hs view
@@ -1,6 +1,6 @@ {- S3 remotes  -- - Copyright 2011-2023 Joey Hess <id@joeyh.name>+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -27,6 +27,8 @@ import qualified System.FilePath.Posix as Posix import Data.Char import Data.String+import Data.Maybe+import Data.Time.Clock import Network.Socket (HostName) import Network.HTTP.Conduit (Manager) import Network.HTTP.Client (responseStatus, responseBody, RequestBody(..))@@ -36,7 +38,6 @@ import Control.Monad.Catch import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar-import Data.Maybe  import Annex.Common import Types.Remote@@ -63,8 +64,8 @@ import Utility.DataUnits import Annex.Content import qualified Annex.Url as Url-import Utility.Url (extractFromResourceT)-import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..))+import Utility.Url (extractFromResourceT, UserAgent)+import Annex.Url (getUserAgent, getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env import Annex.Verify @@ -581,7 +582,7 @@ 		| versioning info = do 			rsp <- sendS3Handle h $  				S3.getBucketObjectVersions (bucket info)-			continuelistversioned h [] rsp+			continuelistversioned Nothing h [] rsp 		| otherwise = do 			rsp <- sendS3Handle h $  				(S3.getBucket (bucket info))@@ -589,17 +590,31 @@ 			continuelistunversioned h [] rsp  	continuelistunversioned h l rsp-		| S3.gbrIsTruncated rsp = do-			rsp' <- sendS3Handle h $-				(S3.getBucket (bucket info))-					{ S3.gbMarker = S3.gbrNextMarker rsp-					, S3.gbPrefix = fileprefix-					}-			continuelistunversioned h (rsp:l) rsp'-		| otherwise = return $-			mkImportableContentsUnversioned info (reverse (rsp:l))-	-	continuelistversioned h l rsp+		| S3.gbrIsTruncated rsp =+			let marker = +				S3.gbrNextMarker rsp+					<|>+				(S3.objectKey <$> lastMaybe (S3.gbrContents rsp))+			in case marker of+				Just _ -> do+					rsp' <- sendS3Handle h $+						(S3.getBucket (bucket info))+							{ S3.gbMarker = marker+							, S3.gbPrefix = fileprefix+							}+					l' <- extractFromResourceT $+						extractunversioned rsp+					continuelistunversioned h (l':l) rsp'+				Nothing -> nomore+		| otherwise = nomore+	  where+		nomore = do+			l' <- extractFromResourceT $+				extractunversioned rsp+			return $ mkImportableContentsUnversioned+				(reverse (l':l))++	continuelistversioned reuse h l rsp 		| S3.gbovrIsTruncated rsp = do 			rsp' <- sendS3Handle h $ 				(S3.getBucketObjectVersions (bucket info))@@ -607,65 +622,84 @@ 					, S3.gbovVersionIdMarker = S3.gbovrNextVersionIdMarker rsp 					, S3.gbovPrefix = fileprefix 					}-			continuelistversioned h (rsp:l) rsp'-		| otherwise = return $-			mkImportableContentsVersioned info (reverse (rsp:l))+			(l', reuse') <- extractFromResourceT $+				extractversioned reuse rsp+			continuelistversioned reuse' h (l':l) rsp'+		| otherwise = do+			(l', _) <- extractFromResourceT $+				extractversioned reuse rsp+			return $ mkImportableContentsVersioned+				(reverse (l':l)) -mkImportableContentsUnversioned :: S3Info -> [S3.GetBucketResponse] -> ImportableContents (ContentIdentifier, ByteSize)-mkImportableContentsUnversioned info l = ImportableContents -	{ importableContents = concatMap (mapMaybe extract . S3.gbrContents) l+	extractunversioned = mapMaybe extractunversioned' . S3.gbrContents+	extractunversioned' oi = do+                  loc <- bucketImportLocation info $+                          T.unpack $ S3.objectKey oi+                  let sz  = S3.objectSize oi+                  let cid = mkS3UnversionedContentIdentifier $ S3.objectETag oi+                  return (loc, (cid, sz))+	+	extractversioned reuse = extractversioned' reuse . S3.gbovrContents+	extractversioned' reuse [] = ([], reuse)+	extractversioned' reuse (x:xs) = case extractversioned'' reuse x of+		Just (v, reuse') -> +			let (l, reuse'') = extractversioned' reuse' xs+			in (v:l, reuse'')+		Nothing -> extractversioned' reuse xs+	extractversioned'' reuse ovi@(S3.ObjectVersion {}) = do+		loc <- bucketImportLocation info $+			T.unpack $ S3.oviKey ovi+		-- Avoid storing the same filename in memory repeatedly.+		let loc' = case reuse of+			Just reuseloc | reuseloc == loc -> reuseloc+			_ -> loc+		let sz  = S3.oviSize ovi+		let cid = mkS3VersionedContentIdentifier' ovi+		return (((loc', (cid, sz)), S3.oviLastModified ovi), Just loc')+	extractversioned'' _ (S3.DeleteMarker {}) = Nothing++mkImportableContentsUnversioned :: [[(ImportLocation, (ContentIdentifier, ByteSize))]] -> ImportableContents (ContentIdentifier, ByteSize)+mkImportableContentsUnversioned l = ImportableContents +	{ importableContents = concat l 	, importableHistory = [] 	}-  where-	extract oi = do-		loc <- bucketImportLocation info $-			T.unpack $ S3.objectKey oi-		let sz  = S3.objectSize oi-		let cid = mkS3UnversionedContentIdentifier $ S3.objectETag oi-		return (loc, (cid, sz)) -mkImportableContentsVersioned :: S3Info -> [S3.GetBucketObjectVersionsResponse] -> ImportableContents (ContentIdentifier, ByteSize)-mkImportableContentsVersioned info = build . groupfiles+mkImportableContentsVersioned :: [[((ImportLocation, (ContentIdentifier, ByteSize)), UTCTime)]] -> ImportableContents (ContentIdentifier, ByteSize)+mkImportableContentsVersioned = build . groupfiles   where+	ovilastmodified = snd+	loc = fst . fst+ 	build [] = ImportableContents [] [] 	build l = 		let (l', v) = latestversion l 		in ImportableContents-			{ importableContents = mapMaybe extract v+			{ importableContents = map fst v 			, importableHistory = case build l' of 				ImportableContents [] [] -> [] 				h -> [h] 			}-  	-	extract ovi@(S3.ObjectVersion {}) = do-		loc <- bucketImportLocation info $-			T.unpack $ S3.oviKey ovi-		let sz  = S3.oviSize ovi-		let cid = mkS3VersionedContentIdentifier' ovi-		return (loc, (cid, sz))-	extract (S3.DeleteMarker {}) = Nothing 	 	-- group files so all versions of a file are in a sublist, 	-- with the newest first. S3 uses such an order, so it's just a 	-- matter of breaking up the response list into sublists.-	groupfiles = groupBy (\a b -> S3.oviKey a == S3.oviKey b) -		. concatMap S3.gbovrContents+	groupfiles = groupBy (\a b -> loc a == loc b) . concat  	latestversion [] = ([], []) 	latestversion ([]:rest) = latestversion rest 	latestversion l@((first:_old):remainder) =-		go (S3.oviLastModified first) [first] remainder+		go (ovilastmodified first) [first] remainder 	  where 		go mtime c [] = (removemostrecent mtime l, reverse c) 		go mtime c ([]:rest) = go mtime c rest 		go mtime c ((latest:_old):rest) = -			let !mtime' = max mtime (S3.oviLastModified latest)+			let !mtime' = max mtime (ovilastmodified latest) 			in go mtime' (latest:c) rest 	 	removemostrecent _ [] = [] 	removemostrecent mtime ([]:rest) = removemostrecent mtime rest 	removemostrecent mtime (i@(curr:old):rest)-		| S3.oviLastModified curr == mtime =+		| ovilastmodified curr == mtime = 			old : removemostrecent mtime rest 		| otherwise = 			i : removemostrecent mtime rest@@ -885,10 +919,11 @@ 				Just creds -> go =<< liftIO (genCredentials creds) 				Nothing -> return (Left S3HandleNeedCreds)   where-	s3cfg = s3Configuration c 	go awscreds = do-		let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing 		ou <- getUrlOptions+		ua <- getUserAgent+		let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing+		let s3cfg = s3Configuration (Just ua) c 		return $ Right $ S3Handle (httpManager ou) awscfg s3cfg  withS3Handle :: S3HandleVar -> (Either S3HandleProblem S3Handle -> Annex a) -> Annex a@@ -907,13 +942,20 @@ needS3Creds :: UUID -> String needS3Creds u = missingCredPairFor "S3" (AWS.creds u) -s3Configuration :: ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery-s3Configuration c = cfg+s3Configuration :: Maybe UserAgent -> ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery+#if MIN_VERSION_aws(0,24,3)+s3Configuration ua c = cfg+#else+s3Configuration _ua c = cfg+#endif 	{ S3.s3Port = port 	, S3.s3RequestStyle = case getRemoteConfigValue requeststyleField c of 		Just "path" -> S3.PathStyle 		Just s -> giveup $ "bad S3 requeststyle value: " ++ s 		Nothing -> S3.s3RequestStyle cfg+#if MIN_VERSION_aws(0,24,3)+	, S3.s3UserAgent = T.pack <$> ua+#endif 	}   where 	h = fromJust $ getRemoteConfigValue hostField c@@ -1157,7 +1199,7 @@ 	, Just ("versioning", if versioning info then "yes" else "no") 	]   where-	s3c = s3Configuration c+	s3c = s3Configuration Nothing c 	showstorageclass (S3.OtherStorageClass t) = T.unpack t 	showstorageclass sc = show sc @@ -1341,11 +1383,24 @@   where 	enableversioning b = do #if MIN_VERSION_aws(0,21,1)-		showAction "enabling bucket versioning"+		showAction "checking bucket versioning" 		hdl <- mkS3HandleVar c gc u+		let setversioning = S3.putBucketVersioning b S3.VersioningEnabled 		withS3HandleOrFail u hdl $ \h ->-			void $ liftIO $ runResourceT $ sendS3Handle h $-				S3.putBucketVersioning b S3.VersioningEnabled+#if MIN_VERSION_aws(0,24,3)+			liftIO $ runResourceT $+				tryS3 (sendS3Handle h setversioning) >>= \case+					Right _ -> return ()+					Left err -> do+						res <- sendS3Handle h $+							S3.getBucketVersioning b+						case S3.gbvVersioning res of+							Just S3.VersioningEnabled -> return ()+							_ -> giveup $ "This bucket does not have versioning enabled, and enabling it failed: "+								++ T.unpack (S3.s3ErrorMessage err)+#else+			void $ liftIO $ runResourceT $ sendS3Handle h setversioning+#endif #else 		showLongNote $ unlines 			[ "This version of git-annex cannot auto-enable S3 bucket versioning."
Test.hs view
@@ -1,6 +1,6 @@ {- git-annex test suite  -- - Copyright 2010-2023 Joey Hess <id@joeyh.name>+ - Copyright 2010-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -37,6 +37,7 @@ import qualified Git.Ref import qualified Git.LsTree import qualified Git.FilePath+import qualified Git.Bundle import qualified Annex.Locations #ifndef mingw32_HOST_OS import qualified Types.GitConfig@@ -282,6 +283,8 @@ 	[ testCase "add dup" test_add_dup 	, testCase "add extras" test_add_extras 	, testCase "add moved link" test_add_moved+	, testCase "git-remote-annex" (test_git_remote_annex False)+	, testCase "git-remote-annex exporttree" (test_git_remote_annex True) 	, testCase "readonly remote" test_readonly_remote 	, testCase "ignore deleted files" test_ignore_deleted_files 	, testCase "metadata" test_metadata@@ -421,6 +424,39 @@ 	annexed_present wormannexedfile 	checkbackend wormannexedfile backendWORM +test_git_remote_annex :: Bool -> Assertion+#ifndef mingw32_HOST_OS+test_git_remote_annex exporttree+	| exporttree = +		runtest ["importtree=yes", "exporttree=yes"] $+			git_annex "export" ["master", "--to=foo"] "export"+	| otherwise = +		runtest [] $ +			git_annex "copy" ["--to=foo"] "copy"+  where+	runtest cfg populate = whenM Git.Bundle.versionSupported $ +		intmpclonerepo $ do+			let cfg' = ["type=directory", "encryption=none", "directory=dir"] ++ cfg+			createDirectory "dir"+			git_annex "initremote" ("foo":("uuid=" ++ diruuid):cfg') "initremote"+			git_annex "get" [] "get failed"+			() <- populate+			git "config" ["remote.foo.url", "annex::"] "git config"+			-- git push does not always propagate nonzero exit+			-- status from git-remote-annex, so remember the+			-- transcript and display it if clone fails+			pushtranscript <- testProcess' "git" ["push", "foo", "master", "git-annex"] Nothing (== True) (const True) "git push"+			git "clone" ["annex::"++diruuid++"?"++intercalate "&" cfg', "clonedir"]+				("git clone from special remote (after git push with output: " ++ pushtranscript ++ ")")+			inpath "clonedir" $+				git_annex "get" [annexedfile] "get from origin special remote"+	diruuid="89ddefa4-a04c-11ef-87b5-e880882a4f98"+#else+test_git_remote_annex exporttree =+	-- git-remote-annex is not currently installed on Windows+	return ()+#endif+ test_add_moved :: Assertion test_add_moved = intmpclonerepo $ do 	git_annex "get" [annexedfile] "get failed"@@ -440,10 +476,10 @@ 	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do 			pair r1 r2-			indir r1 $ do+			intopdir r1 $ do 				git_annex "get" [annexedfile] "get failed in first repo" 			make_readonly r1-			indir r2 $ do+			intopdir r2 $ do 				git_annex "sync" ["r1", "--no-push", "--no-content"] "sync with readonly repo" 				git_annex "get" [annexedfile, "--from", "r1"] "get from readonly repo" 				git "remote" ["rm", "origin"] "remote rm"@@ -1234,7 +1270,7 @@ 	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> 			withtmpclonerepo $ \r3 -> do-				forM_ [r1, r2, r3] $ \r -> indir r $ do+				forM_ [r1, r2, r3] $ \r -> intopdir r $ do 					when (r /= r1) $ 						git "remote" ["add", "r1", "../" ++ r1] "remote add" 					when (r /= r2) $@@ -1243,11 +1279,11 @@ 						git "remote" ["add", "r3", "../" ++ r3] "remote add" 					git_annex "get" [annexedfile] "get" 					git "remote" ["rm", "origin"] "remote rm"-				forM_ [r3, r2, r1] $ \r -> indir r $+				forM_ [r3, r2, r1] $ \r -> intopdir r $ 					git_annex "sync" ["--no-content"] ("sync in " ++ r)-				forM_ [r3, r2] $ \r -> indir r $+				forM_ [r3, r2] $ \r -> intopdir r $ 					git_annex "drop" ["--force", annexedfile] ("drop in " ++ r)-				indir r1 $ do+				intopdir r1 $ do 					git_annex "sync" ["--no-content"] "sync in r1" 					git_annex_expectoutput "find" ["--in", "r3"] [] 					{- This was the bug. The sync@@ -1261,19 +1297,19 @@ test_conflict_resolution_movein_regression = withtmpclonerepo $ \r1 ->  	withtmpclonerepo $ \r2 -> do 		let rname r = if r == r1 then "r1" else "r2"-		forM_ [r1, r2] $ \r -> indir r $ do+		forM_ [r1, r2] $ \r -> intopdir r $ do 			{- Get all files, see check below. -} 			git_annex "get" [] "get" 			disconnectOrigin 		pair r1 r2-		forM_ [r1, r2] $ \r -> indir r $ do+		forM_ [r1, r2] $ \r -> intopdir r $ do 			{- Set up a conflict. -} 			let newcontent = content annexedfile ++ rname r 			git_annex "unlock" [annexedfile] "unlock" 			writecontent annexedfile newcontent 		{- Sync twice in r1 so it gets the conflict resolution 		 - update from r2 -}-		forM_ [r1, r2, r1] $ \r -> indir r $+		forM_ [r1, r2, r1] $ \r -> intopdir r $ 			git_annex "sync" ["--force", "--no-content"] ("sync in " ++ rname r) 		{- After the sync, it should be possible to get all 		 - files. This includes both sides of the conflict,@@ -1281,7 +1317,7 @@ 		 - 		 - The bug caused one repo to be missing the content 		 - of the file that had been put in it. -}-		forM_ [r1, r2] $ \r -> indir r $ do+		forM_ [r1, r2] $ \r -> intopdir r $ do 			git_annex "get" [] ("get all files after merge conflict resolution in " ++ rname r)  {- Simple case of conflict resolution; 2 different versions of annexed@@ -1290,18 +1326,18 @@ test_conflict_resolution =  	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do-			indir r1 $ do+			intopdir r1 $ do 				disconnectOrigin 				writecontent conflictor "conflictor1" 				add_annex conflictor "add conflicter" 				git_annex "sync" ["--no-content"] "sync in r1"-			indir r2 $ do+			intopdir r2 $ do 				disconnectOrigin 				writecontent conflictor "conflictor2" 				add_annex conflictor "add conflicter" 				git_annex "sync" ["--no-content"] "sync in r2" 			pair r1 r2-			forM_ [r1,r2,r1] $ \r -> indir r $+			forM_ [r1,r2,r1] $ \r -> intopdir r $ 				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2@@ -1314,7 +1350,7 @@ 		length v == 2 			@? (what ++ " not exactly 2 variant files in: " ++ show l) 		conflictor `notElem` l @? ("conflictor still present after conflict resolution")-		indir d $ do+		intopdir d $ do 			git_annex "get" v "get" 			git_annex_expectoutput "find" v v @@ -1323,12 +1359,12 @@ test_conflict_resolution_adjusted_branch = 	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> whenM (adjustedbranchsupported r2) $ do-			indir r1 $ do+			intopdir r1 $ do 				disconnectOrigin 				writecontent conflictor "conflictor1" 				add_annex conflictor "add conflicter" 				git_annex "sync" ["--no-content"] "sync in r1"-			indir r2 $ do+			intopdir r2 $ do 				disconnectOrigin 				writecontent conflictor "conflictor2" 				add_annex conflictor "add conflicter"@@ -1338,7 +1374,7 @@ 				-- filesystem. So, --force it. 				git_annex "adjust" ["--unlock", "--force"] "adjust" 			pair r1 r2-			forM_ [r1,r2,r1] $ \r -> indir r $+			forM_ [r1,r2,r1] $ \r -> intopdir r $ 				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2@@ -1351,7 +1387,7 @@ 		length v == 2 			@? (what ++ " not exactly 2 variant files in: " ++ show l) 		conflictor `notElem` l @? ("conflictor still present after conflict resolution")-		indir d $ do+		intopdir d $ do 			git_annex "get" v "get" 			git_annex_expectoutput "find" v v @@ -1364,12 +1400,12 @@   where 	check inr1 = withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do-			indir r1 $ do+			intopdir r1 $ do 				disconnectOrigin 				writecontent conflictor "conflictor" 				add_annex conflictor "add conflicter" 				git_annex "sync" ["--no-content"] "sync in r1"-			indir r2 $ do+			intopdir r2 $ do 				disconnectOrigin 				createDirectory conflictor 				writecontent subfile "subfile"@@ -1377,7 +1413,7 @@ 				git_annex "sync" ["--no-content"] "sync in r2" 			pair r1 r2 			let l = if inr1 then [r1, r2] else [r2, r1]-			forM_ l $ \r -> indir r $+			forM_ l $ \r -> intopdir r $ 				git_annex "sync" ["--no-content"] "sync in mixed conflict" 			checkmerge "r1" r1 			checkmerge "r2" r2@@ -1392,7 +1428,7 @@ 			@? (what ++ " conflictor variant file missing in: " ++ show l ) 		length v == 1 			@? (what ++ " too many variant files in: " ++ show v)-		indir d $ do+		intopdir d $ do 			git_annex "get" (conflictor:v) ("get  in " ++ what) 			git_annex_expectoutput "find" [conflictor] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath subfile))] 			git_annex_expectoutput "find" v v@@ -1406,23 +1442,23 @@   where 	check inr1 = withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do-			indir r1 $ do+			intopdir r1 $ do 				disconnectOrigin 				writecontent conflictor "conflictor" 				add_annex conflictor "add conflicter" 				git_annex "sync" ["--no-content"] "sync in r1"-			indir r2 $+			intopdir r2 $ 				disconnectOrigin 			pair r1 r2-			indir r2 $ do+			intopdir r2 $ do 				git_annex "sync" ["--no-content"] "sync in r2" 				git_annex "get" [conflictor] "get conflictor" 				git_annex "unlock" [conflictor] "unlock conflictor" 				writecontent conflictor "newconflictor"-			indir r1 $+			intopdir r1 $ 				removeWhenExistsWith R.removeLink (toRawFilePath conflictor) 			let l = if inr1 then [r1, r2, r1] else [r2, r1, r2]-			forM_ l $ \r -> indir r $+			forM_ l $ \r -> intopdir r $ 				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2@@ -1446,12 +1482,12 @@   where 	check inr1 = withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do-			indir r1 $ do+			intopdir r1 $ do 				disconnectOrigin 				writecontent conflictor "conflictor" 				add_annex conflictor "add conflicter" 				git_annex "sync" ["--no-content"] "sync in r1"-			indir r2 $ do+			intopdir r2 $ do 				disconnectOrigin 				writecontent conflictor nonannexed_content 				git "config"@@ -1462,7 +1498,7 @@ 				git_annex "sync" ["--no-content"] "sync in r2" 			pair r1 r2 			let l = if inr1 then [r1, r2] else [r2, r1]-			forM_ l $ \r -> indir r $+			forM_ l $ \r -> intopdir r $ 				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2@@ -1496,19 +1532,19 @@ 	check inr1 = withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> 			whenM (checkRepo (Types.coreSymlinks <$> Annex.getGitConfig) r1) $ do-				indir r1 $ do+				intopdir r1 $ do 					disconnectOrigin 					writecontent conflictor "conflictor" 					add_annex conflictor "add conflicter" 					git_annex "sync" ["--no-content"] "sync in r1"-				indir r2 $ do+				intopdir r2 $ do 					disconnectOrigin 					R.createSymbolicLink (toRawFilePath symlinktarget) (toRawFilePath "conflictor") 					git "add" [conflictor] "git add conflictor" 					git_annex "sync" ["--no-content"] "sync in r2" 				pair r1 r2 				let l = if inr1 then [r1, r2] else [r2, r1]-				forM_ l $ \r -> indir r $+				forM_ l $ \r -> intopdir r $ 					git_annex "sync" ["--no-content"] "sync" 				checkmerge "r1" r1 				checkmerge "r2" r2@@ -1543,19 +1579,19 @@   where 	check remoteconflictor = withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do-			indir r1 $ do+			intopdir r1 $ do 				disconnectOrigin 				createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor))) 				writecontent remoteconflictor annexedcontent 				add_annex conflictor "add remoteconflicter" 				git_annex "sync" ["--no-content"] "sync in r1"-			indir r2 $ do+			intopdir r2 $ do 				disconnectOrigin 				writecontent conflictor localcontent 			pair r1 r2 			-- this case is intentionally not handled 			-- since the user can recover on their own easily-			indir r2 $ git_annex_shouldfail "sync" ["--no-content"] "sync should not succeed"+			intopdir r2 $ git_annex_shouldfail "sync" ["--no-content"] "sync should not succeed" 	conflictor = "conflictor" 	localcontent = "local" 	annexedcontent = "annexed"@@ -1568,18 +1604,18 @@ 	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> 			withtmpclonerepo $ \r3 -> do-				indir r1 $ do+				intopdir r1 $ do 					writecontent conflictor "conflictor" 					git_annex "add" [conflictor] "add conflicter" 					git_annex "sync" ["--no-content"] "sync in r1" 					check_is_link conflictor "r1"-				indir r2 $ do+				intopdir r2 $ do 					createDirectory conflictor 					writecontent (conflictor </> "subfile") "subfile" 					git_annex "add" [conflictor] "add conflicter" 					git_annex "sync" ["--no-content"] "sync in r2" 					check_is_link (conflictor </> "subfile") "r2"-				indir r3 $ do+				intopdir r3 $ do 					writecontent conflictor "conflictor" 					git_annex "add" [conflictor] "add conflicter" 					git_annex "sync" ["--no-content"] "sync in r1"@@ -1599,26 +1635,26 @@ test_mixed_lock_conflict_resolution =  	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do-			indir r1 $ do+			intopdir r1 $ do 				disconnectOrigin 				writecontent conflictor "conflictor" 				git_annex "add" [conflictor] "add conflicter" 				git_annex "sync" ["--no-content"] "sync in r1"-			indir r2 $ do+			intopdir r2 $ do 				disconnectOrigin 				writecontent conflictor "conflictor" 				git_annex "add" [conflictor] "add conflicter" 				git_annex "unlock" [conflictor] "unlock conflicter" 				git_annex "sync" ["--no-content"] "sync in r2" 			pair r1 r2-			forM_ [r1,r2,r1] $ \r -> indir r $+			forM_ [r1,r2,r1] $ \r -> intopdir r $ 				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2   where 	conflictor = "conflictor" 	variantprefix = conflictor ++ ".variant"-	checkmerge what d = indir d $ do+	checkmerge what d = intopdir d $ do 		l <- getDirectoryContents "." 		let v = filter (variantprefix `isPrefixOf`) l 		length v == 0@@ -1643,14 +1679,14 @@ 			checkmerge "r2" r2   where 	conflictor = "conflictor"-	setup r = indir r $ whensupported $ do+	setup r = intopdir r $ whensupported $ do 		disconnectOrigin 		git_annex "upgrade" [] "upgrade" 		git_annex "adjust" ["--unlock", "--force"] "adjust" 		writecontent conflictor "conflictor" 		git_annex "add" [conflictor] "add conflicter" 		git_annex "sync" ["--no-content"] "sync"-	checkmerge what d = indir d $ whensupported $ do+	checkmerge what d = intopdir d $ whensupported $ do 		git_annex "sync" ["--no-content"] ("sync should not work in " ++ what) 		l <- getDirectoryContents "." 		conflictor `elem` l@@ -1664,7 +1700,7 @@ test_adjusted_branch_subtree_regression :: Assertion test_adjusted_branch_subtree_regression =  	withtmpclonerepo $ \r -> whenM (adjustedbranchsupported r) $ do-		indir r $ do+		intopdir r $ do 			disconnectOrigin 			origbranch <- annexeval origBranch 			git_annex "upgrade" [] "upgrade"@@ -2086,31 +2122,31 @@ 	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do 			pair r1 r2-			indir r1 $ do+			intopdir r1 $ do 				disconnectOrigin 				writecontent wormannexedfile $ content wormannexedfile 				git_annex "add" [wormannexedfile, "--backend=WORM"] "add" 				git_annex "sync" ["--no-content"] "sync"-			indir r2 $ do+			intopdir r2 $ do 				disconnectOrigin 				git_annex "sync" ["--no-content"] "sync"-			indir r1 $ do+			intopdir r1 $ do 				git_annex "sync" ["--no-content"] "sync"-			indir r2 $ do+			intopdir r2 $ do 				git_annex "get" [wormannexedfile] "get" 				git_annex "drop" [wormannexedfile] "drop" 				git_annex "get" [wormannexedfile] "get" 				git_annex "drop" [wormannexedfile] "drop"-			indir r1 $ do+			intopdir r1 $ do 				git_annex "drop" ["--force", wormannexedfile] "drop" 				git_annex "sync" ["--no-content"] "sync" 				git_annex "forget" ["--force"] "forget" 				git_annex "sync" ["--no-content"] "sync" 				emptylog-			indir r2 $ do+			intopdir r2 $ do 				git_annex "sync" ["--no-content"] "sync" 				emptylog-			indir r1 $ do+			intopdir r1 $ do 				git_annex "sync" ["--no-content"] "sync" 				emptylog   where
Test/Framework.hs view
@@ -73,7 +73,11 @@ -- In debug mode, the output is allowed to pass through. -- So the output does not get checked in debug mode. testProcess :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> (String -> Bool) -> String -> Assertion-testProcess command params environ expectedret expectedtranscript faildesc = do+testProcess command params environ expectedret expectedtranscript faildesc =+	void $ testProcess' command params environ expectedret expectedtranscript faildesc++testProcess' :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> (String -> Bool) -> String -> IO String+testProcess' command params environ expectedret expectedtranscript faildesc = do 	let p = (proc command params) { env = environ } 	debug <- testDebug . testOptions <$> getTestMode 	if debug@@ -81,10 +85,12 @@ 			ret <- withCreateProcess p $ \_ _ _ pid -> 				waitForProcess pid 			(expectedret (ret == ExitSuccess)) @? (faildesc ++ " failed with unexpected exit code")+			return "" 		else do 			(transcript, ret) <- Utility.Process.Transcript.processTranscript' p Nothing 			(expectedret ret) @? (faildesc ++ " failed with unexpected exit code (transcript follows)\n" ++ transcript) 			(expectedtranscript transcript) @? (faildesc ++ " failed with unexpected output (transcript follows)\n" ++ transcript)+			return transcript  -- Run git. (Do not use to run git-annex as the one being tested -- may not be in path.)@@ -140,12 +146,12 @@ 		a `finally` Annex.Action.stopCoProcesses  innewrepo :: IO () -> IO ()-innewrepo a = withgitrepo $ \r -> indir r a+innewrepo a = withgitrepo $ \r -> intopdir r a  inmainrepo :: IO a -> IO a inmainrepo a = do 	d <- mainrepodir-	indir d a+	intopdir d a  with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do@@ -160,7 +166,7 @@ 	config = "remote.origin.url"  intmpclonerepo :: Assertion -> Assertion-intmpclonerepo a = withtmpclonerepo $ \r -> indir r a+intmpclonerepo a = withtmpclonerepo $ \r -> intopdir r a  checkRepo :: Types.Annex a -> FilePath -> IO a checkRepo getval d = do@@ -170,11 +176,11 @@  intmpbareclonerepo :: Assertion -> Assertion intmpbareclonerepo a = withtmpclonerepo' (newCloneRepoConfig { bareClone = True } ) $-	\r -> indir r a+	\r -> intopdir r a  intmpsharedclonerepo :: Assertion -> Assertion intmpsharedclonerepo a = withtmpclonerepo' (newCloneRepoConfig { sharedClone = True } ) $-	\r -> indir r a+	\r -> intopdir r a  withtmpclonerepo :: (FilePath -> Assertion) -> Assertion withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig@@ -200,14 +206,19 @@ 	maindir <- mainrepodir 	bracket (setuprepo maindir) return a -indir :: FilePath -> IO a -> IO a-indir dir a = do+intopdir :: FilePath -> IO a -> IO a+intopdir dir a = do+	topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")+	inpath (topdir ++ "/" ++ dir) a++inpath :: FilePath -> IO a -> IO a+inpath path a = do 	currdir <- getCurrentDirectory 	-- Assertion failures throw non-IO errors; catch 	-- any type of error and change back to currdir before 	-- rethrowing. 	r <- bracket_-		(changeToTopDir dir)+		(setCurrentDirectory path) 		(setCurrentDirectory currdir) 		(tryNonAsync a) 	case r of@@ -215,7 +226,7 @@ 		Left e -> throwM e  adjustedbranchsupported :: FilePath -> IO Bool-adjustedbranchsupported repo = indir repo $ Annex.AdjustedBranch.isGitVersionSupported+adjustedbranchsupported repo = intopdir repo $ Annex.AdjustedBranch.isGitVersionSupported  setuprepo :: FilePath -> IO FilePath setuprepo dir = do@@ -248,7 +259,7 @@ 		] 	git "clone" cloneparams "git clone" 	configrepo new-	indir new $ do+	intopdir new $ do 		ver <- annexVersion <$> getTestMode 		git_annex "init"  			[ "-q"@@ -257,12 +268,12 @@ 			] 			"git annex init" 	unless (bareClone cfg) $-		indir new $+		intopdir new $ 			setupTestMode 	return new  configrepo :: FilePath -> IO ()-configrepo dir = indir dir $ do+configrepo dir = intopdir dir $ do 	-- ensure git is set up to let commits happen 	git "config" ["user.name", "Test User"] 		"git config"@@ -556,11 +567,6 @@ 		git "commit" ["--allow-empty", "-m", "empty"] "git commit failed" 		git_annex "adjust" ["--unlock"] "git annex adjust failed" -changeToTopDir :: FilePath -> IO ()-changeToTopDir t = do-	topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")-	setCurrentDirectory $ topdir ++ "/" ++ t- tmpdir :: String tmpdir = ".t" @@ -687,7 +693,7 @@  {- Set up repos as remotes of each other. -} pair :: FilePath -> FilePath -> Assertion-pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do+pair r1 r2 = forM_ [r1, r2] $ \r -> intopdir r $ do 	when (r /= r1) $ 		git "remote" ["add", "r1", "../" ++ r1] "remote add" 	when (r /= r2) $
Utility/Directory/Create.hs view
@@ -77,11 +77,11 @@ 			| null dirs -> 				liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ 					ioError $ customerror doesNotExistErrorType $-						"createDirectoryFrom: " ++ fromRawFilePath topdir ++ " does not exist"+						"createDirectoryUnder: " ++ fromRawFilePath topdir ++ " does not exist" 			| otherwise -> createdirs $ 					map (topdir P.</>) (reverse (scanl1 (P.</>) dirs)) 		_ -> liftIO $ ioError $ customerror userErrorType-			("createDirectoryFrom: not located in " ++ unwords (map fromRawFilePath topdirs))+			("createDirectoryUnder: not located in " ++ unwords (map fromRawFilePath topdirs))   where 	customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0))
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20241031+Version: 10.20241202 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -633,9 +633,10 @@     CmdLine.GitAnnexShell.Checks     CmdLine.GitAnnexShell.Fields     CmdLine.AnnexSetter-    CmdLine.Option+    CmdLine.Multicall     CmdLine.GitRemoteAnnex     CmdLine.GitRemoteTorAnnex+    CmdLine.Option     CmdLine.Seek     CmdLine.Usage     Command
git-annex.hs view
@@ -10,7 +10,9 @@ import System.Environment (getArgs, getProgName) import System.FilePath import Network.Socket (withSocketsDo)+import qualified Data.Map as M +import CmdLine.Multicall import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnexShell import qualified CmdLine.GitRemoteAnnex@@ -34,11 +36,15 @@ #endif 	run ps =<< getProgName   where-	run ps n = case takeFileName n of-		"git-annex-shell" -> CmdLine.GitAnnexShell.run ps-		"git-remote-annex" -> CmdLine.GitRemoteAnnex.run ps-		"git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps-		_  -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps+	run ps n = case M.lookup (takeFileName n) otherMulticallCommands of+		Just GitAnnexShell -> CmdLine.GitAnnexShell.run ps+		Just GitRemoteAnnex -> CmdLine.GitRemoteAnnex.run ps+		Just GitRemoteTorAnnex -> CmdLine.GitRemoteTorAnnex.run ps+		Nothing -> CmdLine.GitAnnex.run+			Test.optParser+			Test.runner+			Benchmark.mkGenerator+			ps  #ifdef mingw32_HOST_OS {- On Windows, if HOME is not set, probe it and set it.
stack.yaml view
@@ -16,3 +16,4 @@ resolver: nightly-2024-07-29 extra-deps: - filepath-bytestring-1.4.100.3.2+- aws-0.24.3