git-annex 10.20231227 → 10.20240129

raw patch · 53 files changed

+818/−291 lines, 53 files

Files

• Annex/Branch.hs +1/−1
• Annex/Content.hs +28/−22
• Annex/Content/LowLevel.hs +8/−8
• Annex/CopyFile.hs +1/−1
• Annex/Import.hs +26/−18
• Annex/StallDetection.hs +83/−12
• Annex/Transfer.hs +3/−3
• Assistant.hs +4/−4
• Assistant/Threads/WebApp.hs +7/−3
• Assistant/TransferSlots.hs +2/−2
• Assistant/WebApp/Gpg.hs +1/−1
• CHANGELOG +28/−0
• COPYRIGHT +1/−1
• CmdLine/GitAnnex/Options.hs +6/−1
• Command/AddUrl.hs +1/−1
• Command/Export.hs +1/−1
• Command/Fsck.hs +1/−1
• Command/Import.hs +15/−5
• Command/Info.hs +39/−21
• Command/RecvKey.hs +1/−1
• Command/Reinject.hs +1/−1
• Command/SendKey.hs +2/−1
• Command/SetKey.hs +1/−1
• Command/Sync.hs +1/−1
• Command/TestRemote.hs +3/−3
• Command/TransferKey.hs +1/−1
• Command/TransferKeys.hs +1/−1
• Command/Transferrer.hs +2/−2
• Command/Watch.hs +8/−1
• Command/WebApp.hs +15/−5
• Crypto.hs +79/−42
• Git/Tree.hs +54/−14
• Limit.hs +16/−0
• Messages/Progress.hs +1/−1
• P2P/Annex.hs +2/−2
• Remote/Directory.hs +1/−1
• Remote/External.hs +1/−1
• Remote/Git.hs +7/−5
• Remote/Helper/Chunked.hs +4/−4
• Remote/Helper/Encryptable.hs +12/−12
• Remote/Helper/P2P.hs +4/−3
• Remote/Helper/Special.hs +11/−7
• Remote/Tahoe.hs +1/−1
• Test.hs +26/−4
• Types/Crypto.hs +1/−0
• Types/GitConfig.hs +26/−6
• Types/StallDetection.hs +9/−1
• Utility/Gpg.hs +21/−40
• Utility/Metered.hs +36/−11
• Utility/StatelessOpenPGP.hs +202/−0
• Utility/WebApp.hs +8/−9
• git-annex.cabal +3/−2
• templates/configurators/genkeymodal.hamlet +1/−1

@@ -136,7 +136,7 @@ 			<$> branchsha 	go False = withIndex' True $ do 		-- Create the index file. This is not necessary,-		-- except to avoid a bug in git that causes+		-- except to avoid a bug in git 2.37 that causes 		-- git write-tree to segfault when the index file does not 		-- exist. 		inRepo $ flip Git.UpdateIndex.streamUpdateIndex []

@@ -279,9 +279,10 @@ {- Runs an action, passing it the temp file to get,  - and if the action succeeds, verifies the file matches  - the key and moves the file into the annex as a key's content. -}-getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool-getViaTmp rsp v key af action = checkDiskSpaceToGet key False $-	getViaTmpFromDisk rsp v key af action+getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> Maybe FileSize -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool+getViaTmp rsp v key af sz action =+	checkDiskSpaceToGet key sz False $+		getViaTmpFromDisk rsp v key af action  {- Like getViaTmp, but does not check that there is enough disk space  - for the incoming key. For use when the key content is already on disk@@ -349,14 +350,14 @@  -  - Wen there's enough free space, runs the download action.  -}-checkDiskSpaceToGet :: Key -> a -> Annex a -> Annex a-checkDiskSpaceToGet key unabletoget getkey = do+checkDiskSpaceToGet :: Key -> Maybe FileSize -> a -> Annex a -> Annex a+checkDiskSpaceToGet key sz unabletoget getkey = do 	tmp <- fromRepo (gitAnnexTmpObjectLocation key) 	e <- liftIO $ doesFileExist (fromRawFilePath tmp) 	alreadythere <- liftIO $ if e 		then getFileSize tmp 		else return 0-	ifM (checkDiskSpace Nothing key alreadythere True)+	ifM (checkDiskSpace sz Nothing key alreadythere True) 		( do 			-- The tmp file may not have been left writable 			when e $ thawContent tmp@@ -542,17 +543,18 @@ 		secureErase obj 		liftIO $ removeWhenExistsWith R.removeLink obj -{- Runs an action to transfer an object's content.+{- Runs an action to transfer an object's content. The action is also+ - passed the size of the object.  -  - In some cases, it's possible for the file to change as it's being sent.  - If this happens, runs the rollback action and throws an exception.  - The rollback action should remove the data that was transferred.  -}-sendAnnex :: Key -> Annex () -> (FilePath -> Annex a) -> Annex a+sendAnnex :: Key -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a sendAnnex key rollback sendobject = go =<< prepSendAnnex' key   where-	go (Just (f, check)) = do-		r <- sendobject f+	go (Just (f, sz, check)) = do+		r <- sendobject f sz 		check >>= \case 			Nothing -> return r 			Just err -> do@@ -571,9 +573,13 @@  - Annex monad of the remote that is receiving the object, rather than  - the sender. So it cannot rely on Annex state.  -}-prepSendAnnex :: Key -> Annex (Maybe (FilePath, Annex Bool))+prepSendAnnex :: Key -> Annex (Maybe (FilePath, FileSize, Annex Bool)) prepSendAnnex key = withObjectLoc key $ \f -> do-	let retval c = return $ Just (fromRawFilePath f, sameInodeCache f c)+	let retval c cs = return $ Just +		(fromRawFilePath f+		, inodeCacheFileSize c+		, sameInodeCache f cs+		) 	cache <- Database.Keys.getInodeCaches key 	if null cache 		-- Since no inode cache is in the database, this@@ -581,7 +587,7 @@ 		-- change while the transfer is in progress, so 		-- generate an inode cache for the starting 		-- content.-		then maybe (return Nothing) (retval . (:[]))+		then maybe (return Nothing) (\fc -> retval fc [fc]) 			=<< withTSDelta (liftIO . genInodeCache f) 		-- Verify that the object is not modified. Usually this 		-- only has to check the inode cache, but if the cache@@ -589,19 +595,19 @@ 		-- content. 		else withTSDelta (liftIO . genInodeCache f) >>= \case 			Just fc -> ifM (isUnmodified' key f fc cache)-				( retval (fc:cache)+				( retval fc (fc:cache) 				, return Nothing 				) 			Nothing -> return Nothing -prepSendAnnex' :: Key -> Annex (Maybe (FilePath, Annex (Maybe String)))+prepSendAnnex' :: Key -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String))) prepSendAnnex' key = prepSendAnnex key >>= \case-	Just (f, checksuccess) -> +	Just (f, sz, checksuccess) ->  		let checksuccess' = ifM checksuccess 			( return Nothing 			, return (Just "content changed while it was being sent") 			)-		in return (Just (f, checksuccess'))+		in return (Just (f, sz, checksuccess')) 	Nothing -> return Nothing  cleanObjectLoc :: Key -> Annex () -> Annex ()@@ -745,9 +751,9 @@ downloadUrl listfailedurls k p iv urls file uo =  	-- Poll the file to handle configurations where an external 	-- download command is used.-	meteredFile file (Just p) k (go urls [])+	meteredFile (toRawFilePath file) (Just p) k (go urls [])   where-	go (u:us) errs = Url.download' p iv u file uo >>= \case+	go (u:us) errs p' = Url.download' p' iv u file uo >>= \case 		Right () -> return True 		Left err -> do 			-- If the incremental verifier was fed anything@@ -759,9 +765,9 @@ 					Just n | n > 0 -> unableIncrementalVerifier iv' 					_ -> noop 				Nothing -> noop-			go us ((u, err) : errs)-	go [] [] = return False-	go [] errs@((_, err):_) = do+			go us ((u, err) : errs) p'+	go [] [] _ = return False+	go [] errs@((_, err):_) _ = do 		if listfailedurls 			then warning $ UnquotedString $ 				unlines $ flip map errs $ \(u, err') ->

@@ -1,6 +1,6 @@ {- git-annex low-level content functions  -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -102,13 +102,13 @@  - to be downloaded from the free space. This way, we avoid overcommitting  - when doing concurrent downloads.  -}-checkDiskSpace :: Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool-checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (fromKey keySize key)) destdir key+checkDiskSpace :: Maybe FileSize -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool+checkDiskSpace msz destdir key = checkDiskSpace' sz destdir key+  where+	sz = fromMaybe 1 (fromKey keySize key <|> msz) -{- Allows specifying the size of the key, if it's known, which is useful- - as not all keys know their size. -}-checkDiskSpace' :: Integer -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool-checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getRead Annex.force)+checkDiskSpace' :: FileSize -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool+checkDiskSpace' sz destdir key alreadythere samefilesystem = ifM (Annex.getRead Annex.force) 	( return True 	, do 		-- We can't get inprogress and free at the same@@ -123,7 +123,7 @@ 		dir >>= liftIO . getDiskFree . fromRawFilePath >>= \case 			Just have -> do 				reserve <- annexDiskReserve <$> Annex.getGitConfig-				let delta = need + reserve - have - alreadythere + inprogress+				let delta = sz + reserve - have - alreadythere + inprogress 				let ok = delta <= 0 				unless ok $ 					warning $ UnquotedString $ 

@@ -57,7 +57,7 @@ 			) 		)   where-	docopycow = watchFileSize dest meterupdate $+	docopycow = watchFileSize dest' meterupdate $ const $ 		copyCoW CopyTimeStamps src dest 	 	dest' = toRawFilePath dest

@@ -1,6 +1,6 @@ {- git-annex import from remotes  -- - Copyright 2019-2023 Joey Hess <id@joeyh.name>+ - Copyright 2019-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -223,20 +223,27 @@ 		-- nothing new needs to be committed. 		-- (This is unlikely to happen.) 		| sametodepth h' = return Nothing-		| otherwise = do-			importedcommit <- case getRemoteTrackingBranchImportHistory h of-				Nothing -> mkcommitsunconnected imported-				Just oldimported@(History oldhc _)-					| importeddepth == 1 ->-						mkcommitconnected imported oldimported-					| otherwise -> do-						let oldimportedtrees = mapHistory historyCommitTree oldimported-						mknewcommits oldhc oldimportedtrees imported-			ti' <- addBackExportExcluded remote ti-			Just <$> makeRemoteTrackingBranchMergeCommit'-				trackingcommit importedcommit ti'+		-- If the imported tree is unchanged,+		-- nothing new needs to be committed.+		| otherwise = getLastImportedTree remote >>= \case+			Just (LastImportedTree lasttree)+				| lasttree == ti -> return Nothing+			_ -> gencommit trackingcommit h 	  where 		h'@(History t s) = mapHistory historyCommitTree h+	+	gencommit trackingcommit h = do+		importedcommit <- case getRemoteTrackingBranchImportHistory h of+			Nothing -> mkcommitsunconnected imported+			Just oldimported@(History oldhc _)+				| importeddepth == 1 ->+					mkcommitconnected imported oldimported+				| otherwise -> do+					let oldimportedtrees = mapHistory historyCommitTree oldimported+					mknewcommits oldhc oldimportedtrees imported+		ti' <- addBackExportExcluded remote ti+		Just <$> makeRemoteTrackingBranchMergeCommit'+			trackingcommit importedcommit ti'  	importeddepth = historyDepth imported @@ -791,7 +798,6 @@ 					, providedMimeEncoding = Nothing 					, providedLinkType = Nothing 					}-				let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote) 				islargefile <- checkMatcher' matcher mi mempty 				metered Nothing sz bwlimit $ const $ if islargefile 					then doimportlarge importkey cidmap loc cid sz f@@ -834,7 +840,7 @@ 				when ok $ 					logStatus k InfoPresent 				return (Just (k, ok))-			checkDiskSpaceToGet k Nothing $+			checkDiskSpaceToGet k Nothing Nothing $ 				notifyTransfer Download af $ 					download' (Remote.uuid remote) k af Nothing stdRetry $ \p' -> 						withTmp k $ downloader p'@@ -853,7 +859,7 @@ 					recordcidkey cidmap cid k 					return sha 				Nothing -> error "internal"-		checkDiskSpaceToGet tmpkey Nothing $+		checkDiskSpaceToGet tmpkey Nothing Nothing $ 			withTmp tmpkey $ \tmpfile -> 				tryNonAsync (downloader tmpfile) >>= \case 					Right sha -> return $ Just (loc, Left sha)@@ -888,8 +894,7 @@ 			Left e -> do 				warning (UnquotedString (show e)) 				return Nothing-		let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote)-		checkDiskSpaceToGet tmpkey Nothing $+		checkDiskSpaceToGet tmpkey Nothing Nothing $ 			notifyTransfer Download af $ 				download' (Remote.uuid remote) tmpkey af Nothing stdRetry $ \p -> 					withTmp tmpkey $ \tmpfile ->@@ -917,6 +922,9 @@ 				else gitShaKey <$> hashFile tmpfile 	 	ia = Remote.importActions remote+				+	bwlimit = remoteAnnexBwLimitDownload (Remote.gitconfig remote)+			<|> remoteAnnexBwLimit (Remote.gitconfig remote)  	locworktreefile loc = fromRepo $ fromTopFilePath $ asTopFilePath $ 		case importtreeconfig of

@@ -1,14 +1,20 @@ {- Stall detection for transfers.  -- - Copyright 2020-2021 Joey Hess <id@joeyh.name>+ - Copyright 2020-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -module Annex.StallDetection (detectStalls, StallDetection) where+module Annex.StallDetection (+	getStallDetection,+	detectStalls,+	StallDetection,+) where  import Annex.Common import Types.StallDetection+import Types.Direction+import Types.Remote (gitconfig) import Utility.Metered import Utility.HumanTime import Utility.DataUnits@@ -16,41 +22,71 @@  import Control.Concurrent.STM import Control.Monad.IO.Class (MonadIO)+import Data.Time.Clock +getStallDetection :: Direction -> Remote -> Maybe StallDetection+getStallDetection Download r = +	remoteAnnexStallDetectionDownload (gitconfig r)+		<|> remoteAnnexStallDetection (gitconfig r)+getStallDetection Upload r =+	remoteAnnexStallDetectionUpload (gitconfig r)+		<|> remoteAnnexStallDetection (gitconfig r)+ {- This may be safely canceled (with eg uninterruptibleCancel),  - as long as the passed action can be safely canceled. -} detectStalls :: (Monad m, MonadIO m) => Maybe StallDetection -> TVar (Maybe BytesProcessed) -> m () -> m () detectStalls Nothing _ _ = noop detectStalls (Just StallDetectionDisabled) _ _ = noop-detectStalls (Just (StallDetection (BwRate minsz duration))) metervar onstall =-	detectStalls' minsz duration metervar onstall Nothing+detectStalls (Just (StallDetection bwrate@(BwRate _minsz duration))) metervar onstall = do+	-- If the progress is being updated, but less frequently than+	-- the specified duration, a stall would be incorrectly detected.+	--+	-- For example, consider the case of a remote that does+	-- not support progress updates, but is chunked with a large chunk+	-- size. In that case, progress is only updated after each chunk.+	--+	-- So, wait for the first update, and see how long it takes.+	-- When it's longer than the duration (or close to it), +	-- upscale the duration and minsz accordingly.+	starttime <- liftIO getCurrentTime+	v <- waitforfirstupdate =<< readMeterVar metervar+	endtime <- liftIO getCurrentTime+	let timepassed = floor (endtime `diffUTCTime` starttime)+	let BwRate scaledminsz scaledduration = upscale bwrate timepassed+	detectStalls' scaledminsz scaledduration metervar onstall v+  where+	minwaitsecs = Seconds $+		min 60 (fromIntegral (durationSeconds duration))+	waitforfirstupdate startval = do+		liftIO $ threadDelaySeconds minwaitsecs+		v <- readMeterVar metervar+		if v > startval+			then return v+			else waitforfirstupdate startval detectStalls (Just ProbeStallDetection) metervar onstall = do 	-- Only do stall detection once the progress is confirmed to be 	-- consistently updating. After the first update, it needs to 	-- advance twice within 30 seconds. With that established, 	-- if no data at all is sent for a 60 second period, it's 	-- assumed to be a stall.-	v <- getval >>= waitforfirstupdate+	v <- readMeterVar metervar >>= waitforfirstupdate 	ontimelyadvance v $ \v' -> ontimelyadvance v' $ 		detectStalls' 1 duration metervar onstall   where-	getval = liftIO $ atomically $ fmap fromBytesProcessed-		<$> readTVar metervar-	 	duration = Duration 60  	delay = Seconds (fromIntegral (durationSeconds duration) `div` 2) 	 	waitforfirstupdate startval = do 		liftIO $ threadDelaySeconds delay-		v <- getval+		v <- readMeterVar metervar 		if v > startval 			then return v 			else waitforfirstupdate startval  	ontimelyadvance v cont = do 		liftIO $ threadDelaySeconds delay-		v' <- getval+		v' <- readMeterVar metervar 		when (v' > v) $ 			cont v' @@ -65,8 +101,7 @@ detectStalls' minsz duration metervar onstall st = do 	liftIO $ threadDelaySeconds delay 	-- Get whatever progress value was reported most recently, if any.-	v <- liftIO $ atomically $ fmap fromBytesProcessed-		<$> readTVar metervar+	v <- readMeterVar metervar 	let cont = detectStalls' minsz duration metervar onstall v 	case (st, v) of 		(Nothing, _) -> cont@@ -81,3 +116,39 @@ 			| otherwise -> cont   where 	delay = Seconds (fromIntegral (durationSeconds duration))++readMeterVar+	:: MonadIO m+	=> TVar (Maybe BytesProcessed)+	-> m (Maybe ByteSize)+readMeterVar metervar = liftIO $ atomically $ +	fmap fromBytesProcessed <$> readTVar metervar++-- Scale up the minsz and duration to match the observed time that passed+-- between progress updates. This allows for some variation in the transfer+-- rate causing later progress updates to happen less frequently.+upscale :: BwRate -> Integer -> BwRate+upscale input@(BwRate minsz duration) timepassedsecs+	| timepassedsecs > dsecs `div` allowedvariation = BwRate +		(ceiling (fromIntegral minsz * scale))+		(Duration (ceiling (fromIntegral dsecs * scale)))+	| otherwise = input+  where+	scale = max (1 :: Double) $+		(fromIntegral timepassedsecs / fromIntegral (max dsecs 1))+		* fromIntegral allowedvariation+	+	dsecs = durationSeconds duration++	-- Setting this too low will make normal bandwidth variations be+	-- considered to be stalls, while setting it too high will make+	-- stalls not be detected for much longer than the expected+	-- duration.+	--+	-- For example, a BwRate of 20MB/1m, when the first progress+	-- update takes 10m to arrive, is scaled to 600MB/30m. That 30m+	-- is a reasonable since only 3 chunks get sent in that amount of+	-- time at that rate. If allowedvariation = 10, that would+	-- be 2000MB/100m, which seems much too long to wait to detect a+	-- stall.+	allowedvariation = 3

@@ -56,7 +56,7 @@ -- Upload, supporting canceling detected stalls. upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool upload r key f d witness = -	case remoteAnnexStallDetection (Remote.gitconfig r) of+	case getStallDetection Upload r of 		Nothing -> go (Just ProbeStallDetection) 		Just StallDetectionDisabled -> go Nothing 		Just sd -> runTransferrer sd r key f d Upload witness@@ -75,12 +75,12 @@ -- Download, supporting canceling detected stalls. download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool download r key f d witness = -	case remoteAnnexStallDetection (Remote.gitconfig r) of+	case getStallDetection Download r of 		Nothing -> go (Just ProbeStallDetection) 		Just StallDetectionDisabled -> go Nothing 		Just sd -> runTransferrer sd r key f d Download witness   where-	go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f $ \dest ->+	go sd = getViaTmp (Remote.retrievalSecurityPolicy r) vc key f Nothing $ \dest -> 		download' (Remote.uuid r) key f sd d (go' dest) witness 	go' dest p = verifiedAction $ 		Remote.retrieveKeyFile r key f (fromRawFilePath dest) p vc

@@ -59,7 +59,7 @@ #endif import qualified Utility.Debug as Debug -import Network.Socket (HostName)+import Network.Socket (HostName, PortNumber)  stopDaemon :: Annex () stopDaemon = liftIO . Utility.Daemon.stopDaemon . fromRawFilePath@@ -70,8 +70,8 @@  -  - startbrowser is passed the url and html shim file, as well as the original  - stdout and stderr descriptors. -}-startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()-startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do+startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe PortNumber ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()+startDaemon assistant foreground startdelay cannotrun listenhost listenport startbrowser = do 	Annex.changeState $ \s -> s { Annex.daemon = True } 	enableInteractiveBranchAccess 	pidfile <- fromRepo gitAnnexPidFile@@ -141,7 +141,7 @@ #endif 		urlrenderer <- liftIO newUrlRenderer #ifdef WITH_WEBAPP-		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost webappwaiter ]+		let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost listenport webappwaiter ] #else 		let webappthread = [] #endif

@@ -45,7 +45,7 @@ import qualified Annex  import Yesod-import Network.Socket (SockAddr, HostName)+import Network.Socket (SockAddr, HostName, PortNumber) import Data.Text (pack, unpack) import qualified Network.Wai.Handler.WarpTLS as TLS import Network.Wai.Middleware.RequestLogger@@ -61,12 +61,16 @@ 	-> Maybe String 	-> Maybe (IO Url) 	-> Maybe HostName+	-> Maybe PortNumber 	-> Maybe (Url -> FilePath -> IO ()) 	-> NamedThread-webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost onstartup = thread $ liftIO $ do+webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost listenport onstartup = thread $ liftIO $ do 	listenhost' <- if isJust listenhost 		then pure listenhost 		else getAnnex $ annexListen <$> Annex.getGitConfig+	listenport' <- if isJust listenport+		then pure listenport+		else getAnnex $ annexPort <$> Annex.getGitConfig 	tlssettings <- getAnnex getTlsSettings 	webapp <- WebApp 		<$> pure assistantdata@@ -84,7 +88,7 @@ 		( return $ logStdout app 		, return app 		)-	runWebApp tlssettings listenhost' app' $ \addr -> if noannex+	runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex 		then withTmpFile "webapp.html" $ \tmpfile h -> do 			hClose h 			go tlssettings addr webapp tmpfile Nothing

@@ -33,6 +33,7 @@ import qualified Types.Remote as Remote import Annex.Content import Annex.Wanted+import Annex.StallDetection import Utility.Batch import Types.NumCopies @@ -126,8 +127,7 @@ 				qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig 				debug [ "Transferring:" , describeTransfer qp t info ] 				notifyTransfer-				let sd = remoteAnnexStallDetection-					(Remote.gitconfig remote)+				let sd = getStallDetection (transferDirection t) remote 				return $ Just (t, info, go remote sd) 			, do 				qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig

@@ -54,7 +54,7 @@ withNewSecretKey use = do 	cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig 	userid <- liftIO $ newUserId cmd-	liftIO $ genSecretKey cmd RSA "" userid maxRecommendedKeySize+	liftIO $ genSecretKey cmd "" userid 	results <- M.keys . M.filter (== userid) <$> liftIO (secretKeys cmd) 	case results of 		[] -> giveup "Failed to generate gpg key!"

@@ -1,3 +1,31 @@+git-annex (10.20240129) upstream; urgency=medium++  * info: Added "annex sizes of repositories" table to the overall display.+  * import: Sped up import from special remotes.+  * import: Added --message/-m option.+  * Support using commands that implement the Stateless OpenPGP command line+    interface, as an alternative to gpg.+    Currently only supported for encryption=shared special remotes,+    when annex.shared-sop-command is configured.+  * test: Test a specified Stateless OpenPGP command when+    run with eg --test-git-config annex.shared-sop-command=sqop+  * Improve disk free space checking when transferring unsized keys to+    local git remotes.+  * Added configs annex.stalldetection-download, annex.stalldetection-upload,+    annex.bwlimit-download, annex.bwlimit-upload,+    and similar per-remote configs.+  * Improve annex.stalldetection to handle remotes that update progress+    less frequently than the configured time period.+  * external: Monitor file size when getting content from external+    special remotes and use that to update the progress meter,+    in case the external special remote program does not report progress.+  * Added --expected-present file matching option.+  * webapp: Added --port option, and annex.port config.+  * assistant: When generating a gpg secret key, avoid hardcoding the+    key algorithm and size.++ -- Joey Hess <id@joeyh.name>  Mon, 29 Jan 2024 13:12:00 -0400+ git-annex (10.20231227) upstream; urgency=medium    * migrate: Support distributed migrations by recording each migration,

@@ -2,7 +2,7 @@ Source: native package  Files: *-Copyright: © 2010-2023 Joey Hess <id@joeyh.name>+Copyright: © 2010-2024 Joey Hess <id@joeyh.name> License: AGPL-3+  Files: Assistant/WebApp.hs Assistant/WebApp/* templates/* static/*

@@ -293,7 +293,7 @@ keyMatchingOptions' =  	[ annexOption (setAnnexState . Limit.addIn) $ strOption 		( long "in" <> short 'i' <> metavar paramRemote-		<> help "match files present in a remote"+		<> help "match files present in a repository" 		<> hidden 		<> completeRemotes 		)@@ -384,6 +384,11 @@ 	, annexFlag (setAnnexState Limit.addLocked) 		( long "locked" 		<> help "match files that are locked"+		<> hidden+		)+	, annexFlag (setAnnexState Limit.addExpectedPresent)+		( long "expected-present"+		<> help "match files expected to be present" 		<> hidden 		) 	]

@@ -439,7 +439,7 @@  - the returned location. -} downloadWith' :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> RawFilePath -> Annex (Maybe (RawFilePath, Backend)) downloadWith' downloader dummykey u url file =-	checkDiskSpaceToGet dummykey Nothing $ do+	checkDiskSpaceToGet dummykey Nothing Nothing $ do 		backend <- chooseBackend file 		tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey 		let t = (Transfer.Transfer Transfer.Download u (fromKey id dummykey))

@@ -304,7 +304,7 @@ 				alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do 					let rollback = void $ 						performUnexport r db [ek] loc-					sendAnnex ek rollback $ \f ->+					sendAnnex ek rollback $ \f _sz -> 						Remote.action $ 							storer f ek loc pm 			, do

@@ -195,7 +195,7 @@ 		let cleanup = liftIO $ catchIO (R.removeLink tmp) (const noop) 		cleanup 		cleanup `after` a tmp-	getfile tmp = ifM (checkDiskSpace (Just (P.takeDirectory tmp)) key 0 True)+	getfile tmp = ifM (checkDiskSpace Nothing (Just (P.takeDirectory tmp)) key 0 True) 		( ifM (getcheap tmp) 			( return (Just (Right UnVerified)) 			, ifM (Annex.getRead Annex.fast)

@@ -70,6 +70,7 @@ 		, importToSubDir :: Maybe FilePath 		, importContent :: Bool 		, checkGitIgnoreOption :: CheckGitIgnore+		, messageOption :: Maybe String 		}  optParser :: CmdParamsDesc -> Parser ImportOptions@@ -81,7 +82,11 @@ 		) 	dupmode <- fromMaybe Default <$> optional duplicateModeParser 	ic <- Command.Add.checkGitIgnoreSwitch-	return $ case mfromremote of+	message <- optional (strOption+		( long "message" <> short 'm' <> metavar "MSG"+		<> help "commit message"+		))+	pure $ case mfromremote of 		Nothing -> LocalImportOptions ps dupmode ic 		Just r -> case ps of 			[bs] -> @@ -91,6 +96,7 @@ 					(if null subdir then Nothing else Just subdir) 					content 					ic+					message 			_ -> giveup "expected BRANCH[:SUBDIR]"  data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates | ReinjectDuplicates@@ -141,7 +147,9 @@ 		(pure Nothing) 		(Just <$$> inRepo . toTopFilePath . toRawFilePath) 		(importToSubDir o)-	seekRemote r (importToBranch o) subdir (importContent o) (checkGitIgnoreOption o)+	seekRemote r (importToBranch o) subdir (importContent o) +		(checkGitIgnoreOption o)+		(messageOption o)  startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (RawFilePath, RawFilePath) -> CommandStart startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) =@@ -314,8 +322,8 @@ 	verifyEnoughCopiesToDrop [] key Nothing needcopies mincopies [] preverified tocheck 		(const yes) no -seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CheckGitIgnore -> CommandSeek-seekRemote remote branch msubdir importcontent ci = do+seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CheckGitIgnore -> Maybe String -> CommandSeek+seekRemote remote branch msubdir importcontent ci mimportmessage = do 	importtreeconfig <- case msubdir of 		Nothing -> return ImportTree 		Just subdir ->@@ -345,7 +353,9 @@ 				includeCommandAction $  					commitimport imported   where-	importmessage = "import from " ++ Remote.name remote+	importmessage = fromMaybe +		("import from " ++ Remote.name remote)+		mimportmessage  	tb = mkRemoteTrackingBranch remote branch 

@@ -283,6 +283,7 @@ 	, known_annex_files True 	, known_annex_size True 	, total_annex_size+	, reposizes_stats_global 	, backend_usage 	, bloom_info 	]@@ -298,7 +299,7 @@ tree_slow_stats :: [FilePath -> Stat] tree_slow_stats = 	[ const numcopies_stats-	, const reposizes_stats+	, const reposizes_stats_tree 	, const reposizes_total 	] @@ -372,6 +373,10 @@ countRepoList _ [] = "0" countRepoList n s = show n ++ "\n" ++ beginning s +dispRepoList :: String -> String+dispRepoList [] = ""+dispRepoList s = "\n" ++ beginning s+ dir_name :: FilePath -> Stat dir_name dir = simpleStat "directory" $ pure dir @@ -441,7 +446,8 @@ total_annex_size :: Stat total_annex_size =  	simpleStat "combined annex size of all repositories" $-		showSizeKeys =<< cachedAllRepoData+		showSizeKeys . fromMaybe mempty . allRepoData+		=<< cachedAllRepoData    treeDesc :: Bool -> String treeDesc True = "working tree"@@ -545,21 +551,29 @@ 		. map (\(variance, count) -> "numcopies " ++ variance ++ ": " ++ show count) 		. V.toList -reposizes_stats :: Stat-reposizes_stats = stat desc $ nojson $ do+reposizes_stats_tree :: Stat+reposizes_stats_tree = reposizes_stats True "repositories containing these files"+	=<< cachedRepoData++reposizes_stats_global :: Stat+reposizes_stats_global = reposizes_stats False "annex sizes of repositories" +	. repoData =<< cachedAllRepoData++reposizes_stats :: Bool -> String -> M.Map UUID KeyInfo -> Stat+reposizes_stats count desc m = stat desc $ nojson $ do 	sizer <- mkSizer-	l <- map (\(u, kd) -> (u, sizer storageUnits True (sizeKeys kd)))-		. sortBy (flip (comparing (sizeKeys . snd)))-		. M.toList-		<$> cachedRepoData+	let l = map (\(u, kd) -> (u, sizer storageUnits True (sizeKeys kd))) $+		sortBy (flip (comparing (sizeKeys . snd))) $+		M.toList m 	let maxlen = maximum (map (length . snd) l) 	descm <- lift Remote.uuidDescriptions 	-- This also handles json display. 	s <- lift $ Remote.prettyPrintUUIDsWith (Just "size") desc descm (Just . show) $ 		map (\(u, sz) -> (u, Just $ mkdisp sz maxlen)) l-	return $ countRepoList (length l) s+	return $ if count+		then countRepoList (length l) s+		else dispRepoList s   where-	desc = "repositories containing these files" 	mkdisp sz maxlen = DualDisp 		{ dispNormal = lpad maxlen sz 		, dispJson = sz@@ -619,28 +633,32 @@ 			put s { referencedData = Just v } 			return v -cachedAllRepoData :: StatState KeyInfo+cachedAllRepoData :: StatState StatInfo cachedAllRepoData = do 	s <- get 	case allRepoData s of-		Just v -> return v+		Just _ -> return s 		Nothing -> do 			matcher <- lift getKeyOnlyMatcher-			!v <- lift $ overLocationLogs emptyKeyInfo $ \k locs d -> do-				numcopies <- genericLength . snd-					<$> trustPartition DeadTrusted locs+			!(d, rd) <- lift $ overLocationLogs (emptyKeyInfo, mempty) $ \k locs (d, rd) -> do 				ifM (matchOnKey matcher k)-					( return (addKeyCopies numcopies k d)-					, return d+					( do+						alivelocs <- snd+							<$> trustPartition DeadTrusted locs+						let !d' = addKeyCopies (genericLength alivelocs) k d+						let !rd' = foldl' (flip (accumrepodata k)) rd alivelocs+						return (d', rd')+					, return (d, rd) 					)-			put s { allRepoData = Just v }-			return v+			let s' = s { allRepoData = Just d, repoData = rd }+			put s'+			return s'+  where+	accumrepodata k = M.alter (Just . addKey k . fromMaybe emptyKeyInfo) --- currently only available for directory info cachedNumCopiesStats :: StatState (Maybe NumCopiesStats) cachedNumCopiesStats = numCopiesStats <$> get --- currently only available for directory info cachedRepoData :: StatState (M.Map UUID KeyInfo) cachedRepoData = repoData <$> get 

@@ -28,7 +28,7 @@ start (_, key) = fieldTransfer Download key $ \_p -> do 	-- This matches the retrievalSecurityPolicy of Remote.Git 	let rsp = RetrievalAllKeysSecure-	ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) go)+	ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) Nothing go) 		( do 			logStatus key InfoPresent 			_ <- quiesce True

@@ -128,7 +128,7 @@ 		, giveup "failed" 		)   where-	move = checkDiskSpaceToGet key False $+	move = checkDiskSpaceToGet key Nothing False $ 		moveAnnex key (AssociatedFile Nothing) src  cleanup :: Key -> CommandCleanup

@@ -32,7 +32,8 @@ 		<$> getField "RsyncOptions" 	ifM (inAnnex key) 		( fieldTransfer Upload key $ \_p ->-			sendAnnex key rollback $ liftIO . rsyncServerSend (map Param opts)+			sendAnnex key rollback $ \f _sz -> +				liftIO $ rsyncServerSend (map Param opts) f 		, do 			warning "requested key is not present" 			liftIO exitFailure

@@ -36,7 +36,7 @@ 	-- the file might be on a different filesystem, so moveFile is used 	-- rather than simply calling moveAnnex; disk space is also 	-- checked this way.-	ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key (AssociatedFile Nothing) $ \dest -> unVerified $+	ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key (AssociatedFile Nothing) Nothing $ \dest -> unVerified $ 		if dest /= file 			then liftIO $ catchBoolIO $ do 				moveFile file dest

@@ -591,7 +591,7 @@ 			let (branch, subdir) = splitRemoteAnnexTrackingBranchSubdir b 			if canImportKeys remote importcontent 				then do-					Command.Import.seekRemote remote branch subdir importcontent (CheckGitIgnore True)+					Command.Import.seekRemote remote branch subdir importcontent (CheckGitIgnore True) Nothing 					-- Importing generates a branch 					-- that is not initially connected 					-- to the current branch, so allow

@@ -296,7 +296,7 @@ 		Just b -> case Types.Backend.verifyKeyContent b of 			Nothing -> return True 			Just verifier -> verifier k (serializeKey' k)-	get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->+	get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> 		tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case 			Right v -> return (True, v) 			Left _ -> return (False, UnVerified)@@ -370,13 +370,13 @@ 	, check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> 		Remote.checkPresent r k 	, check (== Right False) "retrieveKeyFile" $ \r k ->-		logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest ->+		logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest -> 			tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case 				Right v -> return (True, v) 				Left _ -> return (False, UnVerified) 	, check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of 		Nothing -> return False-		Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> +		Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) Nothing $ \dest ->  			unVerified $ isRight 				<$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) 	]

@@ -63,7 +63,7 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $ 	download' (uuid remote) key file Nothing stdRetry $ \p ->-		logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file $ \t ->+		logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file Nothing $ \t -> 			tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case 				Right v -> return (True, v)	 				Left e -> do

@@ -50,7 +50,7 @@ 						return True 		| otherwise = notifyTransfer direction file $ 			download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->-				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do+				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case 						Left e -> do 							warning (UnquotedString (show e))

@@ -55,7 +55,7 @@ 		-- so caller is responsible for doing notification 		-- and for retrying, and updating location log, 		-- and stall canceling.-		let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do+		let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do 			Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) 		in download' (Remote.uuid remote) key file Nothing noRetry go  			noNotification@@ -72,7 +72,7 @@ 	runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote = 		notifyTransfer Download file $ 			download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->-				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do+				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case 						Left e -> do 							warning (UnquotedString (show e))

@@ -24,5 +24,12 @@ start assistant o startdelay = do 	if stopDaemonOption o 		then stopDaemon-		else startDaemon assistant (foregroundDaemonOption o) startdelay Nothing Nothing Nothing -- does not return+		else startDaemon assistant +			(foregroundDaemonOption o)+			startdelay+			Nothing +			Nothing+			Nothing+			Nothing+			-- does not return 	stop

@@ -36,6 +36,7 @@  import Control.Concurrent import Control.Concurrent.STM+import Network.Socket (PortNumber)  cmd :: Command cmd = noCommit $ dontCheck repoExists $ notBareRepo $@@ -45,6 +46,7 @@  data WebAppOptions = WebAppOptions 	{ listenAddress :: Maybe String+	, listenPort :: Maybe PortNumber 	}  optParser :: CmdParamsDesc -> Parser WebAppOptions@@ -53,6 +55,10 @@ 		( long "listen" <> metavar paramAddress 		<> help "accept connections to this address" 		))+	<*> optional (option auto+		( long "port" <> metavar paramNumber+		<> help "specify port to listen on"+		))  seek :: WebAppOptions -> CommandSeek seek = commandAction . start@@ -77,9 +83,12 @@ 		listenAddress' <- if isJust (listenAddress o) 			then pure (listenAddress o) 			else annexListen <$> Annex.getGitConfig+		listenPort' <- if isJust (listenPort o)+			then pure (listenPort o)+			else annexPort <$> Annex.getGitConfig 		ifM (checkpid <&&> checkshim (fromRawFilePath f))-			( if isJust (listenAddress o)-				then giveup "The assistant is already running, so --listen cannot be used."+			( if isJust (listenAddress o) || isJust (listenPort o)+				then giveup "The assistant is already running, so --listen and --port cannot be used." 				else do 					url <- liftIO . readFile . fromRawFilePath 						=<< fromRepo gitAnnexUrlFile@@ -87,7 +96,7 @@ 						then putStrLn url 						else liftIO $ openBrowser browser (fromRawFilePath f) url Nothing Nothing 			, do-				startDaemon True True Nothing cannotrun listenAddress' $ Just $ +				startDaemon True True Nothing cannotrun listenAddress' listenPort' $ Just $  					\origout origerr url htmlshim -> 						if isJust listenAddress' 							then maybe noop (`hPutStrLn` url) origout@@ -168,6 +177,7 @@ 			webAppThread d urlrenderer True Nothing 				(callback signaler) 				(listenAddress o)+				(listenPort o) 				(callback mainthread) 		waitNamedThreads   where@@ -189,8 +199,8 @@ 			_wait <- takeMVar v 			state <- Annex.new =<< Git.CurrentRepo.get 			Annex.eval state $-				startDaemon True True Nothing Nothing (listenAddress o) $ Just $-					sendurlback v+				startDaemon True True Nothing Nothing (listenAddress o) (listenPort o) +					(Just $ sendurlback v) 	sendurlback v _origout _origerr url _htmlshim = putMVar v url  openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()

@@ -1,9 +1,8 @@ {- git-annex crypto  -- - Currently using gpg; could later be modified to support different- - crypto backends if necessary.+ - Currently using gpg by default, or optionally stateless OpenPGP.  -- - 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.  -}@@ -32,7 +31,7 @@ 	readBytesStrictly, 	encrypt, 	decrypt,-	LensGpgEncParams(..),+	LensEncParams(..),  	prop_HmacSha1WithCipher_sane ) where@@ -40,36 +39,42 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Control.Monad.IO.Class+import qualified Data.ByteString.Short as S (toShort)  import Annex.Common import qualified Utility.Gpg as Gpg+import qualified Utility.StatelessOpenPGP as SOP import Types.Crypto import Types.Remote import Types.Key import Annex.SpecialRemote.Config-import qualified Data.ByteString.Short as S (toShort)+import Utility.Tmp.Dir +{- The number of bytes of entropy used to generate a Cipher.+ -+ - Since a Cipher is base-64 encoded, the actual size of a Cipher+ - is larger than this. 512 bytes of date base-64 encodes to 684+ - characters.+ -}+cipherSize :: Int+cipherSize = 512+ {- The beginning of a Cipher is used for MAC'ing; the remainder is used- - as the GPG symmetric encryption passphrase when using the hybrid- - scheme. Note that the cipher itself is base-64 encoded, hence the- - string is longer than 'cipherSize': 683 characters, padded to 684.+ - as the symmetric encryption passphrase.  -- - The 256 first characters that feed the MAC represent at best 192- - bytes of entropy.  However that's more than enough for both the- - default MAC algorithm, namely HMAC-SHA1, and the "strongest"+ - Due to the base-64 encoding of the Cipher, the beginning 265 characters+ - represent at best 192 bytes of entropy. However that's more than enough+ - for both the default MAC algorithm, namely HMAC-SHA1, and the "strongest"  - currently supported, namely HMAC-SHA512, which respectively need  - (ideally) 64 and 128 bytes of entropy.  -- - The remaining characters (320 bytes of entropy) is enough for GnuPG's- - symmetric cipher; unlike weaker public key crypto, the key does not- - need to be too large.+ - The remaining characters (320 bytes of entropy) is enough for+ - the symmetric encryption passphrase; unlike weaker public key crypto,+ - that does not need to be too large.  -} cipherBeginning :: Int cipherBeginning = 256 -cipherSize :: Int-cipherSize = 512- cipherPassphrase :: Cipher -> S.ByteString cipherPassphrase (Cipher c) = S.drop cipherBeginning c cipherPassphrase (MacOnlyCipher _) = giveup "MAC-only cipher"@@ -79,7 +84,7 @@ cipherMac (MacOnlyCipher c) = c  {- Creates a new Cipher, encrypted to the specified key id. -}-genEncryptedCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> Gpg.KeyId -> EncryptedCipherVariant -> Bool -> IO StorableCipher+genEncryptedCipher :: LensEncParams c => Gpg.GpgCmd -> c -> Gpg.KeyId -> EncryptedCipherVariant -> Bool -> IO StorableCipher genEncryptedCipher cmd c keyid variant highQuality = do 	ks <- Gpg.findPubKeys cmd keyid 	random <- Gpg.genRandom cmd highQuality size@@ -105,7 +110,7 @@ {- Updates an existing Cipher, making changes to its keyids.  -  - When the Cipher is encrypted, re-encrypts it. -}-updateCipherKeyIds :: LensGpgEncParams encparams => Gpg.GpgCmd -> encparams -> [(Bool, Gpg.KeyId)] -> StorableCipher -> IO StorableCipher+updateCipherKeyIds :: LensEncParams encparams => Gpg.GpgCmd -> encparams -> [(Bool, Gpg.KeyId)] -> StorableCipher -> IO StorableCipher updateCipherKeyIds _ _ _ SharedCipher{} = giveup "Cannot update shared cipher" updateCipherKeyIds _ _ [] c = return c updateCipherKeyIds cmd encparams changes encipher@(EncryptedCipher _ variant ks) = do@@ -129,7 +134,7 @@ 	listKeyIds = concat <$$> mapM (keyIds <$$> Gpg.findPubKeys cmd)  {- Encrypts a Cipher to the specified KeyIds. -}-encryptCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> Cipher -> EncryptedCipherVariant -> KeyIds -> IO StorableCipher+encryptCipher :: LensEncParams c => Gpg.GpgCmd -> c -> Cipher -> EncryptedCipherVariant -> KeyIds -> IO StorableCipher encryptCipher cmd c cip variant (KeyIds ks) = do 	-- gpg complains about duplicate recipient keyids 	let ks' = nub $ sort ks@@ -146,10 +151,10 @@ 		MacOnlyCipher x -> x  {- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}-decryptCipher :: LensGpgEncParams c => Gpg.GpgCmd -> c -> StorableCipher -> IO Cipher+decryptCipher :: LensEncParams c => Gpg.GpgCmd -> c -> StorableCipher -> IO Cipher decryptCipher cmd c cip = decryptCipher' cmd Nothing c cip -decryptCipher' :: LensGpgEncParams c => Gpg.GpgCmd -> Maybe [(String, String)] -> c -> StorableCipher -> IO Cipher+decryptCipher' :: LensEncParams c => Gpg.GpgCmd -> Maybe [(String, String)] -> c -> StorableCipher -> IO Cipher decryptCipher' _ _ _ (SharedCipher t) = return $ Cipher t decryptCipher' _ _ _ (SharedPubKeyCipher t _) = return $ MacOnlyCipher t decryptCipher' cmd environ c (EncryptedCipher t variant _) =@@ -195,19 +200,25 @@ readBytesStrictly :: (MonadIO m) => (S.ByteString -> m a) -> Reader m a readBytesStrictly a h = liftIO (S.hGetContents h) >>= a - {- Runs a Feeder action, that generates content that is symmetrically  - encrypted with the Cipher (unless it is empty, in which case- - public-key encryption is used) using the given gpg options, and then- - read by the Reader action. + - public-key encryption is used), and then read by the Reader action.   -- - Note that the Reader must fully consume gpg's input before returning.+ - Note that the Reader must fully consume all input before returning.  -}-encrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a-encrypt cmd c cipher = case cipher of-	Cipher{} -> Gpg.feedRead cmd (params ++ Gpg.stdEncryptionParams True) $-			cipherPassphrase cipher-	MacOnlyCipher{} -> Gpg.feedRead' cmd $ params ++ Gpg.stdEncryptionParams False+encrypt :: (MonadIO m, MonadMask m, LensEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a+encrypt gpgcmd c cipher feeder reader = case cipher of+	Cipher{} -> +		let passphrase = cipherPassphrase cipher+		in case statelessOpenPGPCommand c of+			Just sopcmd -> withTmpDir "sop" $ \d ->+				SOP.encryptSymmetric sopcmd passphrase+					(SOP.EmptyDirectory d)+					(statelessOpenPGPProfile c)+					(SOP.Armoring False)+					feeder reader+			Nothing -> Gpg.feedRead gpgcmd (params ++ Gpg.stdEncryptionParams True) passphrase feeder reader+	MacOnlyCipher{} -> Gpg.feedRead' gpgcmd (params ++ Gpg.stdEncryptionParams False) feeder reader   where 	params = getGpgEncParams c @@ -215,12 +226,19 @@  - Cipher (or using a private key if the Cipher is empty), and read by the  - Reader action.  -- - Note that the Reader must fully consume gpg's input before returning.+ - Note that the Reader must fully consume all input before returning.  - -}-decrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a-decrypt cmd c cipher = case cipher of-	Cipher{} -> Gpg.feedRead cmd params $ cipherPassphrase cipher-	MacOnlyCipher{} -> Gpg.feedRead' cmd params+decrypt :: (MonadIO m, MonadMask m, LensEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a+decrypt cmd c cipher feeder reader = case cipher of+	Cipher{} -> +		let passphrase = cipherPassphrase cipher+		in case statelessOpenPGPCommand c of+			Just sopcmd -> withTmpDir "sop" $ \d ->+				SOP.decryptSymmetric sopcmd passphrase+					(SOP.EmptyDirectory d)+					feeder reader+			Nothing -> Gpg.feedRead cmd params passphrase feeder reader+	MacOnlyCipher{} -> Gpg.feedRead' cmd params feeder reader   where 	params = Param "--decrypt" : getGpgDecParams c @@ -235,19 +253,26 @@   where 	known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51" -class LensGpgEncParams a where-	{- Base parameters for encrypting. Does not include specification+class LensEncParams a where+	{- Base gpg parameters for encrypting. Does not include specification 	 - of recipient keys. -} 	getGpgEncParamsBase :: a -> [CommandParam]-	{- Parameters for encrypting. When the remote is configured to use+	{- Gpg parameters for encrypting. When the remote is configured to use 	 - public-key encryption, includes specification of recipient keys. -} 	getGpgEncParams :: a -> [CommandParam]-	{- Parameters for decrypting. -}+	{- Gpg parameters for decrypting. -} 	getGpgDecParams :: a -> [CommandParam]+	{- Set when stateless OpenPGP should be used rather than gpg.+	 - It is currently only used for SharedEncryption and not the other+	 - schemes which use public keys. -}+	statelessOpenPGPCommand :: a -> Maybe SOP.SOPCmd+	{- When using stateless OpenPGP, this may be set to a profile+	 - which should be used instead of the default. -}+	statelessOpenPGPProfile :: a -> Maybe SOP.SOPProfile  {- Extract the GnuPG options from a pair of a Remote Config and a Remote  - Git Config. -}-instance LensGpgEncParams (ParsedRemoteConfig, RemoteGitConfig) where+instance LensEncParams (ParsedRemoteConfig, RemoteGitConfig) where 	getGpgEncParamsBase (_c,gc) = map Param (remoteAnnexGnupgOptions gc) 	getGpgEncParams (c,gc) = getGpgEncParamsBase (c,gc) ++  		{- When the remote is configured to use public-key encryption,@@ -261,9 +286,21 @@ 					getRemoteConfigValue pubkeysField c 			_ -> [] 	getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc)+	statelessOpenPGPCommand (c,gc) = case remoteAnnexSharedSOPCommand gc of+		Nothing -> Nothing+		Just sopcmd ->+			{- So far stateless OpenPGP is only supported+			 - for SharedEncryption, not other encryption+			 - methods that involve public keys. -}+			case getRemoteConfigValue encryptionField c of+				Just SharedEncryption -> Just sopcmd+				_ -> Nothing+	statelessOpenPGPProfile (_c,gc) = remoteAnnexSharedSOPProfile gc  {- Extract the GnuPG options from a Remote. -}-instance LensGpgEncParams (RemoteA a) where+instance LensEncParams (RemoteA a) where 	getGpgEncParamsBase r = getGpgEncParamsBase (config r, gitconfig r) 	getGpgEncParams r = getGpgEncParams (config r, gitconfig r) 	getGpgDecParams r = getGpgDecParams (config r, gitconfig r)+	statelessOpenPGPCommand r = statelessOpenPGPCommand (config r, gitconfig r)+	statelessOpenPGPProfile r  = statelessOpenPGPProfile (config r, gitconfig r)

@@ -1,11 +1,12 @@ {- git trees  -- - Copyright 2016-2021 Joey Hess <id@joeyh.name>+ - Copyright 2016-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}  module Git.Tree ( 	Tree(..),@@ -231,7 +232,7 @@ 	withMkTreeHandle repo $ \h -> do 		(l, cleanup) <- liftIO $ lsTreeWithObjects LsTree.LsTreeRecursive r repo 		(l', _, _) <- go h False [] 1 inTopTree l-		l'' <- adjustlist h 0 inTopTree (const True) l'+		l'' <- adjustlist h 0 inTopTree topTreePath l' 		sha <- liftIO $ mkTree h l'' 		void $ liftIO cleanup 		return sha@@ -250,7 +251,7 @@ 						in go h modified (blob:c) depth intree is 			Just TreeObject -> do 				(sl, modified, is') <- go h False [] (depth+1) (beneathSubTree i) is-				sl' <- adjustlist h depth (inTree i) (beneathSubTree i) sl+				sl' <- adjustlist h depth (inTree i) (gitPath i) sl 				let slmodified = sl' /= sl 				subtree <- if modified || slmodified 					then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl'@@ -268,16 +269,22 @@ 			_ -> giveup ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"") 		| otherwise = return (c, wasmodified, i:is) -	adjustlist h depth ishere underhere l = do-		let (addhere, rest) = partition ishere addtreeitems+	adjustlist h depth ishere herepath l = do+		let addhere = fromMaybe [] $ M.lookup herepath addtreeitempathmap 		let l' = filter (not . removed) $ 			addoldnew l (map treeItemToTreeContent addhere) 		let inl i = any (\t -> beneathSubTree t i) l' 		let (Tree addunderhere) = flattenTree depth $ treeItemsToTree $-			filter (\i -> underhere i && not (inl i)) rest+			filter (not . inl) $ if herepath == topTreePath+				then filter (not . ishere) addtreeitems+				else fromMaybe [] $+					M.lookup (subTreePrefix herepath) addtreeitemprefixmap 		addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere 		return (addoldnew l' addunderhere') +	addtreeitempathmap = mkPathMap addtreeitems+	addtreeitemprefixmap = mkSubTreePathPrefixMap addtreeitems+ 	removeset = S.fromList $ map (P.normalise . gitPath) removefiles 	removed (TreeBlob f _ _) = S.member (P.normalise (gitPath f)) removeset 	removed (TreeCommit f _ _) = S.member (P.normalise (gitPath f)) removeset@@ -355,12 +362,8 @@  	subdirs = P.splitDirectories $ gitPath graftloc -	-- For a graftloc of "foo/bar/baz", this generates-	-- ["foo", "foo/bar", "foo/bar/baz"] 	graftdirs = map (asTopFilePath . toInternalGitPath) $-		mkpaths [] subdirs-	mkpaths _ [] = []-	mkpaths base (d:rest) = (P.joinPath base P.</> d) : mkpaths (base ++ [d]) rest+		pathPrefixes subdirs  {- Assumes the list is ordered, with tree objects coming right before their  - contents. -}@@ -413,13 +416,50 @@ 	gitPath (TreeCommit f _ _) = gitPath f  inTopTree :: GitPath t => t -> Bool-inTopTree = inTree "."+inTopTree = inTree topTreePath +topTreePath :: RawFilePath+topTreePath = "."+ inTree :: (GitPath t, GitPath f) => t -> f -> Bool inTree t f = gitPath t == P.takeDirectory (gitPath f)  beneathSubTree :: (GitPath t, GitPath f) => t -> f -> Bool-beneathSubTree t f = prefix `B.isPrefixOf` P.normalise (gitPath f)+beneathSubTree t f = subTreePrefix t `B.isPrefixOf` subTreePath f++subTreePath :: GitPath t => t -> RawFilePath+subTreePath = P.normalise . gitPath++subTreePrefix :: GitPath t => t -> RawFilePath+subTreePrefix t+	| B.null tp = tp+	| otherwise = P.addTrailingPathSeparator (P.normalise tp)   where 	tp = gitPath t-	prefix = if B.null tp then tp else P.addTrailingPathSeparator (P.normalise tp)++{- Makes a Map where the keys are directories, and the values+ - are the items located in that directory.+ -+ - Values that are not in any subdirectory are placed in+ - the topTreePath key.+ -}+mkPathMap :: GitPath t => [t] -> M.Map RawFilePath [t]+mkPathMap l = M.fromListWith (++) $+	map (\ti -> (P.takeDirectory (gitPath ti), [ti])) l++{- Input is eg splitDirectories "foo/bar/baz",+ - for which it will output ["foo", "foo/bar", "foo/bar/baz"] -}+pathPrefixes :: [RawFilePath] -> [RawFilePath]+pathPrefixes = go []+  where+	go _ [] = []+	go base (d:rest) = (P.joinPath base P.</> d) : go (base ++ [d]) rest++{- Makes a Map where the keys are all subtree path prefixes, + - and the values are items with that subtree path prefix.+ -}+mkSubTreePathPrefixMap :: GitPath t => [t] -> M.Map RawFilePath [t]+mkSubTreePathPrefixMap l = M.fromListWith (++) $ concatMap go l+  where+	go ti = map (\p -> (p, [ti]))+		(map subTreePrefix $ pathPrefixes $ P.splitDirectories $ subTreePath ti)

@@ -330,6 +330,22 @@ 				then return False 				else inAnnex key +{- Limit to content that location tracking expects to be present+ - in the current repository. Does not verify inAnnex. -}+addExpectedPresent :: Annex ()+addExpectedPresent = do+	hereu <- getUUID+	addLimit $ Right $ MatchFiles+		{ matchAction = const $ checkKey $ \key -> do+			us <- Remote.keyLocations key+			return $ hereu `elem` us+		, matchNeedsFileName = False+		, matchNeedsFileContent = False+		, matchNeedsKey = True+		, matchNeedsLocationLog = True+		, matchDesc = matchDescSimple "expected-present"+		}+ {- Limit to content that is currently present on a uuid. -} limitPresent :: Maybe UUID -> MatchFiles Annex limitPresent u = MatchFiles

@@ -171,7 +171,7 @@ 	minratelimit = min consoleratelimit jsonratelimit 		 {- Poll file size to display meter. -}-meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a+meteredFile :: RawFilePath -> Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a meteredFile file combinemeterupdate key a =  	metered combinemeterupdate key Nothing $ \_ p -> 		watchFileSize file p a

@@ -64,7 +64,7 @@ 		let fallback = runner (sender mempty (return Invalid)) 		v <- tryNonAsync $ prepSendAnnex k 		case v of-			Right (Just (f, checkchanged)) -> proceed $ do+			Right (Just (f, _sz, checkchanged)) -> proceed $ do 				-- alwaysUpload to allow multiple uploads of the same key. 				let runtransfer ti = transfer alwaysUpload k af Nothing $ \p -> 					sinkfile f o checkchanged sender p ti@@ -79,7 +79,7 @@ 			iv <- startVerifyKeyContentIncrementally DefaultVerify k 			let runtransfer ti =  				Right <$> transfer download' k af Nothing (\p ->-					logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp ->+					logStatusAfter k $ getViaTmp rsp DefaultVerify k af Nothing $ \tmp -> 						storefile (fromRawFilePath tmp) o l getb iv validitycheck p ti) 			let fallback = return $ Left $ 				ProtoFailureMessage "transfer already in progress, or unable to take transfer lock"

@@ -228,7 +228,7 @@ 		(\a b -> deviceID a == deviceID b) 			<$> R.getSymbolicLinkStatus d 			<*> R.getSymbolicLinkStatus annexdir-	checkDiskSpace (Just d) k 0 samefilesystem+	checkDiskSpace Nothing (Just d) k 0 samefilesystem  {- Passed a temp directory that contains the files that should be placed  - in the dest directory, moves it into place. Anything already existing

@@ -235,7 +235,7 @@  retrieveKeyFileM :: External -> Retriever retrieveKeyFileM external = fileRetriever $ \d k p ->-	either giveup return =<< go d k p+	either giveup return =<< watchFileSize d p (go d k)   where 	go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromRawFilePath d)) k (Just p) $ \resp -> 		case resp of

@@ -484,10 +484,11 @@ 	| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $ do 		u <- getUUID 		hardlink <- wantHardLink-		let bwlimit = remoteAnnexBwLimit (gitconfig r)+		let bwlimit = remoteAnnexBwLimitDownload (gitconfig r)+			<|> remoteAnnexBwLimit (gitconfig r) 		-- run copy from perspective of remote 		onLocalFast st $ Annex.Content.prepSendAnnex' key >>= \case-			Just (object, check) -> do+			Just (object, _sz, check) -> do 				let checksuccess = check >>= \case 					Just err -> giveup err 					Nothing -> return True@@ -545,14 +546,15 @@ 	| otherwise = giveup "copying to non-ssh repo not supported"   where 	copylocal Nothing = giveup "content not available"-	copylocal (Just (object, check)) = do+	copylocal (Just (object, sz, check)) = do 		-- The check action is going to be run in 		-- the remote's Annex, but it needs access to the local 		-- Annex monad's state. 		checkio <- Annex.withCurrentState check 		u <- getUUID 		hardlink <- wantHardLink-		let bwlimit = remoteAnnexBwLimit (gitconfig r)+		let bwlimit = remoteAnnexBwLimitUpload (gitconfig r)+			<|> remoteAnnexBwLimit (gitconfig r) 		-- run copy from perspective of remote 		res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) 			( return True@@ -563,7 +565,7 @@ 				let checksuccess = liftIO checkio >>= \case 					Just err -> giveup err 					Nothing -> return True-				logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest ->+				logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file (Just sz) $ \dest -> 					metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' ->  						copier object (fromRawFilePath dest) key p' checksuccess verify 			)

@@ -115,7 +115,7 @@  - writes a whole L.ByteString at a time.  -} storeChunks-	:: LensGpgEncParams encc+	:: LensEncParams encc 	=> UUID 	-> ChunkConfig 	-> EncKey@@ -159,9 +159,9 @@ 				-- stored, update the chunk log. 				chunksStored u k (FixedSizeChunks chunksize) numchunks 			| otherwise = do-				liftIO $ meterupdate' zeroBytesProcessed 				let (chunkkey, chunkkeys') = nextChunkKeyStream chunkkeys 				storechunk chunkkey (ByteContent chunk) meterupdate'+				liftIO $ meterupdate' zeroBytesProcessed 				let bytesprocessed' = addBytesProcessed bytesprocessed (L.length chunk) 				loop bytesprocessed' (splitchunk bs) chunkkeys' 		  where@@ -250,7 +250,7 @@  - Handles decrypting the content when encryption is used.  -} retrieveChunks -	:: LensGpgEncParams encc+	:: LensEncParams encc 	=> Retriever 	-> UUID 	-> VerifyConfig@@ -391,7 +391,7 @@  - into place. (And it may even already be in the right place..)  -} writeRetrievedContent-	:: LensGpgEncParams encc+	:: LensEncParams encc 	=> FilePath 	-> Maybe (Cipher, EncKey) 	-> encc

@@ -158,18 +158,18 @@ encryptionSetup :: RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, EncryptionIsSetup) encryptionSetup c gc = do 	pc <- either giveup return $ parseEncryptionConfig c-	cmd <- gpgCmd <$> Annex.getGitConfig-	maybe (genCipher pc cmd) (updateCipher pc cmd) (extractCipher pc)+	gpgcmd <- gpgCmd <$> Annex.getGitConfig+	maybe (genCipher pc gpgcmd) (updateCipher pc gpgcmd) (extractCipher pc)   where 	-- The type of encryption 	encryption = parseEncryptionMethod (fromProposedAccepted <$> M.lookup encryptionField c) c 	-- Generate a new cipher, depending on the chosen encryption scheme-	genCipher pc cmd = case encryption of+	genCipher pc gpgcmd = case encryption of 		Right NoneEncryption -> return (c, NoEncryption)-		Right SharedEncryption -> encsetup $ genSharedCipher cmd-		Right HybridEncryption -> encsetup $ genEncryptedCipher cmd (pc, gc) key Hybrid-		Right PubKeyEncryption -> encsetup $ genEncryptedCipher cmd (pc, gc) key PubKey-		Right SharedPubKeyEncryption -> encsetup $ genSharedPubKeyCipher cmd key+		Right SharedEncryption -> encsetup $ genSharedCipher gpgcmd+		Right HybridEncryption -> encsetup $ genEncryptedCipher gpgcmd (pc, gc) key Hybrid+		Right PubKeyEncryption -> encsetup $ genEncryptedCipher gpgcmd (pc, gc) key PubKey+		Right SharedPubKeyEncryption -> encsetup $ genSharedPubKeyCipher gpgcmd key 		Left err -> giveup err 	key = maybe (giveup "Specify keyid=...") fromProposedAccepted $ 		M.lookup (Accepted "keyid") c@@ -177,13 +177,13 @@ 		maybe [] (\k -> [(False,fromProposedAccepted k)]) (M.lookup (Accepted "keyid-") c) 	cannotchange = giveup "Cannot set encryption type of existing remotes." 	-- Update an existing cipher if possible.-	updateCipher pc cmd v = case v of+	updateCipher pc gpgcmd v = case v of 		SharedCipher _ | encryption == Right SharedEncryption -> 			return (c', EncryptionIsSetup) 		EncryptedCipher _ variant _ | sameasencryption variant ->-			use "encryption update" $ updateCipherKeyIds cmd (pc, gc) newkeys v+			use "encryption update" $ updateCipherKeyIds gpgcmd (pc, gc) newkeys v 		SharedPubKeyCipher _ _ ->-			use "encryption update" $ updateCipherKeyIds cmd (pc, gc) newkeys v+			use "encryption update" $ updateCipherKeyIds gpgcmd (pc, gc) newkeys v 		_ -> cannotchange 	sameasencryption variant = case encryption of 		Right HybridEncryption -> variant == Hybrid@@ -236,8 +236,8 @@ 				(go cachev encipher)   where 	go cachev encipher cache = do-		cmd <- gpgCmd <$> Annex.getGitConfig-		cipher <- liftIO $ decryptCipher cmd (c, gc) encipher+		gpgcmd <- gpgCmd <$> Annex.getGitConfig+		cipher <- liftIO $ decryptCipher gpgcmd (c, gc) encipher 		liftIO $ atomically $ putTMVar cachev $ 			M.insert encipher cipher cache 		return $ Just (cipher, encipher)

@@ -16,6 +16,7 @@ import Annex.Content import Messages.Progress import Utility.Metered+import Utility.Tuple import Types.NumCopies import Annex.Verify @@ -33,8 +34,8 @@  store :: RemoteGitConfig -> ProtoRunner Bool -> Key -> AssociatedFile -> MeterUpdate -> Annex () store gc runner k af p = do-	let sizer = KeySizer k (fmap (toRawFilePath . fst) <$> prepSendAnnex k)-	let bwlimit = remoteAnnexBwLimit gc+	let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k)+	let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc 	metered (Just p) sizer bwlimit $ \_ p' -> 		runner (P2P.put k af p') >>= \case 			Just True -> return ()@@ -44,7 +45,7 @@ retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieve gc runner k af dest p verifyconfig = do 	iv <- startVerifyKeyContentIncrementally verifyconfig k-	let bwlimit = remoteAnnexBwLimit gc+	let bwlimit = remoteAnnexBwLimitDownload gc <|> remoteAnnexBwLimit gc 	metered (Just p) k bwlimit $ \m p' ->  		runner (P2P.get dest k iv af m p') >>= \case 			Just (True, v) -> return v

@@ -212,9 +212,9 @@ 			then whereisKey baser 			else Nothing 		, exportActions = (exportActions baser)-			{ storeExport = \f k l p -> displayprogress p k (Just f) $+			{ storeExport = \f k l p -> displayprogress uploadbwlimit p k (Just f) $ 				storeExport (exportActions baser) f k l-			, retrieveExport = \k l f p -> displayprogress p k Nothing $+			, retrieveExport = \k l f p -> displayprogress downloadbwlimit p k Nothing $ 				retrieveExport (exportActions baser) k l f 			} 		}@@ -222,8 +222,8 @@ 	isencrypted = isEncrypted c  	-- chunk, then encrypt, then feed to the storer-	storeKeyGen k p enc = sendAnnex k rollback $ \src ->-		displayprogress p k (Just src) $ \p' ->+	storeKeyGen k p enc = sendAnnex k rollback $ \src _sz ->+		displayprogress uploadbwlimit p k (Just src) $ \p' -> 			storeChunks (uuid baser) chunkconfig enck k src p' 				enc encr storer checkpresent 	  where@@ -232,7 +232,7 @@  	-- call retriever to get chunks; decrypt them; stream to dest file 	retrieveKeyFileGen k dest p vc enc =-		displayprogress p k Nothing $ \p' ->+		displayprogress downloadbwlimit p k Nothing $ \p' -> 			retrieveChunks retriever (uuid baser) vc 				chunkconfig enck k dest p' enc encr 	  where@@ -250,9 +250,13 @@  	chunkconfig = chunkConfig cfg -	displayprogress p k srcfile a+	downloadbwlimit = remoteAnnexBwLimitDownload (gitconfig baser)+		<|> remoteAnnexBwLimit (gitconfig baser)+	uploadbwlimit = remoteAnnexBwLimitUpload (gitconfig baser)+		<|> remoteAnnexBwLimit (gitconfig baser)++	displayprogress bwlimit p k srcfile a 		| displayProgress cfg = do-			let bwlimit = remoteAnnexBwLimit (gitconfig baser) 			metered (Just p) (KeySizer k (pure (fmap toRawFilePath srcfile))) bwlimit (const a) 		| otherwise = a p 

@@ -139,7 +139,7 @@ 	missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use."  store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex ()-store rs hdl k _f _p = sendAnnex k noop $ \src ->+store rs hdl k _f _p = sendAnnex k noop $ \src _sz -> 	parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe 		(giveup "tahoe failed to store content") 		(\cap -> storeCapability rs k cap)

@@ -27,6 +27,7 @@ import Common import CmdLine.GitAnnex.Options import qualified Utility.RawFilePath as R+import Data.String  import qualified Utility.ShellEscape import qualified Annex@@ -82,6 +83,7 @@ import qualified Utility.Aeson import qualified Utility.CopyFile import qualified Utility.MoveFile+import qualified Utility.StatelessOpenPGP import qualified Types.Remote #ifndef mingw32_HOST_OS import qualified Remote.Helper.Encryptable@@ -347,7 +349,8 @@ 	, testCase "rsync remote" test_rsync_remote 	, testCase "bup remote" test_bup_remote 	, testCase "borg remote" test_borg_remote-	, testCase "crypto" test_crypto+	, testCase "gpg crypto" test_gpg_crypto+	, testCase "sop crypto" test_sop_crypto 	, testCase "preferred content" test_preferred_content 	, testCase "required_content" test_required_content 	, testCase "add subdirs" test_add_subdirs@@ -1824,10 +1827,29 @@ 		git_annex "drop" [annexedfile] "drop from borg (appendonly)" 		git_annex "get" [annexedfile, "--from=borg"] "get from borg" +-- To test Stateless OpenPGP, annex.shared-sop-command has to be set using+-- the --test-git-config option.+test_sop_crypto :: Assertion+test_sop_crypto = do+	gc <- testGitConfig . testOptions <$> getTestMode+	case filter (\(k, _) -> k == ck) gc of+		[] -> noop+		((_, sopcmd):_) -> go $ +			Utility.StatelessOpenPGP.SOPCmd $+				Git.Types.fromConfigValue sopcmd+  where+	ck = fromString "annex.shared-sop-command"+	pw = fromString "testpassword"+	v = fromString "somevalue"+	unarmored = Utility.StatelessOpenPGP.Armoring False+	go sopcmd = do+		Utility.StatelessOpenPGP.test_encrypt_decrypt_Symmetric sopcmd sopcmd pw unarmored v+			@? "sop command roundtrips symmetric encryption"+ -- gpg is not a build dependency, so only test when it's available-test_crypto :: Assertion+test_gpg_crypto :: Assertion #ifndef mingw32_HOST_OS-test_crypto = do+test_gpg_crypto = do 	testscheme "shared" 	testscheme "hybrid" 	testscheme "pubkey"@@ -1919,7 +1941,7 @@ 			Annex.Locations.keyPaths . 			Crypto.encryptKey Types.Crypto.HmacSha1 cipher #else-test_crypto = putStrLn "gpg testing not implemented on Windows"+test_gpg_crypto = putStrLn "gpg testing not implemented on Windows" #endif  test_add_subdirs :: Assertion

@@ -35,6 +35,7 @@ 	| HybridEncryption 	deriving (Typeable, Eq) +-- A base-64 encoded random value used for encryption. -- XXX ideally, this would be a locked memory region data Cipher = Cipher ByteString | MacOnlyCipher ByteString 

@@ -1,6 +1,6 @@ {- git-annex configuration  -- - Copyright 2012-2021 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -47,8 +47,10 @@ import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd)+import Utility.StatelessOpenPGP (SOPCmd(..), SOPProfile(..)) import Utility.ThreadScheduler (Seconds(..)) import Utility.Url (Scheme, mkScheme)+import Network.Socket (PortNumber)  import Control.Concurrent.STM import qualified Data.Set as S@@ -114,6 +116,7 @@ 	, annexSecureEraseCommand :: Maybe String 	, annexGenMetaData :: Bool 	, annexListen :: Maybe String+	, annexPort :: Maybe PortNumber 	, annexStartupScan :: Bool 	, annexHardLink :: Bool 	, annexThin :: Bool@@ -209,6 +212,7 @@ 	, annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command") 	, annexGenMetaData = getbool (annexConfig "genmetadata") False 	, annexListen = getmaybe (annexConfig "listen")+	, annexPort = getmayberead (annexConfig "port") 	, annexStartupScan = getbool (annexConfig "startupscan") True 	, annexHardLink = getbool (annexConfig "hardlink") False 	, annexThin = getbool (annexConfig "thin") False@@ -358,7 +362,11 @@ 	, remoteAnnexForwardRetry :: Maybe Integer 	, remoteAnnexRetryDelay :: Maybe Seconds 	, remoteAnnexStallDetection :: Maybe StallDetection+	, remoteAnnexStallDetectionUpload :: Maybe StallDetection+	, remoteAnnexStallDetectionDownload :: Maybe StallDetection 	, remoteAnnexBwLimit :: Maybe BwRate+	, remoteAnnexBwLimitUpload :: Maybe BwRate+	, remoteAnnexBwLimitDownload :: Maybe BwRate 	, remoteAnnexAllowUnverifiedDownloads :: Bool 	, remoteAnnexConfigUUID :: Maybe UUID @@ -372,6 +380,8 @@ 	, remoteAnnexRsyncTransport :: [String] 	, remoteAnnexGnupgOptions :: [String] 	, remoteAnnexGnupgDecryptOptions :: [String]+	, remoteAnnexSharedSOPCommand :: Maybe SOPCmd+	, remoteAnnexSharedSOPProfile :: Maybe SOPProfile 	, remoteAnnexRsyncUrl :: Maybe String 	, remoteAnnexBupRepo :: Maybe String 	, remoteAnnexBorgRepo :: Maybe String@@ -423,11 +433,17 @@ 		, remoteAnnexRetryDelay = Seconds 			<$> getmayberead "retrydelay" 		, remoteAnnexStallDetection =-			either (const Nothing) Just . parseStallDetection-				=<< getmaybe "stalldetection"-		, remoteAnnexBwLimit = do-			sz <- readSize dataUnits =<< getmaybe "bwlimit"-			return (BwRate sz (Duration 1))+			readStallDetection =<< getmaybe "stalldetection"+		, remoteAnnexStallDetectionUpload =+			readStallDetection =<< getmaybe "stalldetection-upload"+		, remoteAnnexStallDetectionDownload =+			readStallDetection =<< getmaybe "stalldetection-download"+		, remoteAnnexBwLimit =+			readBwRatePerSecond =<< getmaybe "bwlimit"+		, remoteAnnexBwLimitUpload =+			readBwRatePerSecond =<< getmaybe "bwlimit-upload"+		, remoteAnnexBwLimitDownload =+			readBwRatePerSecond =<< getmaybe "bwlimit-download" 		, remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ 			getmaybe ("security-allow-unverified-downloads") 		, remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid"@@ -439,6 +455,10 @@ 		, remoteAnnexRsyncTransport = getoptions "rsync-transport" 		, remoteAnnexGnupgOptions = getoptions "gnupg-options" 		, remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options"+		, remoteAnnexSharedSOPCommand = SOPCmd <$>+			notempty (getmaybe "shared-sop-command")+		, remoteAnnexSharedSOPProfile = SOPProfile <$>+			notempty (getmaybe "shared-sop-profile") 		, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl" 		, remoteAnnexBupRepo = getmaybe "buprepo" 		, remoteAnnexBorgRepo = getmaybe "borgrepo"

@@ -1,6 +1,6 @@ {- types for stall detection and banwdith rates  -- - Copyright 2020-2021 Joey Hess <id@joeyh.name>+ - Copyright 2020-2024 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -39,6 +39,9 @@ 	Just True -> Right ProbeStallDetection 	Just False -> Right StallDetectionDisabled +readStallDetection :: String -> Maybe StallDetection+readStallDetection = either (const Nothing) Just . parseStallDetection+ parseBwRate :: String -> Either String BwRate parseBwRate s = do 	let (bs, ds) = separate (== '/') s@@ -48,3 +51,8 @@ 		(readSize dataUnits bs) 	d <- parseDuration ds 	Right (BwRate b d)++readBwRatePerSecond :: String -> Maybe BwRate+readBwRatePerSecond s = do+	sz <- readSize dataUnits s+	return (BwRate sz (Duration 1))

@@ -23,8 +23,6 @@ 	findPubKeys, 	UserId, 	secretKeys,-	KeyType(..),-	maxRecommendedKeySize, 	genSecretKey, 	genRandom, 	testKeyId,@@ -60,6 +58,8 @@  newtype GpgCmd = GpgCmd { unGpgCmd :: String } +type Passphrase = B.ByteString+ {- Get gpg command to use, Just what's specified or, if a specific gpg  - command was found at configure time, use it, or otherwise, "gpg". -} mkGpgCmd :: Maybe FilePath -> GpgCmd@@ -147,8 +147,8 @@ 		forceSuccessProcess p pid `after` B.hGetContents from 	go _ _ _ _ _ = error "internal" -{- Runs gpg with some parameters. First sends it a passphrase (unless it- - is empty) via '--passphrase-fd'. Then runs a feeder action that is+{- Runs gpg with some parameters. First sends it a passphrase via+ - '--passphrase-fd'. Then runs a feeder action that is  - passed a handle and should write to it all the data to input to gpg.  - Finally, runs a reader action that is passed a handle to gpg's  - output.@@ -157,12 +157,13 @@  - the passphrase.  -  - Note that the reader must fully consume gpg's input before returning. -}-feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> B.ByteString -> (Handle -> IO ()) -> (Handle -> m a) -> m a+feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> Passphrase -> (Handle -> IO ()) -> (Handle -> m a) -> m a feedRead cmd params passphrase feeder reader = do #ifndef mingw32_HOST_OS 	let setup = liftIO $ do 		-- pipe the passphrase into gpg on a fd 		(frompipe, topipe) <- System.Posix.IO.createPipe+		setFdOption topipe CloseOnExec True 		toh <- fdToHandle topipe 		t <- async $ do 			B.hPutStr toh (passphrase <> "\n")@@ -260,49 +261,29 @@ 	extract c k (_:rest) = 		extract c k rest -type Passphrase = String-type Size = Int-data KeyType = Algo Int | DSA | RSA--{- The maximum key size that gpg currently offers in its UI when- - making keys. -}-maxRecommendedKeySize :: Size-maxRecommendedKeySize = 4096--{- Generates a secret key using the experimental batch mode.+{- Generates a secret key.  - The key is added to the secret key ring.  - Can take a very long time, depending on system entropy levels.  -}-genSecretKey :: GpgCmd -> KeyType -> Passphrase -> UserId -> Size -> IO ()-genSecretKey (GpgCmd cmd) keytype passphrase userid keysize =-	let p = (proc cmd params)-		{ std_in = CreatePipe }-	in withCreateProcess p (go p)+genSecretKey :: GpgCmd -> Passphrase -> UserId -> IO ()+genSecretKey gpgcmd passphrase userid =+	feedRead gpgcmd params passphrase feeder reader   where-	params = ["--batch", "--gen-key"]--	go p (Just h) _ _ pid = do-		hPutStr h $ unlines $ catMaybes-			[ Just $  "Key-Type: " ++ -				case keytype of-					DSA -> "DSA"-					RSA -> "RSA"-					Algo n -> show n-			, Just $ "Key-Length: " ++ show keysize-			, Just $ "Name-Real: " ++ userid-			, Just "Expire-Date: 0"-			, if null passphrase-				then Nothing-				else Just $ "Passphrase: " ++ passphrase-			]-		hClose h-		forceSuccessProcess p pid-	go _ _ _ _ _ = error "internal"+	params =+		[ Param "--batch"+		, Param "--quick-gen-key"+		, Param userid+		, Param "default" -- algo+		, Param "default" -- usage+		, Param "never" -- expire+		]+	feeder = hClose+	reader = void . hGetContents  {- Creates a block of high-quality random data suitable to use as a cipher.  - It is armored, to avoid newlines, since gpg only reads ciphers up to the  - first newline. -}-genRandom :: GpgCmd -> Bool -> Size -> IO B.ByteString+genRandom :: GpgCmd -> Bool -> Int -> IO B.ByteString genRandom cmd highQuality size = do 	s <- readStrict cmd params 	checksize s

@@ -1,6 +1,6 @@ {- Metered IO and actions  -- - Copyright 2012-2021 Joey Hess <id@joeyh.name>+ - Copyright 2012-2024 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -218,22 +218,47 @@  - away and start over. To avoid reporting the original file size followed  - by a smaller size in that case, wait until the file starts growing  - before updating the meter for the first time.+ -+ - An updated version of the MeterUpdate is passed to the action, and the+ - action should use that for any updates that it makes. This allows for+ - eg, the action updating the meter before a write is flushed to the file.+ - In that situation, this avoids the meter being set back to the size of+ - the file when it's gotten ahead of that point.  -}-watchFileSize :: (MonadIO m, MonadMask m) => FilePath -> MeterUpdate -> m a -> m a-watchFileSize f p a = bracket -	(liftIO $ forkIO $ watcher =<< getsz)-	(liftIO . void . tryIO . killThread)-	(const a)+watchFileSize+	:: (MonadIO m, MonadMask m)+	=> RawFilePath+	-> MeterUpdate+	-> (MeterUpdate -> m a)+	-> m a+watchFileSize f p a = do+	sizevar <- liftIO $ newMVar zeroBytesProcessed+	bracket +		(liftIO $ forkIO $ watcher (meterupdate sizevar True) =<< getsz)+		(liftIO . void . tryIO . killThread)+		(const (a (meterupdate sizevar False)))   where-	watcher oldsz = do+	watcher p' oldsz = do 		threadDelay 500000 -- 0.5 seconds 		sz <- getsz 		when (sz > oldsz) $-			p sz-		watcher sz+			p' sz+		watcher p' sz 	getsz = catchDefaultIO zeroBytesProcessed $-		toBytesProcessed <$> getFileSize f'-	f' = toRawFilePath f+		toBytesProcessed <$> getFileSize f++	meterupdate sizevar preventbacktracking n+		| preventbacktracking = do+			old <- takeMVar sizevar+			if old > n+				then putMVar sizevar old+				else do+					putMVar sizevar n+					p n+		| otherwise = do+			void $ takeMVar sizevar+			putMVar sizevar n+			p n  data OutputHandler = OutputHandler 	{ quietMode :: Bool

@@ -0,0 +1,202 @@+{- Stateless OpenPGP interface+ -+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP, OverloadedStrings #-}++module Utility.StatelessOpenPGP (+	SOPCmd(..),+	SOPSubCmd,+	SOPProfile(..),+	Password,+	EmptyDirectory(..),+	Armoring(..),+	encryptSymmetric,+	decryptSymmetric,+	test_encrypt_decrypt_Symmetric,+	feedRead,+	feedRead',+) where++import Common+#ifndef mingw32_HOST_OS+import System.Posix.Types+import System.Posix.IO+#else+import Utility.Tmp+#endif+import Utility.Tmp.Dir++import Control.Concurrent.Async+import Control.Monad.IO.Class+import qualified Data.ByteString as B++{- The command to run, eq sqop. -}+newtype SOPCmd = SOPCmd { unSOPCmd :: String }++{- The subcommand to run eg encrypt. -}+type SOPSubCmd = String++newtype SOPProfile = SOPProfile String++{- Note that SOP requires passwords to be UTF-8 encoded, and that they+ - may try to trim trailing whitespace. They may also forbid leading+ - whitespace, or forbid some non-printing characters. -}+type Password = B.ByteString++newtype Armoring = Armoring Bool++{- The path to a sufficiently empty directory.+ -+ - This is unfortunately needed because of an infelicity in the SOP+ - standard, as documented in section 9.9 "Be Careful with Special+ - Designators", when using "@FD:" and similar designators the SOP+ - command may test for the presense of a file with the same name on the+ - filesystem, and fail with  AMBIGUOUS_INPUT. + -+ - Since we don't want to need to deal with such random failure due to+ - whatever filename might be present, when running sop commands using+ - special designators, an empty directory has to be provided, and the+ - command is run in that directory. Of course, this necessarily means+ - that any relative paths passed to the command have to be made absolute.+ -+ - The directory does not really have to be empty, it just needs to be one+ - that should not contain any files with names starting with "@".+ -}+newtype EmptyDirectory = EmptyDirectory FilePath++{- Encrypt using symmetric encryption with the specified password. -}+encryptSymmetric+	:: (MonadIO m, MonadMask m)+	=> SOPCmd+	-> Password+	-> EmptyDirectory+	-> Maybe SOPProfile+	-> Armoring+	-> (Handle -> IO ())+	-> (Handle -> m a)+	-> m a+encryptSymmetric sopcmd password emptydirectory mprofile armoring feeder reader =+	feedRead sopcmd "encrypt" params password emptydirectory feeder reader+  where+	params = map Param $ catMaybes+		[ case armoring of+			Armoring False -> Just "--no-armor"+			Armoring True -> Nothing+		, Just "--as=binary"+		, case mprofile of+			Just (SOPProfile profile) -> +				Just $ "--profile=" ++ profile+			Nothing -> Nothing+		]++{- Deccrypt using symmetric encryption with the specified password. -}+decryptSymmetric+	:: (MonadIO m, MonadMask m)+	=> SOPCmd+	-> Password+	-> EmptyDirectory+	-> (Handle -> IO ())+	-> (Handle -> m a)+	-> m a+decryptSymmetric sopcmd password emptydirectory feeder reader =+	feedRead sopcmd "decrypt" [] password emptydirectory feeder reader++{- Test a value round-trips through symmetric encryption and decryption. -}+test_encrypt_decrypt_Symmetric :: SOPCmd -> SOPCmd -> Password -> Armoring -> B.ByteString -> IO Bool+test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $+	withTmpDir "test" $ \d -> do+		let ed = EmptyDirectory d+		enc <- encryptSymmetric a password ed Nothing armoring+			(`B.hPutStr` v) B.hGetContents+		dec <- decryptSymmetric b password ed+			(`B.hPutStr` enc) B.hGetContents+		return (v == dec)++{- Runs a SOP command with some parameters. First sends it a password+ - via '--with-password'. Then runs a feeder action that is+ - passed a handle and should write to it all the data to input to the+ - command. Finally, runs a reader action that is passed a handle to+ - the command's output.+ -+ - Note that the reader must fully consume its input before returning. -}+feedRead+	:: (MonadIO m, MonadMask m)+	=> SOPCmd+	-> SOPSubCmd+	-> [CommandParam]+	-> Password+	-> EmptyDirectory+	-> (Handle -> IO ())+	-> (Handle -> m a)+	-> m a+feedRead cmd subcmd params password emptydirectory feeder reader = do+#ifndef mingw32_HOST_OS+	let setup = liftIO $ do+		-- pipe the passphrase in on a fd+		(frompipe, topipe) <- System.Posix.IO.createPipe+		setFdOption topipe CloseOnExec True+		toh <- fdToHandle topipe+		t <- async $ do+			B.hPutStr toh (password <> "\n")+			hClose toh+		let Fd pfd = frompipe+		let passwordfd = [Param $ "--with-password=@FD:"++show pfd]+		return (passwordfd, frompipe, toh, t)+	let cleanup (_, frompipe, toh, t) = liftIO $ do+		closeFd frompipe+		hClose toh+		cancel t+	bracket setup cleanup $ \(passwordfd, _, _, _) ->+		go (Just emptydirectory) (passwordfd ++ params)+#else+	-- store the password in a temp file+	withTmpFile "sop" $ \tmpfile h -> do+		liftIO $ B.hPutStr h password+		liftIO $ hClose h+		let passwordfile = [Param $ "--with-password="++tmpfile]+		-- Don't need to pass emptydirectory since @FD is not used,+		-- and so tmpfile also does not need to be made absolute.+		case emptydirectory of+			EmptyDirectory _ -> return ()+		go Nothing $ passwordfile ++ params+#endif+  where+	go med params' = feedRead' cmd subcmd params' med feeder reader++{- Like feedRead, but without password. -}+feedRead'+	:: (MonadIO m, MonadMask m)+	=> SOPCmd+	-> SOPSubCmd+	-> [CommandParam]+	-> Maybe EmptyDirectory+	-> (Handle -> IO ())+	-> (Handle -> m a)+	-> m a+feedRead' (SOPCmd cmd) subcmd params med feeder reader = do+	let p = (proc cmd (subcmd:toCommand params))+		{ std_in = CreatePipe+		, std_out = CreatePipe+		, std_err = Inherit+		, cwd = case med of+			Just (EmptyDirectory d) -> Just d+			Nothing -> Nothing+		}+	bracket (setup p) cleanup (go p)+  where+	setup = liftIO . createProcess+	cleanup = liftIO . cleanupProcess++	go p (Just to, Just from, _, pid) =+		let runfeeder = do+			feeder to+			hClose to+		in bracketIO (async runfeeder) cancel $ const $ do+			r <- reader from+			liftIO $ forceSuccessProcess p pid+			return r+	go _ _ = error "internal"

@@ -58,9 +58,9 @@  - An IO action can also be run, to do something with the address,  - such as start a web browser to view the webapp.  -}-runWebApp :: Maybe TLSSettings -> Maybe HostName -> Wai.Application -> (SockAddr -> IO ()) -> IO ()-runWebApp tlssettings h app observer = withSocketsDo $ do-	sock <- getSocket h+runWebApp :: Maybe TLSSettings -> Maybe HostName -> Maybe PortNumber -> Wai.Application -> (SockAddr -> IO ()) -> IO ()+runWebApp tlssettings h p app observer = withSocketsDo $ do+	sock <- getSocket h p 	void $ forkIO $ go webAppSettings sock app	 	sockaddr <- getSocketName sock 	observer sockaddr@@ -74,14 +74,13 @@ 	halfhour = 30 * 60  {- Binds to a local socket, or if specified, to a socket on the specified- - hostname or address. Selects any free port, unless the hostname ends with- - ":port"+ - hostname or address. Selects any free port, unless a port is specified.  -  - Prefers to bind to the ipv4 address rather than the ipv6 address  - of localhost, if it's available.  -}-getSocket :: Maybe HostName -> IO Socket-getSocket h = do+getSocket :: Maybe HostName -> Maybe PortNumber -> IO Socket+getSocket h p = do #if defined (mingw32_HOST_OS) 	-- The HostName is ignored by this code. 	-- getAddrInfo didn't used to work on windows; current status@@ -91,11 +90,11 @@ 	let addr = tupleToHostAddress (127,0,0,1) 	sock <- socket AF_INET Stream defaultProtocol 	preparesocket sock-	bind sock (SockAddrInet defaultPort addr)+	bind sock (SockAddrInet (fromMaybe defaultPort p) addr) 	use sock   where #else-	addrs <- getAddrInfo (Just hints) (Just hostname) Nothing+	addrs <- getAddrInfo (Just hints) (Just hostname) (fmap show p) 	case (partition (\a -> addrFamily a == AF_INET) addrs) of 		(v4addr:_, _) -> go v4addr 		(_, v6addr:_) -> go v6addr

@@ -1,11 +1,11 @@ Name: git-annex-Version: 10.20231227+Version: 10.20240129 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess Stability: Stable-Copyright: 2010-2023 Joey Hess+Copyright: 2010-2024 Joey Hess License-File: COPYRIGHT Homepage: http://git-annex.branchable.com/ Build-type: Custom@@ -1060,6 +1060,7 @@     Utility.Split     Utility.SshConfig     Utility.SshHost+    Utility.StatelessOpenPGP     Utility.Su     Utility.SystemDirectory     Utility.Terminal

@@ -5,7 +5,7 @@         <div .modal-header>           <h3>             <img src="@{StaticR activityicon_gif}" alt=""> #-            Generating a #{maxRecommendedKeySize} bit GnuPg key.+            Generating a GnuPg key.         <div .modal-body>         <p>           Generating a GnuPg key can take a long time. To speed up the process, #