git-annex 10.20230626 → 10.20230802

raw patch · 74 files changed

+967/−402 lines, 74 filesdep −connectiondep ~unix-compatsetup-changed

Dependencies removed: connection

Dependency ranges changed: unix-compat

Files

• Annex.hs +2/−0
• Annex/AdjustedBranch.hs +18/−12
• Annex/AdjustedBranch/Merge.hs +14/−12
• Annex/Debug.hs +7/−3
• Annex/FileMatcher.hs +39/−26
• Annex/Import.hs +6/−5
• Annex/Init.hs +3/−0
• Annex/Link.hs +10/−8
• Annex/NumCopies.hs +12/−7
• Annex/YoutubeDl.hs +1/−1
• Assistant/Sync.hs +3/−3
• Assistant/Threads/Merger.hs +1/−1
• Assistant/WebApp/Configurators/Local.hs +2/−1
• Build/DesktopFile.hs +1/−1
• Build/mdwn2man +1/−0
• CHANGELOG +46/−2
• COPYRIGHT +1/−1
• CmdLine/GitAnnex.hs +2/−0
• CmdLine/GitAnnex/Options.hs +8/−3
• CmdLine/Option.hs +9/−0
• Command/Assist.hs +2/−2
• Command/DiffDriver.hs +39/−11
• Command/Drop.hs +2/−1
• Command/DropUnused.hs +2/−2
• Command/Export.hs +2/−2
• Command/ImportFeed.hs +4/−3
• Command/MatchExpression.hs +3/−5
• Command/Merge.hs +1/−1
• Command/Reinject.hs +26/−0
• Command/RemoteDaemon.hs +2/−1
• Command/Satisfy.hs +17/−0
• Command/Sync.hs +110/−78
• Database/ContentIdentifier.hs +1/−1
• Database/Export.hs +1/−1
• Database/Fsck.hs +1/−0
• Database/Handle.hs +1/−1
• Database/Keys/SQL.hs +1/−1
• Git/Config.hs +14/−12
• Git/LockFile.hs +2/−1
• Limit.hs +74/−14
• Limit/Wanted.hs +7/−6
• Logs/PreferredContent.hs +14/−13
• Messages.hs +11/−0
• Remote.hs +1/−1
• Remote/Directory.hs +21/−5
• Remote/GCrypt.hs +6/−3
• Remote/S3.hs +14/−14
• Setup.hs +0/−59
• Types/ActionItem.hs +10/−0
• Types/FileMatcher.hs +7/−3
• Utility/Daemon.hs +5/−4
• Utility/DirWatcher/Kqueue.hs +2/−1
• Utility/LockFile/PidLock.hs +2/−1
• Utility/LockFile/Posix.hs +2/−1
• Utility/Matcher.hs +121/−20
• Utility/OpenFd.hs +27/−0
• Utility/Url.hs +2/−3
• Utility/UserInfo.hs +16/−11
• doc/git-annex-diffdriver.mdwn +29/−13
• doc/git-annex-dropunused.mdwn +8/−0
• doc/git-annex-importfeed.mdwn +1/−1
• doc/git-annex-matchexpression.mdwn +5/−0
• doc/git-annex-matching-options.mdwn +6/−0
• doc/git-annex-mirror.mdwn +3/−0
• doc/git-annex-preferred-content.mdwn +13/−0
• doc/git-annex-pull.mdwn +3/−1
• doc/git-annex-push.mdwn +2/−0
• doc/git-annex-reinject.mdwn +14/−0
• doc/git-annex-satisfy.mdwn +66/−0
• doc/git-annex-sync.mdwn +2/−0
• doc/git-annex.mdwn +7/−2
• git-annex.cabal +15/−6
• stack-lts-18.13.yaml +27/−0
• stack.yaml +7/−11

@@ -122,6 +122,7 @@ 	, transferrerpool :: TransferrerPool 	, debugenabled :: Bool 	, debugselector :: DebugSelector+	, explainenabled :: Bool 	, ciphers :: TMVar (M.Map StorableCipher Cipher) 	, fast :: Bool 	, force :: Bool@@ -152,6 +153,7 @@ 		, transferrerpool = tp 		, debugenabled = annexDebug c 		, debugselector = debugSelectorFromGitConfig c+		, explainenabled = False 		, ciphers = cm 		, fast = False 		, force = False

@@ -258,7 +258,7 @@ 			-- Avoid losing any commits that the adjusted branch 			-- has that have not yet been propigated back to the 			-- origbranch.-			_ <- propigateAdjustedCommits' origbranch adj commitlck+			_ <- propigateAdjustedCommits' True origbranch adj commitlck 			 			origheadfile <- inRepo $ readFileStrict . Git.Ref.headFile 			origheadsha <- inRepo (Git.Ref.sha currbranch)@@ -294,7 +294,7 @@ 		return ok 	| otherwise = preventCommits $ \commitlck -> do 		-- Done for consistency.-		_ <- propigateAdjustedCommits' origbranch adj commitlck+		_ <- propigateAdjustedCommits' True origbranch adj commitlck 		-- No need to actually update the branch because the 		-- adjustment is stable. 		return True@@ -495,20 +495,21 @@ propigateAdjustedCommits :: OrigBranch -> Adjustment -> Annex () propigateAdjustedCommits origbranch adj =  	preventCommits $ \commitsprevented ->-		join $ snd <$> propigateAdjustedCommits' origbranch adj commitsprevented+		join $ snd <$> propigateAdjustedCommits' True origbranch adj commitsprevented 		 {- Returns sha of updated basis branch, and action which will rebase  - the adjusted branch on top of the updated basis branch. -} propigateAdjustedCommits'-	:: OrigBranch+	:: Bool+	-> OrigBranch 	-> Adjustment 	-> CommitsPrevented 	-> Annex (Maybe Sha, Annex ())-propigateAdjustedCommits' origbranch adj _commitsprevented =+propigateAdjustedCommits' warnwhendiverged origbranch adj _commitsprevented = 	inRepo (Git.Ref.sha basis) >>= \case 		Just origsha -> catCommit currbranch >>= \case 			Just currcommit ->-				newcommits >>= go origsha False >>= \case+				newcommits >>= go origsha origsha False >>= \case 					Left e -> do 						warning (UnquotedString e) 						return (Nothing, return ())@@ -528,20 +529,25 @@ 		-- Get commits oldest first, so they can be processed 		-- in order made. 		[Param "--reverse"]-	go parent _ [] = do+	go origsha parent _ [] = do 		setBasisBranch (BasisBranch basis) parent-		inRepo $ Git.Branch.update' origbranch parent+		inRepo (Git.Ref.sha origbranch) >>= \case+			Just origbranchsha | origbranchsha /= origsha ->+				when warnwhendiverged $+					warning $ UnquotedString $ +						"Original branch " ++ fromRef origbranch ++ " has diverged from current adjusted branch " ++ fromRef currbranch+			_ -> inRepo $ Git.Branch.update' origbranch parent 		return (Right parent)-	go parent pastadjcommit (sha:l) = catCommit sha >>= \case+	go origsha parent pastadjcommit (sha:l) = catCommit sha >>= \case 		Just c 			| commitMessage c == adjustedBranchCommitMessage ->-				go parent True l+				go origsha parent True l 			| pastadjcommit -> 				reverseAdjustedCommit parent adj (sha, c) origbranch 					>>= \case 						Left e -> return (Left e)-						Right commit -> go commit pastadjcommit l-		_ -> go parent pastadjcommit l+						Right commit -> go origsha commit pastadjcommit l+		_ -> go origsha parent pastadjcommit l 	rebase currcommit newparent = do 		-- Reuse the current adjusted tree, and reparent it 		-- on top of the newparent.

@@ -1,6 +1,6 @@ {- adjusted branch merging  -- - Copyright 2016-2020 Joey Hess <id@joeyh.name>+ - Copyright 2016-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -8,6 +8,7 @@ {-# LANGUAGE BangPatterns, OverloadedStrings #-}  module Annex.AdjustedBranch.Merge (+	canMergeToAdjustedBranch, 	mergeToAdjustedBranch, ) where @@ -32,6 +33,12 @@ import qualified Data.ByteString as S import qualified System.FilePath.ByteString as P +canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool+canMergeToAdjustedBranch tomerge (origbranch, adj) =+	inRepo $ Git.Branch.changed currbranch tomerge+  where+	AdjBranch currbranch = originalToAdjusted origbranch adj+ {- Update the currently checked out adjusted branch, merging the provided  - branch into it. Note that the provided branch should be a non-adjusted  - branch. -}@@ -42,16 +49,10 @@ 	adjbranch@(AdjBranch currbranch) = originalToAdjusted origbranch adj 	basis = basisBranch adjbranch -	go commitsprevented =-		ifM (inRepo $ Git.Branch.changed currbranch tomerge)-			( do-				(updatedorig, _) <- propigateAdjustedCommits'-					origbranch adj commitsprevented-				changestomerge updatedorig-			, nochangestomerge-			)--	nochangestomerge = return $ return True+	go commitsprevented = do+		(updatedorig, _) <- propigateAdjustedCommits'+			False origbranch adj commitsprevented+		changestomerge updatedorig  	{- Since the adjusted branch changes files, merging tomerge 	 - directly into it would likely result in unnecessary merge@@ -98,7 +99,8 @@ 				-- (for an unknown reason). 				-- http://thread.gmane.org/gmane.comp.version-control.git/297237 				inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"]-				showAction $ UnquotedString $ "Merging into " ++ fromRef (Git.Ref.base origbranch)+				when (tomerge /= origbranch) $+					showAction $ UnquotedString $ "Merging into " ++ fromRef (Git.Ref.base origbranch) 				merged <- autoMergeFrom' tomerge Nothing mergeconfig commitmode True 					(const $ resolveMerge (Just updatedorig) tomerge True) 				if merged

@@ -1,6 +1,6 @@ {- git-annex debugging  -- - Copyright 2021 Joey Hess <id@joeyh.name>+ - Copyright 2021-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -10,6 +10,7 @@ 	DebugSource(..), 	debug, 	fastDebug,+	fastDebug', 	configureDebug, 	debugSelectorFromGitConfig, 	parseDebugSelector,@@ -27,5 +28,8 @@ fastDebug :: DebugSource -> String -> Annex.Annex () fastDebug src msg = do 	rd <- Annex.getRead id-	when (Annex.debugenabled rd) $-		liftIO $ Utility.Debug.fastDebug (Annex.debugselector rd) src msg+	fastDebug' rd src msg++fastDebug' :: Annex.AnnexRead -> DebugSource -> String -> Annex.Annex ()+fastDebug' rd src msg = when (Annex.debugenabled rd) $+	liftIO $ Utility.Debug.fastDebug (Annex.debugselector rd) src msg

@@ -1,6 +1,6 @@ {- git-annex file matching  -- - Copyright 2012-2019 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -50,6 +50,7 @@  import Data.Either import qualified Data.Set as S+import Control.Monad.Writer  type GetFileMatcher = RawFilePath -> Annex (FileMatcher Annex) @@ -69,7 +70,7 @@  checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool checkMatcher matcher mkey afile notpresent notconfigured d-	| isEmpty matcher = notconfigured+	| isEmpty (fst matcher) = notconfigured 	| otherwise = case (mkey, afile) of 		(_, AssociatedFile (Just file)) -> 			go =<< fileMatchInfo file mkey@@ -88,8 +89,13 @@ 	go mi = checkMatcher' matcher mi notpresent  checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Bool-checkMatcher' matcher mi notpresent =-	matchMrun matcher $ \o -> matchAction o notpresent mi+checkMatcher' (matcher, (MatcherDesc matcherdesc)) mi notpresent = do+	(matches, desc) <- runWriterT $ matchMrun' matcher $ \op ->+		matchAction op notpresent mi+	explain (mkActionItem mi) $ UnquotedString <$>+		describeMatchResult matchDesc desc+			((if matches then "matches " else "does not match ") ++ matcherdesc ++ ": ")+	return matches  fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo fileMatchInfo file mkey = do@@ -100,12 +106,12 @@ 		, matchKey = mkey 		} -matchAll :: FileMatcher Annex+matchAll :: Matcher (MatchFiles Annex) matchAll = generate [] -parsedToMatcher :: [ParseResult (MatchFiles Annex)] -> Either String (FileMatcher Annex)-parsedToMatcher parsed = case partitionEithers parsed of-	([], vs) -> Right $ generate vs+parsedToMatcher :: MatcherDesc -> [ParseResult (MatchFiles Annex)] -> Either String (FileMatcher Annex)+parsedToMatcher matcherdesc parsed = case partitionEithers parsed of+	([], vs) -> Right (generate vs, matcherdesc) 	(es, _) -> Left $ unwords $ map ("Parse failure: " ++) es  data ParseToken t@@ -139,8 +145,8 @@ 	, SimpleToken "nothing" (simply limitNothing) 	, ValueToken "include" (usev limitInclude) 	, ValueToken "exclude" (usev limitExclude)-	, ValueToken "largerthan" (usev $ limitSize lb (>))-	, ValueToken "smallerthan" (usev $ limitSize lb (<))+	, ValueToken "largerthan" (usev $ limitSize lb "largerthan" (>))+	, ValueToken "smallerthan" (usev $ limitSize lb "smallerthan" (<)) 	]  commonKeyedTokens :: [ParseToken (MatchFiles Annex)]@@ -149,8 +155,8 @@ 	]  data PreferredContentData = PCD-	{ matchStandard :: Either String (FileMatcher Annex)-	, matchGroupWanted :: Either String (FileMatcher Annex)+	{ matchStandard :: Either String (Matcher (MatchFiles Annex))+	, matchGroupWanted :: Either String (Matcher (MatchFiles Annex)) 	, getGroupMap :: Annex GroupMap 	, configMap :: M.Map UUID RemoteConfig 	, repoUUID :: Maybe UUID@@ -164,9 +170,9 @@ -- so the Key is not known. preferredContentKeylessTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)] preferredContentKeylessTokens pcd =-	[ SimpleToken "standard" (call $ matchStandard pcd)-	, SimpleToken "groupwanted" (call $ matchGroupWanted pcd)-	, SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir)+	[ SimpleToken "standard" (call "standard" $ matchStandard pcd)+	, SimpleToken "groupwanted" (call "groupwanted" $ matchGroupWanted pcd)+	, SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir "inpreferreddir") 	] ++ commonKeylessTokens LimitAnnexFiles   where 	preferreddir = maybe "public" fromProposedAccepted $@@ -177,11 +183,12 @@ 	[ SimpleToken "present" (simply $ limitPresent $ repoUUID pcd) 	, SimpleToken "securehash" (simply limitSecureHash) 	, ValueToken "copies" (usev limitCopies)-	, ValueToken "lackingcopies" (usev $ limitLackingCopies False)-	, ValueToken "approxlackingcopies" (usev $ limitLackingCopies True)+	, ValueToken "lackingcopies" (usev $ limitLackingCopies "lackingcopies" False)+	, ValueToken "approxlackingcopies" (usev $ limitLackingCopies "approxlackingcopies" True) 	, ValueToken "inbackend" (usev limitInBackend) 	, ValueToken "metadata" (usev limitMetaData) 	, ValueToken "inallgroup" (usev $ limitInAllGroup $ getGroupMap pcd)+	, ValueToken "onlyingroup" (usev $ limitOnlyInGroup $ getGroupMap pcd) 	] ++ commonKeyedTokens  preferredContentTokens :: PreferredContentData -> [ParseToken (MatchFiles Annex)]@@ -227,6 +234,7 @@ largeFilesMatcher :: Annex GetFileMatcher largeFilesMatcher = go =<< getGitConfigVal' annexLargeFiles   where+	matcherdesc = MatcherDesc "annex.largefiles" 	go (HasGitConfig (Just expr)) = do 		matcher <- mkmatcher expr "git config" 		return $ const $ return matcher@@ -236,34 +244,38 @@ 			then case v of 				HasGlobalConfig (Just expr') -> 					mkmatcher expr' "git-annex config"-				_ -> return matchAll+				_ -> return (matchAll, matcherdesc) 			else mkmatcher expr "gitattributes"  	mkmatcher expr cfgfrom = do 		parser <- mkMatchExpressionParser-		either (badexpr cfgfrom) return $ parsedToMatcher $ parser expr+		either (badexpr cfgfrom) return $ parsedToMatcher matcherdesc $ parser expr+ 	badexpr cfgfrom e = giveup $ "bad annex.largefiles configuration in " ++ cfgfrom ++ ": " ++ e  newtype AddUnlockedMatcher = AddUnlockedMatcher (FileMatcher Annex)  addUnlockedMatcher :: Annex AddUnlockedMatcher-addUnlockedMatcher = AddUnlockedMatcher <$> +addUnlockedMatcher = AddUnlockedMatcher <$> 	(go =<< getGitConfigVal' annexAddUnlocked)   where 	go (HasGitConfig (Just expr)) = mkmatcher expr "git config" 	go (HasGlobalConfig (Just expr)) = mkmatcher expr "git annex config" 	go _ = matchalways False +	matcherdesc = MatcherDesc "annex.addunlocked"+ 	mkmatcher :: String -> String -> Annex (FileMatcher Annex) 	mkmatcher expr cfgfrom = case Git.Config.isTrueFalse expr of 		Just b -> matchalways b 		Nothing -> do 			parser <- mkMatchExpressionParser-			either (badexpr cfgfrom) return $ parsedToMatcher $ parser expr+			either (badexpr cfgfrom) return $ parsedToMatcher matcherdesc $ parser expr+ 	badexpr cfgfrom e = giveup $ "bad annex.addunlocked configuration in " ++ cfgfrom ++ ": " ++ e -	matchalways True = return $ MOp limitAnything-	matchalways False = return $ MOp limitNothing+	matchalways True = return (MOp limitAnything, matcherdesc)+	matchalways False = return (MOp limitNothing, matcherdesc)  checkAddUnlockedMatcher :: AddUnlockedMatcher -> MatchInfo -> Annex Bool checkAddUnlockedMatcher (AddUnlockedMatcher matcher) mi = @@ -275,13 +287,14 @@ usev :: MkLimit Annex -> String -> ParseResult (MatchFiles Annex) usev a v = Operation <$> a v -call :: Either String (FileMatcher Annex) -> ParseResult (MatchFiles Annex)-call (Right sub) = Right $ Operation $ MatchFiles+call :: String -> Either String (Matcher (MatchFiles Annex)) -> ParseResult (MatchFiles Annex)+call desc (Right sub) = Right $ Operation $ MatchFiles 	{ matchAction = \notpresent mi -> 		matchMrun sub $ \o -> matchAction o notpresent mi 	, matchNeedsFileName = any matchNeedsFileName sub 	, matchNeedsFileContent = any matchNeedsFileContent sub 	, matchNeedsKey = any matchNeedsKey sub 	, matchNeedsLocationLog = any matchNeedsLocationLog sub+	, matchDesc = matchDescSimple desc 	}-call (Left err) = Left err+call _ (Left err) = Left err

@@ -762,7 +762,7 @@ 						warning (UnquotedString (show e)) 						return Nothing 	-	importordownload cidmap (loc, (cid, sz)) largematcher= do+	importordownload cidmap (loc, (cid, sz)) largematcher = do 		f <- locworktreefile loc 		matcher <- largematcher f 		-- When importing a key is supported, always use it rather@@ -771,7 +771,7 @@ 		let act = if importcontent 			then case Remote.importKey ia of 				Nothing -> dodownload-				Just _ -> if Utility.Matcher.introspect matchNeedsFileContent matcher+				Just _ -> if Utility.Matcher.introspect matchNeedsFileContent (fst matcher) 					then dodownload 					else doimport 			else doimport@@ -781,7 +781,7 @@ 		case Remote.importKey ia of 			Nothing -> error "internal" -- checked earlier 			Just importkey -> do-				when (Utility.Matcher.introspect matchNeedsFileContent matcher) $+				when (Utility.Matcher.introspect matchNeedsFileContent (fst matcher)) $ 					giveup "annex.largefiles configuration examines file contents, so cannot import without content."  				let mi = MatchingInfo ProvidedInfo 					{ providedFilePath = Just f@@ -994,14 +994,15 @@  -} makeImportMatcher :: Remote -> Annex (Either String (FileMatcher Annex)) makeImportMatcher r = load preferredContentKeylessTokens >>= \case-	Nothing -> return $ Right matchAll-	Just (Right v) -> return $ Right v+	Nothing -> return $ Right (matchAll, matcherdesc)+	Just (Right v) -> return $ Right (v, matcherdesc) 	Just (Left err) -> load preferredContentTokens >>= \case 		Just (Left err') -> return $ Left err' 		_ -> return $ Left $ 			"The preferred content expression contains terms that cannot be checked when importing: " ++ err   where 	load t = M.lookup (Remote.uuid r) . fst <$> preferredRequiredMapsLoad' t+	matcherdesc = MatcherDesc "preferred content"  {- Gets the ImportableContents from the remote.  -

@@ -118,6 +118,9 @@ 	initSharedClone sharedclone 	 	u <- getUUID+	when (u == NoUUID) $+		giveup "Failed to read annex.uuid from git config after setting it. This should never happen. Please file a bug report."+	 	{- Avoid overwriting existing description with a default 	 - description. -} 	whenM (pure (isJust mdescription) <||> not . M.member u <$> uuidDescMapRaw) $

@@ -44,8 +44,11 @@ import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P #ifndef mingw32_HOST_OS+#if MIN_VERSION_unix(2,8,0)+#else import System.PosixCompat.Files (isSymbolicLink) #endif+#endif  type LinkTarget = S.ByteString @@ -431,23 +434,22 @@ isPointerFile :: RawFilePath -> IO (Maybe Key) isPointerFile f = catchDefaultIO Nothing $ #if defined(mingw32_HOST_OS)-	checkcontentfollowssymlinks -- no symlinks supported on windows+	withFile (fromRawFilePath f) ReadMode readhandle #else #if MIN_VERSION_unix(2,8,0)-	bracket-		(openFd (fromRawFilePath f) ReadOnly (defaultFileFlags { nofollow = True }) Nothing)-		closeFd-		(\fd -> readhandle =<< fdToHandle fd)+	let open = do+		fd <- openFd (fromRawFilePath f) ReadOnly +			(defaultFileFlags { nofollow = True })+		fdToHandle fd+	in bracket open hClose readhandle #else 	ifM (isSymbolicLink <$> R.getSymbolicLinkStatus f) 		( return Nothing-		, checkcontentfollowssymlinks+		, withFile (fromRawFilePath f) ReadMode readhandle 		) #endif #endif   where-	checkcontentfollowssymlinks = -		withFile (fromRawFilePath f) ReadMode readhandle 	readhandle h = parseLinkTargetOrPointer <$> S.hGet h maxPointerSz  {- Checks a symlink target or pointer file first line to see if it

@@ -197,8 +197,12 @@  numCopiesCheck' :: RawFilePath -> (Int -> Int -> v) -> [UUID] -> Annex v numCopiesCheck' file vs have = do-	needed <- fst <$> getFileNumMinCopies file-	return $ length have `vs` fromNumCopies needed+	needed <- fromNumCopies . fst <$> getFileNumMinCopies file+	let nhave = length have+	explain (ActionItemTreeFile file) $ Just $ UnquotedString $+		"has " ++ show nhave ++ " " ++ pluralCopies nhave ++ +		", and the configured annex.numcopies is " ++ show needed+	return $ nhave `vs` needed  data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere 	deriving (Ord, Eq)@@ -280,10 +284,10 @@ 		then showLongNote $ UnquotedString $ 			"Could only verify the existence of " ++ 			show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++ -			" necessary " ++ pluralcopies (fromNumCopies neednum)+			" necessary " ++ pluralCopies (fromNumCopies neednum) 		else do 			showLongNote $ UnquotedString $ "Unable to lock down " ++ show (fromMinCopies needmin) ++ -				" " ++ pluralcopies (fromMinCopies needmin) ++ +				" " ++ pluralCopies (fromMinCopies needmin) ++  				" of file necessary to safely drop it." 			if null lockunsupported 				then showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)"@@ -292,9 +296,10 @@  	Remote.showTriedRemotes bad 	Remote.showLocations True key (map toUUID have++skip) nolocmsg-  where-	pluralcopies 1 = "copy"-	pluralcopies _ = "copies"++pluralCopies :: Int -> String+pluralCopies 1 = "copy"+pluralCopies _ = "copies"  {- Finds locations of a key that can be used to get VerifiedCopies,  - in order to allow dropping the key.

@@ -89,7 +89,7 @@ 	toomanyfiles cmd fs = Left $ cmd ++ " downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs 	downloadedfiles cmd 		| isytdlp cmd = liftIO $ -			(lines <$> readFile filelistfile)+			(nub . lines <$> readFile filelistfile) 				`catchIO` (pure . const []) 		| otherwise = workdirfiles 	workdirfiles = liftIO $ filter (/= filelistfile) 

@@ -75,15 +75,15 @@ 		| Git.repoIsLocal r = True 		| Git.repoIsLocalUnknown r = True 		| otherwise = False-	sync currentbranch@(Just _, _) = do+	syncbranch currentbranch@(Just _, _) = do 		(failedpull, diverged) <- manualPull currentbranch =<< gitremotes 		now <- liftIO getCurrentTime 		failedpush <- pushToRemotes' now =<< gitremotes 		return (nub $ failedpull ++ failedpush, diverged) 	{- No local branch exists yet, but we can try pulling. -}-	sync (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes+	syncbranch (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes 	go = do-		(failed, diverged) <- sync =<< liftAnnex getCurrentBranch+		(failed, diverged) <- syncbranch =<< liftAnnex getCurrentBranch 		addScanRemotes diverged =<< 			filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) rs 		return failed

@@ -99,7 +99,7 @@ 						mc 						def 						cmode-						changedbranch+						[changedbranch] 			recordCommit 		| changedbranch == b = 			-- Record commit so the pusher pushes it out.

@@ -6,7 +6,8 @@  -}  {-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}-{-# LANGUAGE RankNTypes, KindSignatures, TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE RankNTypes, KindSignatures, TypeFamilies, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}  module Assistant.WebApp.Configurators.Local where 

@@ -24,7 +24,7 @@  import System.Environment #ifndef mingw32_HOST_OS -import System.PosixCompat.User+import System.Posix.User import Data.Maybe import Control.Applicative import Prelude

@@ -22,6 +22,7 @@ 	s/^Warning:.*mdwn2man.*//g; 	s/^$/.PP\n/; 	s/^\*\s+(.*)/.IP "$1"/;+	s/\\$/\\\\/; 	next if $_ eq ".PP\n" && $skippara; 	if (/^.IP /) { 		$inlist=1;

@@ -1,7 +1,51 @@+git-annex (10.20230802) upstream; urgency=medium++  * satisfy: New command that gets/sends/drops content to satisfy+    preferred content settings. This is like to the --content+    part of git-annex sync.+  * --explain: New option to display explanations of what git-annex+    takes into account when deciding what to do. Including explaining+    matching of preferred content expressions, annex.largefiles, and +    annex.addunlocked.+  * reinject: Added --guesskeys option.+  * diffdriver: Added --text option for easy diffing of the contents of+    annexed text files.+  * assist: With --jobs, parallelize transferring content to/from remotes.+  * Bug fix: Re-running git-annex adjust or sync when in an adjusted branch+    would overwrite the original branch, losing any commits that had been+    made to it since the adjusted branch was created.+  * Bug fix: Fix behavior when git is configured with +    safe.bareRepository = explicit.+  * importfeed bug fix: When -J was used with multiple feeds, some feeds+    did not get their items downloaded.+  * importfeed: Add feedurl to the metadata (and allow it to be used in the+    --template)+  * Improve resuming interrupted download when using yt-dlp.+  * S3: Amazon S3 buckets created after April 2023 do not support ACLs,+    so public=yes cannot be used with them. Existing buckets configured+    with public=yes will keep working.+  * S3: Allow setting publicurl=yes without public=yes, to support+    buckets that are configured with a Bucket Policy that allows public+    access.+  * directory, gcrypt: Remove empty hash directories when dropping content.+  * dropunused: Support --jobs+  * Support "onlyingroup=" in preferred content expressions.+  * Support --onlyingroup= matching option.+  * Setup.hs: Stop installing man pages, desktop files, and the+    git-annex-shell and git-remote-tor-annex symlinks.+    Anything still relying on that, eg via cabal v1-install will need to+    change to using make install-home.+  * Support building with unix-compat 0.7+  * Support building with unix-2.8.0.+  * stack.yaml: Update to build with ghc-9.6.2 and aws-0.24.+    (For windows, stack-lts-18.13.yaml has to be used instead for now.)++ -- Joey Hess <id@joeyh.name>  Wed, 02 Aug 2023 13:55:30 -0400+ git-annex (10.20230626) upstream; urgency=medium    * Split out two new commands, git-annex pull and git-annex push.-    Those plus a git commit are equivilant to git-annex sync.+    Those plus a git commit are equivalent to git-annex sync.     (Note that the new commands default to syncing content, unless     annex.synccontent is explicitly set to false.)   * assist: New command, which is the same as git-annex sync but with@@ -42,7 +86,7 @@   * Cache negative lookups of global numcopies and mincopies.      Speeds up eg git-annex sync --content by up to 50%.   * Speed up sync in an adjusted branch by avoiding re-adjusting the branch-    unncessarily, particularly when it is adjusted with --hide-missing+    unnecessarily, particularly when it is adjusted with --hide-missing     or --unlock-present.   * config: Added the --show-origin and --for-file options.   * config: Support annex.numcopies and annex.mincopies.

@@ -43,7 +43,7 @@            2007-2015 Bryan O'Sullivan License: BSD-3-clause -Files: Utility/GitLFS.hs+Files: Utility/GitLFS.hs Utility/Matcher.hs Utility/Tor.hs Utility/Yesod.hs Copyright: © 2019 Joey Hess <id@joeyh.name> License: AGPL-3+ 

@@ -103,6 +103,7 @@ import qualified Command.Assist import qualified Command.Pull import qualified Command.Push+import qualified Command.Satisfy import qualified Command.Mirror import qualified Command.AddUrl import qualified Command.ImportFeed@@ -151,6 +152,7 @@ 	, Command.Assist.cmd 	, Command.Pull.cmd 	, Command.Push.cmd+	, Command.Satisfy.cmd 	, Command.Mirror.cmd 	, Command.AddUrl.cmd 	, Command.ImportFeed.cmd

@@ -286,12 +286,12 @@ 		<> help "skip files with fewer copies" 		<> hidden 		)-	, annexOption (setAnnexState . Limit.addLackingCopies False) $ strOption+	, annexOption (setAnnexState . Limit.addLackingCopies "lackingcopies" False) $ strOption 		( long "lackingcopies" <> metavar paramNumber 		<> help "match files that need more copies" 		<> hidden 		)-	, annexOption (setAnnexState . Limit.addLackingCopies True) $ strOption+	, annexOption (setAnnexState . Limit.addLackingCopies "approxlackingcopies" True) $ strOption 		( long "approxlackingcopies" <> metavar paramNumber 		<> help "match files that need more copies (faster)" 		<> hidden@@ -309,7 +309,12 @@ 		) 	, annexOption (setAnnexState . Limit.addInAllGroup) $ strOption 		( long "inallgroup" <> metavar paramGroup-		<> help "match files present in all remotes in a group"+		<> help "match files present in all repositories in a group"+		<> hidden+		)+	, annexOption (setAnnexState . Limit.addOnlyInGroup) $ strOption+		( long "onlyingroup" <> metavar paramGroup+		<> help "match files that are only present in repositories in the group" 		<> hidden 		) 	, annexOption (setAnnexState . Limit.addMetaData) $ strOption

@@ -59,6 +59,11 @@ 		<> help "show debug messages coming from the specified module" 		<> hidden 		)+	, annexFlag (setexplain True)+		( long "explain" <> short 'd'+		<> help "explain why git-annex does what it does"+		<> hidden+		) 	]   where 	setforce v = setAnnexRead $ \rd -> rd { Annex.force = v }@@ -80,6 +85,10 @@ 		-- git-annex child processes. 		, setAnnexState $ Annex.addGitConfigOverride $  			decodeBS (debugfilterconfig <> "=") ++ v+		]+	+	setexplain v = mconcat+		[ setAnnexRead $ \rd -> rd { Annex.explainenabled = v } 		] 	 	(ConfigKey debugconfig) = annexConfig "debug"

@@ -21,7 +21,7 @@ 		(myseek <--< Command.Sync.optParser Command.Sync.AssistMode)  myseek :: Command.Sync.SyncOptions -> CommandSeek-myseek o = startConcurrency transferStages $ do+myseek o = do 	-- Changes to top of repository, so when this is run in a 	-- subdirectory, it will still default to adding files anywhere in 	-- the working tree.@@ -35,7 +35,7 @@ 		, Command.Add.checkGitIgnoreOption = CheckGitIgnore True 		, Command.Add.dryRunOption = DryRun False 		}-	waitForAllRunningCommandActions+	finishCommandActions 	-- Flush added files to index so they will be committed. 	Annex.Queue.flush 

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2014-2021 Joey Hess <id@joeyh.name>+ - Copyright 2014-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -15,13 +15,26 @@ cmd :: Command cmd = dontCheck repoExists $ 	command "diffdriver" SectionPlumbing -		"external git diff driver shim"-		("-- cmd --") (withParams seek)+		"git diff driver"+		("-- cmd --") (seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek = withWords (commandAction . start)+data Options = Options+	{ textDiff :: Bool+	, restOptions :: CmdParams+	} -start :: [String] -> CommandStart+optParser :: CmdParamsDesc -> Parser Options+optParser desc = Options+	<$> switch+		( long "text"+		<> help "diff text files with diff(1)"+		)+	<*> cmdParams desc++seek :: Options -> CommandSeek+seek = commandAction . start++start :: Options -> CommandStart start opts = do 	let (req, differ) = parseReq opts 	void $ liftIO . exitBool =<< liftIO . differ =<< fixupReq req@@ -55,10 +68,14 @@ 	, rNewMode req 	] -parseReq :: [String] -> (Req, Differ)-parseReq opts = case separate (== "--") opts of-	(c:ps, l) -> (mk l, externalDiffer c ps)-	([],_) -> badopts+parseReq :: Options -> (Req, Differ)+parseReq opts+	| textDiff opts = case separate (== "--") (restOptions opts) of+		(_,[]) -> (mk (restOptions opts), textDiffer [])+		(ps,rest) -> (mk rest, textDiffer ps)+	| otherwise = case separate (== "--") (restOptions opts) of+		(c:ps, l) -> (mk l, externalDiffer c ps)+		([],_) -> badopts   where 	mk (path:old_file:old_hex:old_mode:new_file:new_hex:new_mode:[]) = 		Req@@ -73,7 +90,7 @@ 	mk (unmergedpath:[]) = UnmergedReq { rPath = unmergedpath } 	mk _ = badopts -	badopts = giveup $ "Unexpected input: " ++ unwords opts+	badopts = giveup $ "Unexpected input: " ++ unwords (restOptions opts)  {- Check if either file is a symlink to a git-annex object,  - which git-diff will leave as a normal file containing the link text.@@ -101,3 +118,14 @@  externalDiffer :: String -> [String] -> Differ externalDiffer c ps = \req -> boolSystem c (map Param ps ++ serializeReq req )++textDiffer :: [String] -> Differ+textDiffer diffopts req = do+	putStrLn ("diff a/" ++ rPath req ++ " b/" ++ rPath req)+	-- diff exits nonzero on difference, so ignore exit status+	void $ boolSystem "diff" $+		[ Param "-u"+		, Param (rOldFile req)+		, Param (rNewFile req)+		] ++ map Param diffopts+	return True

@@ -108,7 +108,8 @@  startRemote :: PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> DroppingUnused -> Remote -> CommandStart startRemote pcc afile ai si numcopies mincopies key ud remote = -	starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) si $+	starting "drop" (OnlyActionOn key ai) si $ do+		showAction $ UnquotedString $ "from " ++ Remote.name remote 		performRemote pcc key afile numcopies mincopies remote ud  performLocal :: PreferredContentChecked -> Key -> AssociatedFile -> NumCopies -> MinCopies -> [VerifiedCopy] -> DroppingUnused -> CommandPerform

@@ -20,7 +20,7 @@ import qualified Utility.RawFilePath as R  cmd :: Command-cmd = withAnnexOptions [jsonOptions] $+cmd = withAnnexOptions [jobsOption, jsonOptions] $ 	command "dropunused" SectionMaintenance 		"drop unused file content" 		(paramRepeating paramNumRange) (seek <$$> optParser)@@ -36,7 +36,7 @@ 	<*> optional (Command.Drop.parseDropFromOption)  seek :: DropUnusedOptions -> CommandSeek-seek o = do+seek o = startConcurrency commandStages $ do 	numcopies <- getNumCopies 	mincopies <- getMinCopies 	from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o)

@@ -491,8 +491,8 @@ filterExport r tree = logExportExcluded (uuid r) $ \logwriter -> do 	m <- preferredContentMap 	case M.lookup (uuid r) m of-		Just matcher | not (isEmpty matcher) ->-			ExportFiltered <$> go (Just matcher) logwriter+		Just (matcher, matcherdesc) | not (isEmpty matcher) ->+			ExportFiltered <$> go (Just (matcher, matcherdesc)) logwriter 		_ -> ExportFiltered <$> go Nothing logwriter   where 	go mmatcher logwriter = do

@@ -101,7 +101,7 @@ 					return m 				else 					let (pending, rest) = M.partition ispending m-					in if M.null pending+					in if M.null pending || not (M.null rest) 						then retry 						else do 							putTMVar dlst rest@@ -531,13 +531,14 @@ minimalMetaData i = case getItemId (item i) of 	(Nothing) -> emptyMetaData 	(Just (_, itemid)) -> MetaData $ M.singleton itemIdField -		(S.singleton $ toMetaValue $fromFeedText itemid)+		(S.singleton $ toMetaValue $ fromFeedText itemid)  {- Extract fields from the feed and item, that are both used as metadata,  - and to generate the filename. -} extractFields :: ToDownload -> [(String, String)] extractFields i = map (uncurry extractField)-	[ ("feedtitle", [feedtitle])+	[ ("feedurl", [Just (feedurl i)])+	, ("feedtitle", [feedtitle]) 	, ("itemtitle", [itemtitle]) 	, ("feedauthor", [feedauthor]) 	, ("itemauthor", [itemauthor])

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -10,7 +10,6 @@ import Command import Annex.FileMatcher import Utility.DataUnits-import Utility.Matcher import Annex.UUID import Logs.Group @@ -84,15 +83,14 @@ 				, configMap = M.empty 				, repoUUID = Just u 				}-	case parsedToMatcher $ parser ((matchexpr o)) of+	case parsedToMatcher (MatcherDesc "provided expression") $ parser ((matchexpr o)) of 		Left e -> liftIO $ bail $ "bad expression: " ++ e 		Right matcher -> ifM (checkmatcher matcher) 			( liftIO exitSuccess 			, liftIO exitFailure 			)   where-	checkmatcher matcher = matchMrun matcher $ \op ->-		matchAction op S.empty (matchinfo o)+	checkmatcher matcher = checkMatcher' matcher (matchinfo o) S.empty  bail :: String -> IO a bail s = do

@@ -62,7 +62,7 @@ 	currbranch <- getCurrentBranch 	mc <- mergeConfig (allowUnrelatedHistories o) 	let so = def { notOnlyAnnexOption = True }-	next $ merge currbranch mc so Git.Branch.ManualCommit r+	next $ merge currbranch mc so Git.Branch.ManualCommit [r]   where 	ai = ActionItemOther (Just (UnquotedString (Git.fromRef r))) 	si = SeekInput []

@@ -29,6 +29,7 @@ data ReinjectOptions = ReinjectOptions 	{ params :: CmdParams 	, knownOpt :: Bool+	, guessKeysOpt :: Bool 	}  optParser :: CmdParamsDesc -> Parser ReinjectOptions@@ -39,9 +40,16 @@ 		<> help "inject all known files" 		<> hidden 		)+	<*> switch+		( long "guesskeys"+		<> help "inject files that are named like keys"+		<> hidden+		)  seek :: ReinjectOptions -> CommandSeek seek os+	| guessKeysOpt os && knownOpt os = giveup "Cannot combine --known with --guesskeys"+	| guessKeysOpt os = withStrings (commandAction . startGuessKeys) (params os) 	| knownOpt os = withStrings (commandAction . startKnown) (params os) 	| otherwise = withPairs (commandAction . startSrcDest) (params os) @@ -65,6 +73,24 @@   where 	src' = toRawFilePath src 	ai = ActionItemOther (Just (QuotedPath src'))++startGuessKeys :: FilePath -> CommandStart+startGuessKeys src = starting "reinject" ai si $ notAnnexed src' $+	case fileKey (toRawFilePath (takeFileName src)) of+		Just key -> ifM (verifyKeyContent key src')+			( perform src' key+			, do+				qp <- coreQuotePath <$> Annex.getGitConfig+				giveup $ decodeBS $ quote qp $ QuotedPath src'+					<> " does not have expected content"+			)+		Nothing -> do+			warning "Not named like an object file; skipping"+			next $ return True+  where+	src' = toRawFilePath src+	ai = ActionItemOther (Just (QuotedPath src'))+	si = SeekInput [src]  startKnown :: FilePath -> CommandStart startKnown src = starting "reinject" ai si $ notAnnexed src' $ do

@@ -14,6 +14,7 @@ import Utility.Daemon #ifndef mingw32_HOST_OS import Annex.Path+import Utility.OpenFd #endif  cmd :: Command@@ -30,7 +31,7 @@ #ifndef mingw32_HOST_OS 		git_annex <- liftIO programPath 		ps <- gitAnnexDaemonizeParams-		let logfd = openFd "/dev/null" ReadOnly Nothing defaultFileFlags+		let logfd = openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags 		liftIO $ daemonize git_annex ps logfd Nothing False runNonInteractive #else 		liftIO $ foreground Nothing runNonInteractive	

@@ -0,0 +1,17 @@+{- git-annex command+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.Satisfy (cmd) where++import Command+import Command.Sync hiding (cmd)++cmd :: Command+cmd = withAnnexOptions [jobsOption, backendOption] $+	command "satisfy" SectionCommon +		"transfer and drop content as configured"+		(paramRepeating paramRemote) (seek <--< optParser SatisfyMode)

@@ -95,7 +95,7 @@ 		"synchronize local repository with remotes" 		(paramRepeating paramRemote) (seek <--< optParser SyncMode) -data OperationMode = SyncMode | PullMode | PushMode | AssistMode+data OperationMode = SyncMode | PullMode | PushMode | SatisfyMode | AssistMode 	deriving (Eq, Show)  data SyncOptions = SyncOptions@@ -143,15 +143,17 @@ 		( metavar desc 		<> completeRemotes 		))-	<*> switch -		( long "only-annex"-		<> short 'a'-		<> help "do not operate on git branches"-		)-	<*> switch -		( long "not-only-annex"-		<> help "operate on git branches as well as annex"-		)+	<*> whenmode [SatisfyMode] True +		(switch +			( long "only-annex"+			<> short 'a'+			<> help "do not operate on git branches"+			))+	<*> whenmode [SatisfyMode] False +		( switch +			( long "not-only-annex"+			<> help "operate on git branches as well as annex"+			)) 	<*> case mode of 		SyncMode -> switch 			( long "commit"@@ -159,21 +161,25 @@ 			) 		PushMode -> pure False 		PullMode -> pure False+		SatisfyMode -> pure False 		AssistMode -> pure True-	<*> unlessmode [SyncMode] True (switch-		( long "no-commit"-		<> help "avoid git commit" -		))-	<*> unlessmode [SyncMode, AssistMode] Nothing (optional (strOption-		( long "message" <> short 'm' <> metavar "MSG"-		<> help "commit message"-		)))+	<*> unlessmode [SyncMode] True +		(switch+			( long "no-commit"+			<> help "avoid git commit" +			))+	<*> unlessmode [SyncMode, AssistMode] Nothing+		(optional (strOption+			( long "message" <> short 'm' <> metavar "MSG"+			<> help "commit message"+			))) 	<*> case mode of 		SyncMode -> invertableSwitch "pull" True 			( help "avoid git pulls from remotes"  			) 		PullMode -> pure True 		PushMode -> pure False+		SatisfyMode -> pure False 		AssistMode -> pure True 	<*> case mode of 		SyncMode -> invertableSwitch "push" True@@ -181,31 +187,36 @@ 			) 		PullMode -> pure False 		PushMode -> pure True+		SatisfyMode -> pure False 		AssistMode -> pure True-	<*> optional (flag' True -		( long "content"-		<> help "transfer annexed file contents" -		))-	<*> optional (flag' True-		( long "no-content"-		<> short 'g'-		<> help "do not transfer annexed file contents"-		))+	<*> whenmode [SatisfyMode] (Just True)+		(optional (flag' True +			( long "content"+			<> help "transfer annexed file contents" +			)))+	<*> whenmode [SatisfyMode] Nothing+		(optional (flag' True+			( long "no-content"+			<> short 'g'+			<> help "do not transfer annexed file contents"+			))) 	<*> many (strOption 		( long "content-of" 		<> short 'C' 		<> help "transfer contents of annexed files in a given location" 		<> metavar paramPath 		))-	<*> whenmode [PullMode] False (switch-		( long "cleanup"-		<> help "remove synced/ branches"-		))+	<*> whenmode [PullMode, SatisfyMode] False +		(switch+			( long "cleanup"+			<> help "remove synced/ branches"+			)) 	<*> optional parseAllOption-	<*> whenmode [PushMode] False (invertableSwitch "resolvemerge" True-		( help "do not automatically resolve merge conflicts"-		))-	<*> whenmode [PushMode] False+	<*> whenmode [PushMode, SatisfyMode] False +		(invertableSwitch "resolvemerge" True+			( help "do not automatically resolve merge conflicts"+			))+	<*> whenmode [PushMode, SatisfyMode] False 		parseUnrelatedHistoriesOption 	<*> pure mode   where@@ -249,10 +260,10 @@ 	 	prepMerge 	-	startConcurrency transferStages (seek' o)+	seek' o  seek' :: SyncOptions -> CommandSeek-seek' o = do+seek' o = startConcurrency transferStages $ do 	let withbranch a = a =<< getCurrentBranch  	remotes <- syncRemotes (syncWith o)@@ -340,14 +351,16 @@ 			else Nothing 		] -merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool-merge currbranch mergeconfig o commitmode tomerge = do+merge :: CurrBranch -> [Git.Merge.MergeConfig] -> SyncOptions -> Git.Branch.CommitMode -> [Git.Branch] -> Annex Bool+merge currbranch mergeconfig o commitmode tomergel = do 	canresolvemerge <- if resolveMergeOverride o 		then getGitConfigVal annexResolveMerge 		else return False-	case currbranch of-		(Just b, Just adj) -> mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode-		(b, _) -> autoMergeFrom tomerge b mergeconfig commitmode canresolvemerge+	and <$> case currbranch of+		(Just b, Just adj) -> forM tomergel $ \tomerge ->+			mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode+		(b, _) -> forM tomergel $ \tomerge ->+			autoMergeFrom tomerge b mergeconfig commitmode canresolvemerge  syncBranch :: Git.Branch -> Git.Branch syncBranch = Git.Ref.underBase "refs/heads/synced" . origBranch@@ -429,46 +442,54 @@ mergeLocal' :: [Git.Merge.MergeConfig] -> SyncOptions -> CurrBranch -> CommandStart mergeLocal' mergeconfig o currbranch@(Just branch, _) = 	needMerge currbranch branch >>= \case-		Nothing -> stop-		Just syncbranch -> do-			let ai = ActionItemOther (Just $ UnquotedString $ Git.Ref.describe syncbranch)+		[] -> stop+		tomerge -> do+			let ai = ActionItemOther (Just $ UnquotedString $ unwords $ map Git.Ref.describe tomerge) 			let si = SeekInput [] 			starting "merge" ai si $-				next $ merge currbranch mergeconfig o Git.Branch.ManualCommit syncbranch+				next $ merge currbranch mergeconfig o Git.Branch.ManualCommit tomerge mergeLocal' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \case 	Just branch -> needMerge currbranch branch >>= \case-		Nothing -> stop-		Just syncbranch -> do-			let ai = ActionItemOther (Just $ UnquotedString $ Git.Ref.describe syncbranch)+		[] -> stop+		tomerge -> do+			let ai = ActionItemOther (Just $ UnquotedString $ unwords $ map Git.Ref.describe tomerge) 			let si = SeekInput [] 			starting "merge" ai si $ do-				warning $ UnquotedString $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it."+				warning $ UnquotedString $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ unwords (map Git.fromRef tomerge) ++ " into it." 				next $ return False 	Nothing -> stop --- Returns the branch that should be merged, if any.-needMerge :: CurrBranch -> Git.Branch -> Annex (Maybe Git.Branch)+-- Returns the branches that should be merged, if any.+--+-- Usually this is the sync branch. However, when in an adjusted branch,+-- it can be either the sync branch or the original branch, or both.+needMerge :: CurrBranch -> Git.Branch -> Annex [Git.Branch] needMerge currbranch headbranch-	| is_branchView headbranch = return Nothing-	| otherwise = -		ifM (allM id checks)-			( return (Just syncbranch)-			, return Nothing-			)+	| is_branchView headbranch = return []+	| otherwise = ifM isBareRepo+		( return []+		, do+			syncbranchret <- usewhen syncbranch syncbranchchecks+			adjbranchret <- case currbranch of+				(Just origbranch, Just adj) -> +					usewhen origbranch $+						canMergeToAdjustedBranch origbranch (origbranch, adj)+				_ -> return []+			return (syncbranchret++adjbranchret)+		)   where+	usewhen v c = ifM c+		( return [v]+		, return []+		) 	syncbranch = syncBranch headbranch-	checks = case currbranch of-		(Just _, madj) -> -			let branch' = maybe headbranch (adjBranch . originalToAdjusted headbranch) madj-			in -				[ not <$> isBareRepo-				, inRepo (Git.Ref.exists syncbranch)-				, inRepo (Git.Branch.changed branch' syncbranch)-				]-		(Nothing, _) ->-			[ not <$> isBareRepo-			, inRepo (Git.Ref.exists syncbranch)-			]+	syncbranchchecks = case currbranch of+		(Just _, madj) -> syncbranchchanged madj+		(Nothing, _) -> hassyncbranch+	hassyncbranch = inRepo (Git.Ref.exists syncbranch)+	syncbranchchanged madj =+		let branch' = maybe headbranch (adjBranch . originalToAdjusted headbranch) madj+		in hassyncbranch <&&> inRepo (Git.Branch.changed branch' syncbranch)  pushLocal :: SyncOptions -> CurrBranch -> CommandStart pushLocal o b = stopUnless (notOnlyAnnex o) $ do@@ -620,8 +641,9 @@ 			mergelisted (tomerge (branchlist (Just branch))) 	)   where-	mergelisted getlist = and <$> -		(mapM (merge currbranch mergeconfig o Git.Branch.ManualCommit . remoteBranch remote) =<< getlist)+	mergelisted getlist =+		merge currbranch mergeconfig o Git.Branch.ManualCommit+			=<< map (remoteBranch remote) <$> getlist 	tomerge = filterM (changed remote) 	branchlist Nothing = [] 	branchlist (Just branch)@@ -838,6 +860,7 @@ 			SyncMode -> "sync" 			PullMode -> "pull" 			PushMode -> "push"+			SatisfyMode -> "satisfy" 			AssistMode -> "assist"  	gofile bloom mvar _ f k = @@ -910,7 +933,7 @@ 	return (got || not (null putrs))   where 	wantget have inhere = allM id -		[ pure (pullOption o)+		[ pure (pullOption o || operationMode o == SatisfyMode) 		, pure (not $ null have) 		, pure (not inhere) 		, wantGet True (Just k) af@@ -924,7 +947,7 @@ 			next $ return True  	wantput r-		| pushOption o == False = return False+		| pushOption o == False && operationMode o /= SatisfyMode = return False 		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False 		| isExport r = return False 		| isThirdPartyPopulated r = return False@@ -949,6 +972,7 @@  - of the branch. (If the branch is not currently checked out, anything  - imported from the remote will not yet have been merged into it yet and  - so exporting would delete files from the remote unexpectedly.)+ - (This is not done in SatifyMode.)  -  - Otherwise, transfer any files that were part of a previous export  - but are not in the remote yet.@@ -959,12 +983,14 @@ seekExportContent o rs (currbranch, _) = or <$> forM rs go   where 	go r+		| maybe False (\o' -> operationMode o' == SatisfyMode) o =+			case remoteAnnexTrackingBranch (Remote.gitconfig r) of+				Nothing -> return False+				Just b -> withdb r $ \db ->+					cannotupdateexport r db (Just b) False 		| not (maybe True pushOption o) = return False 		| not (remoteAnnexPush (Remote.gitconfig r)) = return False-		| otherwise = bracket-			(Export.openDb (Remote.uuid r))-			Export.closeDb-			(\db -> Export.writeLockDbWhile db (go' r db))+		| otherwise = withdb r (go' r) 	go' r db = case remoteAnnexTrackingBranch (Remote.gitconfig r) of 		Nothing -> cannotupdateexport r db Nothing True 		Just b -> do@@ -986,6 +1012,11 @@ 					| otherwise -> cannotupdateexport r db (Just b) False 				_ -> cannotupdateexport r db (Just b) True 	+	withdb r a = bracket+		(Export.openDb (Remote.uuid r))+		Export.closeDb+		(\db -> Export.writeLockDbWhile db (a db))+	 	cannotupdateexport r db mtb showwarning = do 		exported <- getExport (Remote.uuid r) 		when showwarning $@@ -1056,6 +1087,7 @@ shouldSyncContent :: SyncOptions -> Annex Bool shouldSyncContent o 	| fromMaybe False (noContentOption o) = pure False+	| operationMode o == SatisfyMode = pure True 	-- For git-annex pull and git-annex push and git-annex assist, 	-- annex.syncontent defaults to True unless set 	| operationMode o /= SyncMode = annexsynccontent True

@@ -6,7 +6,7 @@  -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, TypeOperators, TemplateHaskell #-} {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}

@@ -6,7 +6,7 @@  -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, TypeOperators, TemplateHaskell #-} {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}

@@ -12,6 +12,7 @@ {-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-} #if MIN_VERSION_persistent_template(2,8,0) {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-}

@@ -125,7 +125,7 @@ 	case r of 		Right (Right ()) -> debug "Database.Handle" "commitDb done" 		Right (Left e) -> debug "Database.Handle" ("commitDb failed: " ++ show e)-		Left BlockedIndefinitelyOnMVar -> debug "Database.Handle" ("commitDb BlockedIndefinitelyOnMVar")+		Left BlockedIndefinitelyOnMVar -> debug "Database.Handle" "commitDb BlockedIndefinitelyOnMVar"  	return r 

@@ -6,7 +6,7 @@  -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, TypeOperators, TemplateHaskell #-} {-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

@@ -57,20 +57,22 @@ read' :: Repo -> IO Repo read' repo = go repo   where-	go Repo { location = Local { gitdir = d } } = git_config True d-	go Repo { location = LocalUnknown d } = git_config False d+	-- Passing --git-dir changes git's behavior when run in a+	-- repository belonging to another user. When the git directory+	-- was explicitly specified, pass that in order to get the local+	-- git config.+	go Repo { location = Local { gitdir = d } }+		| gitDirSpecifiedExplicitly repo = git_config ["--git-dir=."] d+	-- Run in worktree when there is one, since running in the .git+	-- directory will trigger safe.bareRepository=explicit, even+	-- when not in a bare repository.+	go Repo { location = Local { worktree = Just d } } = git_config [] d+	go Repo { location = Local { gitdir = d } } = git_config [] d+	go Repo { location = LocalUnknown d } = git_config [] d 	go _ = assertLocal repo $ error "internal"-	git_config isgitdir d = withCreateProcess p (git_config' p)+	git_config addparams d = withCreateProcess p (git_config' p) 	  where-		params = -			-- Passing --git-dir changes git's behavior-			-- when run in a repository belonging to another-			-- user. When a gitdir is known, pass that in order-			-- to get the local git config.-			(if isgitdir && gitDirSpecifiedExplicitly repo-				then ["--git-dir=."]-				else [])-			++ ["config", "--null", "--list"]+		params = addparams ++ ["config", "--null", "--list"] 		p = (proc "git" params) 			{ cwd = Just (fromRawFilePath d) 			, env = gitEnv repo

@@ -12,6 +12,7 @@ import Common  #ifndef mingw32_HOST_OS+import Utility.OpenFd import System.Posix.Types import System.Posix.IO #else@@ -51,7 +52,7 @@ openLock' lck = do #ifndef mingw32_HOST_OS 	-- On unix, git simply uses O_EXCL-	h <- openFd lck ReadWrite (Just 0O666)+	h <- openFdWithMode (toRawFilePath lck) ReadWrite (Just 0O666) 		(defaultFileFlags { exclusive = True }) 	setFdOption h CloseOnExec True #else

@@ -1,6 +1,6 @@ {- user-specified limits on files to act on  -- - Copyright 2011-2022 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -41,6 +41,7 @@ import qualified Utility.RawFilePath as R import Backend +import Control.Monad.Writer import Data.Time.Clock.POSIX import qualified Data.Set as S import qualified Data.Map as M@@ -60,8 +61,14 @@ getMatcher :: Annex (MatchInfo -> Annex Bool) getMatcher = run <$> getMatcher'   where-	run matcher i = Utility.Matcher.matchMrun matcher $ \o ->-		matchAction o S.empty i+	run matcher i = do+		(match, desc) <- runWriterT $+			Utility.Matcher.matchMrun' matcher $ \o ->+				matchAction o S.empty i+		explain (mkActionItem i) $ UnquotedString <$>+			Utility.Matcher.describeMatchResult matchDesc desc+				(if match then "matches:" else "does not match:")+		return match  getMatcher' :: Annex (Utility.Matcher.Matcher (MatchFiles Annex)) getMatcher' = go =<< Annex.getState Annex.limit@@ -104,6 +111,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = "include" =? glob 	}  {- Add a limit to skip files that match the glob. -}@@ -117,6 +125,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = "exclude" =? glob 	}  matchGlobFile :: String -> MatchInfo -> Annex Bool@@ -141,6 +150,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = "includesamecontent" =? glob 	}  {- Add a limit to skip files when there is no other file using the same@@ -155,6 +165,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = "excludesamecontent" =? glob 	}  matchSameContentGlob :: String -> MatchInfo -> Annex Bool@@ -223,13 +234,14 @@ 	-> (UserProvidedInfo -> UserInfo String) 	-> Maybe Magic 	-> MkLimit Annex-matchMagic _limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just magic) glob = +matchMagic limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just magic) glob =  	Right $ MatchFiles 		{ matchAction = const go 		, matchNeedsFileName = False 		, matchNeedsFileContent = True 		, matchNeedsKey = False 		, matchNeedsLocationLog = False+		, matchDesc = limitname =? glob 		}   where  	cglob = compileGlob glob CaseSensitive (GlobFilePath False) -- memoized@@ -256,6 +268,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = matchDescSimple "unlocked" 	}  addLocked :: Annex ()@@ -265,6 +278,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = matchDescSimple "locked" 	}  matchLockStatus :: Bool -> MatchInfo -> Annex Bool@@ -299,6 +313,7 @@ 		, matchNeedsFileContent = False 		, matchNeedsKey = True 		, matchNeedsLocationLog = not inhere+		, matchDesc = "in" =? s 		} 	checkinuuid u notpresent key 		| null date = do@@ -329,16 +344,18 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = True 	, matchNeedsLocationLog = not (isNothing u)+	, matchDesc = matchDescSimple "present" 	}  {- Limit to content that is in a directory, anywhere in the repository tree -}-limitInDir :: FilePath -> MatchFiles Annex-limitInDir dir = MatchFiles +limitInDir :: FilePath -> String -> MatchFiles Annex+limitInDir dir desc = MatchFiles  	{ matchAction = const go 	, matchNeedsFileName = True 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = matchDescSimple desc 	}   where 	go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi@@ -370,6 +387,7 @@ 			, matchNeedsFileContent = False 			, matchNeedsKey = True 			, matchNeedsLocationLog = True+			, matchDesc = "copies" =? want 			} 	go' n good notpresent key = do 		us <- filter (`S.notMember` notpresent)@@ -382,11 +400,11 @@ 		| otherwise = (==) <$> readTrustLevel s  {- Adds a limit to match files that need more copies made. -}-addLackingCopies :: Bool -> String -> Annex ()-addLackingCopies approx = addLimit . limitLackingCopies approx+addLackingCopies :: String -> Bool -> String -> Annex ()+addLackingCopies desc approx = addLimit . limitLackingCopies desc approx -limitLackingCopies :: Bool -> MkLimit Annex-limitLackingCopies approx want = case readish want of+limitLackingCopies :: String -> Bool -> MkLimit Annex+limitLackingCopies desc approx want = case readish want of 	Just needed -> Right $ MatchFiles 		{ matchAction = \notpresent mi -> flip checkKey mi $ 			go mi needed notpresent@@ -394,6 +412,7 @@ 		, matchNeedsFileContent = False 		, matchNeedsKey = True 		, matchNeedsLocationLog = True+		, matchDesc = matchDescSimple desc 		} 	Nothing -> Left "bad value for number of lacking copies"   where@@ -422,6 +441,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = True 	, matchNeedsLocationLog = False+	, matchDesc = matchDescSimple "unused" 	}   where  	go _ (MatchingFile _) = return False@@ -444,6 +464,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = matchDescSimple "anything" 	}  {- Adds a limit that never matches. -}@@ -458,6 +479,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = False 	, matchNeedsLocationLog = False+	, matchDesc = matchDescSimple "nothing" 	}  {- Adds a limit to skip files not believed to be present in all@@ -480,12 +502,38 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = True 	, matchNeedsLocationLog = True+	, matchDesc = "inallgroup" =? groupname 	}   where 	check want key = do 		present <- S.fromList <$> Remote.keyLocations key 		return $ S.null $ want `S.difference` present +{- Skip files that are only present in repositories that are not in the+ - group. -}+addOnlyInGroup :: String -> Annex ()+addOnlyInGroup groupname = addLimit $ limitOnlyInGroup groupMap groupname++limitOnlyInGroup :: Annex GroupMap -> MkLimit Annex+limitOnlyInGroup getgroupmap groupname = Right $ MatchFiles+	{ matchAction = \notpresent mi -> do+		m <- getgroupmap+		let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m+		if S.null want+			then return False+			else checkKey (check notpresent want) mi+	, matchNeedsFileName = False+	, matchNeedsFileContent = False+	, matchNeedsKey = True+	, matchNeedsLocationLog = True+	, matchDesc = "inallgroup" =? groupname+	}+  where+	check notpresent want key = do+		locs <- S.fromList <$> Remote.keyLocations key+		let present = locs `S.difference` notpresent+		return $ not $ S.null $ present `S.intersection` want+ {- Adds a limit to skip files not using a specified key-value backend. -} addInBackend :: String -> Annex () addInBackend = addLimit . limitInBackend@@ -497,6 +545,7 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = True 	, matchNeedsLocationLog = False+	, matchDesc = "inbackend" =? name 	}   where 	check key = pure $ fromKey keyVariety key == variety@@ -513,17 +562,18 @@ 	, matchNeedsFileContent = False 	, matchNeedsKey = True 	, matchNeedsLocationLog = False+	, matchDesc = matchDescSimple "securehash" 	}  {- Adds a limit to skip files that are too large or too small -} addLargerThan :: LimitBy -> String -> Annex ()-addLargerThan lb = addLimit . limitSize lb (>)+addLargerThan lb = addLimit . limitSize lb "smallerthan" (>)  addSmallerThan :: LimitBy -> String -> Annex ()-addSmallerThan lb = addLimit . limitSize lb (<)+addSmallerThan lb = addLimit . limitSize lb "smallerthan" (<) -limitSize :: LimitBy -> (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex-limitSize lb vs s = case readSize dataUnits s of+limitSize :: LimitBy -> String -> (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex+limitSize lb desc vs s = case readSize dataUnits s of 	Nothing -> Left "bad size" 	Just sz -> Right $ MatchFiles 		{ matchAction = go sz@@ -533,6 +583,7 @@ 		, matchNeedsFileContent = False 		, matchNeedsKey = False 		, matchNeedsLocationLog = False+		, matchDesc = desc =? s 		}   where 	go sz _ (MatchingFile fi) = case lb of@@ -562,6 +613,7 @@ 		, matchNeedsFileContent = False 		, matchNeedsKey = True 		, matchNeedsLocationLog = False+		, matchDesc = "metadata" =? s 		}   where 	check f matching k = not . S.null @@ -577,6 +629,7 @@ 		, matchNeedsFileContent = False 		, matchNeedsKey = False 		, matchNeedsLocationLog = False+		, matchDesc = "accessedwithin" =? fromDuration duration 		}   where 	check now k = inAnnexCheck k $ \f ->@@ -596,3 +649,10 @@ checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a checkKey a (MatchingInfo p) = maybe (return False) a (providedKey p) checkKey a (MatchingUserInfo p) = a =<< getUserInfo (userProvidedKey p)++matchDescSimple :: String -> (Bool -> Utility.Matcher.MatchDesc)+matchDescSimple s b = Utility.Matcher.MatchDesc $ s +++	if b then "[TRUE]" else "[FALSE]"++(=?) :: String -> String -> (Bool -> Utility.Matcher.MatchDesc)+k =? v = matchDescSimple (k ++ "=" ++ v)

@@ -15,27 +15,27 @@ import qualified Remote  addWantGet :: Annex ()-addWantGet = addPreferredContentLimit $+addWantGet = addPreferredContentLimit "want-get" $ 	checkWant $ wantGet False Nothing  addWantGetBy :: String -> Annex () addWantGetBy name = do 	u <- Remote.nameToUUID name-	addPreferredContentLimit $ checkWant $ \af ->+	addPreferredContentLimit "want-get-by" $ checkWant $ \af -> 		wantGetBy False Nothing af u  addWantDrop :: Annex ()-addWantDrop = addPreferredContentLimit $ checkWant $ \af ->+addWantDrop = addPreferredContentLimit "want-drop" $ checkWant $ \af -> 	wantDrop False Nothing Nothing af (Just [])  addWantDropBy :: String -> Annex () addWantDropBy name = do 	u <- Remote.nameToUUID name-	addPreferredContentLimit $ checkWant $ \af ->+	addPreferredContentLimit "want-drop-by" $ checkWant $ \af -> 		wantDrop False (Just u) Nothing af (Just []) -addPreferredContentLimit :: (MatchInfo -> Annex Bool) -> Annex ()-addPreferredContentLimit a = do+addPreferredContentLimit :: String -> (MatchInfo -> Annex Bool) -> Annex ()+addPreferredContentLimit desc a = do 	nfn <- introspectPreferredRequiredContent matchNeedsFileName Nothing 	nfc <- introspectPreferredRequiredContent matchNeedsFileContent Nothing 	nk <- introspectPreferredRequiredContent matchNeedsKey Nothing@@ -46,6 +46,7 @@ 		, matchNeedsFileContent = nfc 		, matchNeedsKey = nk 		, matchNeedsLocationLog = nl+		, matchDesc = matchDescSimple desc 		}  checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool

@@ -1,6 +1,6 @@ {- git-annex preferred content matcher configuration  -- - Copyright 2012-2020 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -70,7 +70,7 @@ 	u <- maybe getUUID return mu 	check u preferredContentMap <||> check u requiredContentMap   where-	check u mk = mk >>= return . maybe False (any c) . M.lookup u+	check u mk = mk >>= return . maybe False (any c . fst) . M.lookup u  preferredContentMap :: Annex (FileMatcherMap Annex) preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad preferredContentTokens) return@@ -83,18 +83,18 @@ preferredRequiredMapsLoad :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (FileMatcherMap Annex, FileMatcherMap Annex) preferredRequiredMapsLoad mktokens = do 	(pc, rc) <- preferredRequiredMapsLoad' mktokens-	let pc' = handleunknown pc-	let rc' = handleunknown rc+	let pc' = handleunknown (MatcherDesc "preferred content") pc+	let rc' = handleunknown (MatcherDesc "required content") rc 	Annex.changeState $ \s -> s 		{ Annex.preferredcontentmap = Just pc' 		, Annex.requiredcontentmap = Just rc' 		} 	return (pc', rc')   where-	handleunknown = M.mapWithKey $ \u ->-		either (const $ unknownMatcher u) id+	handleunknown matcherdesc = M.mapWithKey $ \u v ->+		(either (const $ unknownMatcher u) id v, matcherdesc) -preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (FileMatcher Annex)), M.Map UUID (Either String (FileMatcher Annex)))+preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (Matcher (MatchFiles Annex))), M.Map UUID (Either String (Matcher (MatchFiles Annex)))) preferredRequiredMapsLoad' mktokens = do 	groupmap <- groupMap 	configmap <- remoteConfigMap@@ -125,12 +125,12 @@ 	-> UUID 	-> (PreferredContentData -> [ParseToken (MatchFiles Annex)]) 	-> PreferredContentExpression-	-> Either String (FileMatcher Annex)+	-> Either String (Matcher (MatchFiles Annex)) makeMatcher groupmap configmap groupwantedmap u mktokens = go True True   where 	go expandstandard expandgroupwanted expr 		| null (lefts tokens) = Right $ generate $ rights tokens-		| otherwise = Left (unwords (lefts tokens))+		| otherwise = Left $ unwords $ lefts tokens 	  where 		tokens = preferredContentParser (mktokens pcd) expr 		pcd = PCD@@ -159,16 +159,17 @@  -  - This avoid unwanted/expensive changes to the content, until the problem  - is resolved. -}-unknownMatcher :: UUID -> FileMatcher Annex+unknownMatcher :: UUID -> Matcher (MatchFiles Annex) unknownMatcher u = generate [present]   where 	present = Operation $ limitPresent (Just u)  {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: PreferredContentExpression -> Maybe String-checkPreferredContentExpression expr = case parsedToMatcher tokens of-	Left e -> Just e-	Right _ -> Nothing+checkPreferredContentExpression expr = +	case parsedToMatcher (MatcherDesc mempty) tokens of+		Left e -> Just e+		Right _ -> Nothing   where 	tokens = preferredContentParser (preferredContentTokens pcd) expr 	pcd = PCD

@@ -50,6 +50,7 @@ 	outputMessage, 	withMessageState, 	MessageState,+	explain, 	prompt, 	mkPrompter, 	sanitizeTopLevelExceptionMessages,@@ -298,6 +299,16 @@ 	case outputType s of 		JSONOutput _ -> True 		_ -> False++explain :: ActionItem -> Maybe StringContainingQuotedPath -> Annex ()+explain ai (Just msg) = do+	rd <- Annex.getRead id+	let d = actionItemDesc ai+	let msg' = "[ " <> (if d == mempty then "" else (d <> " ")) <> msg <> " ]\n"+	if Annex.explainenabled rd+		then outputMessage JSON.none id msg'+		else fastDebug' rd "Messages.explain" (decodeBS (noquote msg'))+explain _ _ = return ()  {- Prevents any concurrent console access while running an action, so  - that the action is the only thing using the console, and can eg prompt

@@ -360,7 +360,7 @@ 			ppremotesmakeavailable <- pp "remotes" remotesmakeavailable 				"Try making some of these remotes available" 			ppenablespecialremotes <- pp "enableremote" enablespecialremotes-				"Maybe enable some of these special remotes (git annex initremote ...)"+				"Maybe enable some of these special remotes (git annex enableremote ...)" 			ppaddgitremotes <- pp "repos" addgitremotes 				"Maybe add some of these git remotes (git remote add ...)" 			ppuuidsskipped <- pp "skipped" uuidsskipped

@@ -50,6 +50,9 @@ import Utility.FileMode import Utility.Directory.Create import qualified Utility.RawFilePath as R+#ifndef mingw32_HOST_OS+import Utility.OpenFd+#endif  remote :: RemoteType remote = specialRemoteType $ RemoteType@@ -232,7 +235,7 @@  - down. -} finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO () finalizeStoreGeneric d tmp dest = do-	removeDirGeneric (fromRawFilePath d) dest'+	removeDirGeneric False (fromRawFilePath d) dest' 	createDirectoryUnder [d] (parentDir dest) 	renameDirectory (fromRawFilePath tmp) dest' 	-- may fail on some filesystems@@ -266,7 +269,7 @@ #endif  removeKeyM :: RawFilePath -> Remover-removeKeyM d k = liftIO $ removeDirGeneric+removeKeyM d k = liftIO $ removeDirGeneric True 	(fromRawFilePath d) 	(fromRawFilePath (storeDir d k)) @@ -279,9 +282,13 @@  - exist. If the topdir does not exist, fails, because in this case the  - remote is not currently accessible and probably still has the content  - we were supposed to remove from it.+ -+ - Empty parent directories (up to but not including the topdir)+ - can also be removed. Failure to remove such a directory is not treated+ - as an error.  -}-removeDirGeneric :: FilePath -> FilePath -> IO ()-removeDirGeneric topdir dir = do+removeDirGeneric :: Bool -> FilePath -> FilePath -> IO ()+removeDirGeneric removeemptyparents topdir dir = do 	void $ tryIO $ allowWrite (toRawFilePath dir) #ifdef mingw32_HOST_OS 	{- Windows needs the files inside the directory to be writable@@ -293,6 +300,15 @@ 		Left e -> 			unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $ 				throwM e+	when removeemptyparents $ do+		subdir <- relPathDirToFile (toRawFilePath topdir) (P.takeDirectory (toRawFilePath dir))+		goparents (Just (P.takeDirectory subdir)) (Right ())+  where+	goparents _ (Left _e) = return ()+	goparents Nothing _ = return ()+	goparents (Just subdir) _ = do+		let d = topdir </> fromRawFilePath subdir+		goparents (upFrom subdir) =<< tryIO (removeDirectory d)  checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k@@ -456,7 +472,7 @@ #ifndef mingw32_HOST_OS 		let open = do 			-- Need a duplicate fd for the post check.-			fd <- openFd f' ReadOnly Nothing defaultFileFlags+			fd <- openFdWithMode f ReadOnly Nothing defaultFileFlags 			dupfd <- dup fd 			h <- fdToHandle fd 			return (h, dupfd)

@@ -439,8 +439,8 @@ remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Remover remove' repo r rsyncopts accessmethod k 	| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $-		liftIO $ Remote.Directory.removeDirGeneric-			(fromRawFilePath (Git.repoPath repo))+		liftIO $ Remote.Directory.removeDirGeneric True+			(gCryptTopDir repo) 			(fromRawFilePath (parentDir (toRawFilePath (gCryptLocation repo k)))) 	| Git.repoIsSsh repo = shellOrRsync r removeshell removersync 	| accessmethod == AccessRsyncOverSsh = removersync@@ -466,10 +466,13 @@ 	checkrsync = Remote.Rsync.checkKey rsyncopts k 	checkshell = Ssh.inAnnex repo k +gCryptTopDir :: Git.Repo -> FilePath+gCryptTopDir repo = Git.repoLocation repo </> fromRawFilePath objectDir+ {- Annexed objects are hashed using lower-case directories for max  - portability. -} gCryptLocation :: Git.Repo -> Key -> FilePath-gCryptLocation repo key = Git.repoLocation repo </> fromRawFilePath objectDir+gCryptLocation repo key = gCryptTopDir repo 	</> fromRawFilePath (keyPath key (hashDirLower def))  data AccessMethod = AccessRsyncOverSsh | AccessGitAnnexShell

@@ -6,6 +6,7 @@  -}  {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-}@@ -94,7 +95,7 @@ 			, yesNoParser versioningField (Just False) 				(FieldDesc "enable versioning of bucket content") 			, yesNoParser publicField (Just False)-				(FieldDesc "allow public read access to the bucket")+				(FieldDesc "allow public read access to the bucket via ACLs (only supported for old Amazon S3 buckets)") 			, optionalStringParser publicurlField 				(FieldDesc "url that can be used by public to download files") 			, optionalStringParser protocolField@@ -238,7 +239,7 @@                                 , removeExportDirectoryWhenEmpty = Nothing                                 , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierS3 hdl this info                                 }-			, whereisKey = Just (getPublicWebUrls u rs info c)+			, whereisKey = Just (getPublicWebUrls rs info c) 			, remoteFsck = Nothing 			, repairRepo = Nothing 			, config = c@@ -427,7 +428,7 @@ 				giveup "cannot download content" 			Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv 	Left S3HandleNeedCreds ->-		getPublicWebUrls' (uuid r) rs info c k >>= \case+		getPublicWebUrls' rs info c k >>= \case 			Left failreason -> do 				warning (UnquotedString failreason) 				giveup "cannot download content"@@ -474,7 +475,7 @@ 			giveup "cannot check content" 		Right loc -> checkKeyHelper info h loc 	Left S3HandleNeedCreds ->-		getPublicWebUrls' (uuid r) rs info c k >>= \case+		getPublicWebUrls' rs info c k >>= \case 			Left failreason -> do 				warning (UnquotedString failreason) 				giveup "cannot check content"@@ -974,7 +975,7 @@ 	, partSize :: Maybe Integer 	, isIA :: Bool 	, versioning :: Bool-	, public :: Bool+	, publicACL :: Bool 	, publicurl :: Maybe URLString 	, host :: Maybe String 	, region :: Maybe String@@ -997,7 +998,7 @@ 		, isIA = configIA c 		, versioning = fromMaybe False $ 			getRemoteConfigValue versioningField c-		, public = fromMaybe False $+		, publicACL = fromMaybe False $ 			getRemoteConfigValue publicField c 		, publicurl = getRemoteConfigValue publicurlField c 		, host = getRemoteConfigValue hostField c@@ -1014,7 +1015,7 @@  acl :: S3Info -> Maybe S3.CannedAcl acl info-	| public info = Just S3.AclPublicRead+	| publicACL info = Just S3.AclPublicRead 	| otherwise = Nothing  getBucketName :: ParsedRemoteConfig -> Maybe BucketName@@ -1154,7 +1155,8 @@ 		then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucketName c) 		else Nothing 	, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c))-	, Just ("public", if public info then "yes" else "no")+	, Just ("publicurl", fromMaybe "" (publicurl info))+	, Just ("public", if publicACL info then "yes" else "no") 	, Just ("versioning", if versioning info then "yes" else "no") 	]   where@@ -1162,13 +1164,11 @@ 	showstorageclass (S3.OtherStorageClass t) = T.unpack t 	showstorageclass sc = show sc -getPublicWebUrls :: UUID -> RemoteStateHandle -> S3Info -> ParsedRemoteConfig -> Key -> Annex [URLString]-getPublicWebUrls u rs info c k = either (const []) id <$> getPublicWebUrls' u rs info c k+getPublicWebUrls :: RemoteStateHandle -> S3Info -> ParsedRemoteConfig -> Key -> Annex [URLString]+getPublicWebUrls rs info c k = either (const []) id <$> getPublicWebUrls' rs info c k -getPublicWebUrls' :: UUID -> RemoteStateHandle -> S3Info -> ParsedRemoteConfig -> Key -> Annex (Either String [URLString])-getPublicWebUrls' u rs info c k-	| not (public info) = return $ Left $ -		"S3 bucket does not allow public access; " ++ needS3Creds u+getPublicWebUrls' :: RemoteStateHandle -> S3Info -> ParsedRemoteConfig -> Key -> Annex (Either String [URLString])+getPublicWebUrls' rs info c k 	| exportTree c = if versioning info 		then case publicurl info of 			Just url -> getversionid (const $ genericPublicUrl url)

@@ -1,72 +1,13 @@-{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  {- cabal setup file -}  import Distribution.Simple-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Setup-import Distribution.Simple.Utils (installOrdinaryFiles, rawSystemExit)-import Distribution.PackageDescription (PackageDescription(..))-import Distribution.Verbosity (Verbosity)-import System.FilePath-import Control.Applicative-import Control.Monad-import System.Directory-import Data.List-import Data.Maybe-import Control.Exception-import qualified System.Info--import qualified Build.DesktopFile as DesktopFile import qualified Build.Configure as Configure-import Build.Mans (buildMans)-import Utility.SafeCommand  main :: IO () main = defaultMainWithHooks simpleUserHooks 	{ preConf = \_ _ -> do 		Configure.run Configure.tests 		return (Nothing, [])	-	, postCopy = myPostCopy 	}--myPostCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO ()-myPostCopy _ flags pkg lbi = when (System.Info.os /= "mingw32") $ do-	installGitAnnexLinks dest verbosity pkg lbi-	installManpages      dest verbosity pkg lbi-	installDesktopFile   dest verbosity pkg lbi-  where-	dest      = fromFlag $ copyDest flags-	verbosity = fromFlag $ copyVerbosity flags--installGitAnnexLinks :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-installGitAnnexLinks copyDest verbosity pkg lbi = do-	rawSystemExit verbosity "ln"-		["-sf", "git-annex", dstBinDir </> "git-annex-shell"]-	rawSystemExit verbosity "ln"-		["-sf", "git-annex", dstBinDir </> "git-remote-tor-annex"]-  where-	dstBinDir = bindir $ absoluteInstallDirs pkg lbi copyDest--{- See http://www.haskell.org/haskellwiki/Cabal/Developer-FAQ#Installing_manpages -}-installManpages :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-installManpages copyDest verbosity pkg lbi =-	installOrdinaryFiles verbosity dstManDir =<< srcManpages-  where-	dstManDir   = mandir (absoluteInstallDirs pkg lbi copyDest) </> "man1"-	-- If mdwn2man fails, perhaps because perl is not available,-	-- we just skip installing man pages.-	srcManpages = zip (repeat "man") . map takeFileName . catMaybes-		<$> buildMans--installDesktopFile :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-installDesktopFile copyDest _verbosity pkg lbi-	| progfile copyDest == progfile NoCopyDest =-		DesktopFile.installUser (progfile copyDest)-			`catch` installerror-	| otherwise = return ()-  where-	progfile cd = bindir (absoluteInstallDirs pkg lbi cd) </> "git-annex"-	installerror :: SomeException -> IO ()-	installerror e = putStrLn ("Warning: Installation of desktop integration files did not succeed (" ++ show e ++ "); skipping.")

@@ -15,6 +15,7 @@ import Key import Types.Transfer import Types.UUID+import Types.FileMatcher import Git.FilePath import Git.Quote (StringContainingQuotedPath(..)) import Utility.FileSystemEncoding@@ -59,6 +60,15 @@  instance MkActionItem (Transfer, TransferInfo) where 	mkActionItem = uncurry ActionItemFailedTransfer++instance MkActionItem MatchInfo where+	mkActionItem (MatchingFile i) = ActionItemTreeFile (matchFile i)+	mkActionItem (MatchingInfo i) = case providedFilePath i of+		Just f -> ActionItemTreeFile f+		Nothing -> case providedKey i of+			Just k -> ActionItemKey k+			Nothing -> ActionItemOther Nothing+	mkActionItem (MatchingUserInfo _) = ActionItemOther Nothing  actionItemDesc :: ActionItem -> StringContainingQuotedPath actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = 

@@ -1,6 +1,6 @@ {- git-annex file matcher types  -- - Copyright 2013-2021 Joey Hess <id@joeyh.name>+ - Copyright 2013-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,7 +11,7 @@ import Types.Key (Key) import Types.Link (LinkType) import Types.Mime-import Utility.Matcher (Matcher, Token)+import Utility.Matcher (Matcher, Token, MatchDesc) import Utility.FileSize import Utility.FileSystemEncoding @@ -76,6 +76,8 @@ getUserInfo (Right i) = return i getUserInfo (Left e) = liftIO e +newtype MatcherDesc = MatcherDesc String+ type FileMatcherMap a = M.Map UUID (FileMatcher a)  type MkLimit a = String -> Either String (MatchFiles a)@@ -93,9 +95,11 @@ 	-- ^ does the matchAction look at information about the key? 	, matchNeedsLocationLog :: Bool 	-- ^ does the matchAction look at the location log?+	, matchDesc :: Bool -> MatchDesc+	-- ^ displayed to the user to describe whether it matched or not 	} -type FileMatcher a = Matcher (MatchFiles a)+type FileMatcher a = (Matcher (MatchFiles a), MatcherDesc)  -- This is a matcher that can have tokens added to it while it's being -- built, and once complete is compiled to an unchangeable matcher.

@@ -21,6 +21,7 @@ #ifndef mingw32_HOST_OS import Utility.LogFile import Utility.Env+import Utility.OpenFd #else import System.Win32.Process (terminateProcessById) import Utility.LockFile@@ -49,7 +50,7 @@ 			maybe noop lockPidFile pidfile  			a 		_ -> do-			nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags+			nullfd <- openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags 			redir nullfd stdInput 			redirLog =<< openlogfd 			environ <- getEnvironment@@ -95,9 +96,9 @@ lockPidFile :: FilePath -> IO () lockPidFile pidfile = do #ifndef mingw32_HOST_OS-	fd <- openFd pidfile ReadWrite (Just stdFileMode) defaultFileFlags+	fd <- openFdWithMode (toRawFilePath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags 	locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0)-	fd' <- openFd newfile ReadWrite (Just stdFileMode) defaultFileFlags+	fd' <- openFdWithMode (toRawFilePath newfile) ReadWrite (Just stdFileMode) defaultFileFlags 		{ trunc = True } 	locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0) 	case (locked, locked') of@@ -132,7 +133,7 @@ checkDaemon pidfile = bracket setup cleanup go   where 	setup = catchMaybeIO $-		openFd pidfile ReadOnly (Just stdFileMode) defaultFileFlags+		openFdWithMode (toRawFilePath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags 	cleanup (Just fd) = closeFd fd 	cleanup Nothing = return () 	go (Just fd) = catchDefaultIO Nothing $ do

@@ -19,6 +19,7 @@  import Common import Utility.DirWatcher.Types+import Utility.OpenFd  import System.Posix.Types import Foreign.C.Types@@ -110,7 +111,7 @@ 				Nothing -> walk c rest 				Just info -> do 					mfd <- catchMaybeIO $-						Posix.openFd dir Posix.ReadOnly Nothing Posix.defaultFileFlags+						openFdWithMode (toRawFilePath dir) Posix.ReadOnly Nothing Posix.defaultFileFlags 					case mfd of 						Nothing -> walk c rest 						Just fd -> do

@@ -30,6 +30,7 @@ import Utility.Monad import Utility.Path.AbsRel import Utility.FileMode+import Utility.OpenFd import Utility.LockFile.LockStatus import Utility.ThreadScheduler import Utility.Hash@@ -204,7 +205,7 @@ 				) 		Left _ -> catchMaybeIO $ do 			let setup = do-				fd <- openFd dest WriteOnly+				fd <- openFdWithMode dest WriteOnly 					(Just $ combineModes readModes) 					(defaultFileFlags {exclusive = True}) 				fdToHandle fd

@@ -24,6 +24,7 @@ import Utility.Applicative import Utility.FileMode import Utility.LockFile.LockStatus+import Utility.OpenFd  import System.IO import System.Posix.Types@@ -75,7 +76,7 @@ openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd openLockFile lockreq filemode lockfile = do 	l <- applyModeSetter filemode lockfile $ \filemode' ->-		openFd lockfile openfor filemode' defaultFileFlags+		openFdWithMode lockfile openfor filemode' defaultFileFlags 	setFdOption l CloseOnExec True 	return l   where

@@ -10,31 +10,36 @@  - Is forgiving about misplaced closing parens, so "foo and (bar or baz"  - will be handled, as will "foo and ( bar or baz ) )"  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -- - License: BSD-2-clause+ - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE Rank2Types, KindSignatures, DeriveFoldable #-}+{-# LANGUAGE DeriveFoldable, FlexibleContexts #-}  module Utility.Matcher ( 	Token(..), 	Matcher(..),+	MatchDesc(..),+	MatchResult(..), 	syntaxToken, 	generate, 	match,+	match', 	matchM, 	matchMrun,+	matchMrun', 	isEmpty, 	combineMatchers, 	introspect,+	describeMatchResult,  	prop_matcher_sane ) where  import Common -import Data.Kind+import Control.Monad.Writer  {- A Token can be an Operation of an arbitrary type, or one of a few  - predefined pieces of syntax. -}@@ -48,6 +53,17 @@ 	| MOp op 	deriving (Show, Eq, Foldable) +newtype MatchDesc = MatchDesc String++data MatchResult op+	= MatchedOperation Bool op+	| MatchedAnd+	| MatchedOr+	| MatchedNot+	| MatchedOpen+	| MatchedClose+	deriving (Show, Eq)+ {- Converts a word of syntax into a token. Doesn't handle operations. -} syntaxToken :: String -> Either String (Token op) syntaxToken "and" = Right And@@ -123,29 +139,63 @@ {- Checks if a Matcher matches, using a supplied function to check  - the value of Operations. -} match :: (op -> v -> Bool) -> Matcher op -> v -> Bool-match a m v = go m-  where-	go MAny = True-	go (MAnd m1 m2) = go m1 && go m2-	go (MOr m1 m2) =  go m1 || go m2-	go (MNot m1) = not $ go m1-	go (MOp o) = a o v+match a m v = fst $ runWriter $ match' a m v +{- Like match, but accumulates a description of why it did or didn't match. -}+match' :: (op -> v -> Bool) -> Matcher op -> v -> Writer [MatchResult op] Bool+match' a m v = matchMrun' m (\op -> pure (a op v))+ {- Runs a monadic Matcher, where Operations are actions in the monad. -} matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool-matchM m v = matchMrun m $ \o -> o v+matchM m v = matchMrun m $ \op -> op v  {- More generic running of a monadic Matcher, with full control over running- - of Operations. Mostly useful in order to match on more than one- - parameter. -}-matchMrun :: forall o (m :: Type -> Type). Monad m => Matcher o -> (o -> m Bool) -> m Bool-matchMrun m run = go m+ - of Operations. -}+matchMrun :: Monad m => Matcher op -> (op -> m Bool) -> m Bool+matchMrun m run = fst <$> runWriterT (matchMrun' m run)++{- Like matchMrun, but accumulates a description of why it did or didn't match. -}+matchMrun'+	:: (MonadWriter [MatchResult op] (t m), MonadTrans t, Monad m)+	=> Matcher op+	-> (op -> m Bool)+	-> t m Bool+matchMrun' m run = go m   where 	go MAny = return True-	go (MAnd m1 m2) = go m1 <&&> go m2-	go (MOr m1 m2) =  go m1 <||> go m2-	go (MNot m1) = liftM not (go m1)-	go (MOp o) = run o+	go (MAnd m1 m2) = do+		tell [MatchedOpen]+		r1 <- go m1+		if r1 +			then do+				tell [MatchedAnd]+				r <- go m2+				tell [MatchedClose]+				return r+			else do+				tell [MatchedClose]+				return False+	go (MOr m1 m2) = do+		tell [MatchedOpen]+		r1 <- go m1+		if r1+			then do+				tell [MatchedClose]+				return True+			else do+				tell [MatchedOr]+				r <- go m2+				tell [MatchedClose]+				return r+	go (MNot m1) = do+		tell [MatchedOpen, MatchedNot]+		r <- liftM not (go m1)+		tell [MatchedClose]+		return r+	go (MOp op) = do+		r <- lift (run op)+		tell [MatchedOperation r op]+		return r  {- Checks if a matcher contains no limits. -} isEmpty :: Matcher a -> Bool@@ -163,6 +213,57 @@ {- Checks if anything in the matcher meets the condition. -} introspect :: (a -> Bool) -> Matcher a -> Bool introspect = any++{- Converts a [MatchResult] into a description of what matched and didn't+ - match. Returns Nothing when the matcher didn't contain any operations+ - and so matched by default. -}+describeMatchResult :: (op -> Bool -> MatchDesc) -> [MatchResult op] -> String -> Maybe String+describeMatchResult _ [] _ = Nothing+describeMatchResult descop l prefix = Just $+	prefix ++ unwords (go $ simplify True l)+  where+ 	go [] = []+	go (MatchedOperation b op:rest) = +		let MatchDesc d = descop op b+		in d : go rest+	go (MatchedAnd:rest) = "and" : go rest+	go (MatchedOr:rest) = "or" : go rest+	go (MatchedNot:rest) = "not" : go rest+	go (MatchedOpen:rest) = "(" : go rest+	go (MatchedClose:rest) = ")" : go rest++	-- Remove unncessary outermost parens+	simplify True (MatchedOpen:rest) = case lastMaybe rest of+		Just MatchedClose -> simplify False (dropFromEnd 1 rest)+		_ -> simplify False rest+	-- (foo or bar) or baz => foo or bar or baz+	simplify _ (MatchedOpen:o1@(MatchedOperation {}):MatchedOr:o2@(MatchedOperation {}):MatchedClose:MatchedOr:rest) = +		o1:MatchedOr:o2:MatchedOr:simplify False rest+	-- (foo and bar) and baz => foo and bar and baz+	simplify _ (MatchedOpen:o1@(MatchedOperation {}):MatchedAnd:o2@(MatchedOperation {}):MatchedClose:MatchedAnd:rest) = +		o1:MatchedAnd:o2:MatchedAnd:simplify False rest+	-- or (foo) => or foo+	simplify _ (MatchedOr:MatchedOpen:o@(MatchedOperation {}):MatchedClose:rest) =+		MatchedOr:o:simplify False rest+	-- and (foo) => and foo+	simplify _ (MatchedAnd:MatchedOpen:o@(MatchedOperation {}):MatchedClose:rest) =+		MatchedAnd:o:simplify False rest+	-- (not foo) => not foo+	simplify _ (MatchedOpen:MatchedNot:o@(MatchedOperation {}):MatchedClose:rest) =+		MatchedNot:o:simplify False rest+	-- ((foo bar)) => (foo bar)+	simplify _ (MatchedOpen:MatchedOpen:rest) =+		MatchedOpen : simplify False (removeclose (0 :: Int) rest)+	simplify _ (v:rest) = v : simplify False rest+	simplify _ v = v++	removeclose n (MatchedOpen:rest) =+		MatchedOpen : removeclose (n+1) rest+	removeclose n (MatchedClose:rest)+		| n > 0 = MatchedClose : removeclose (n-1) rest+		| otherwise = rest+	removeclose n (v:rest) = v : removeclose n rest+	removeclose _ [] = []  prop_matcher_sane :: Bool prop_matcher_sane = and

@@ -0,0 +1,27 @@+{- openFd wrapper to support old versions of unix package.+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.OpenFd where++#ifndef mingw32_HOST_OS++import System.Posix.IO.ByteString+import System.Posix.Types+import System.FilePath.ByteString (RawFilePath)++openFdWithMode :: RawFilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd+#if MIN_VERSION_unix(2,8,0)+openFdWithMode f openmode filemode flags = +	openFd f openmode (flags { creat = filemode })+#else+openFdWithMode = openFd+#endif++#endif

@@ -55,7 +55,6 @@  import Network.URI import Network.HTTP.Types-import qualified Network.Connection as NC import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as B8@@ -745,8 +744,8 @@ 		case partitionEithers (map checkrestriction addrs) of 			((e:_es), []) -> throwIO e 			(_, as)-				| null as -> throwIO $ -					NC.HostNotResolved hostname+				| null as -> giveup $ +					"cannot resolve host " ++ hostname 				| otherwise -> return $ 					(limitresolve p) as ++ ps 	checkrestriction addr = maybe (Right addr) Left $

@@ -19,31 +19,32 @@ #ifndef mingw32_HOST_OS import Utility.Data import Control.Applicative+import System.Posix.User+#if MIN_VERSION_unix(2,8,0)+import System.Posix.User.ByteString (UserEntry) #endif+#endif -import System.PosixCompat.User import Prelude  {- Current user's home directory.  -  - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath-myHomeDir = either giveup return =<< myVal env homeDirectory-  where+myHomeDir = either giveup return =<< #ifndef mingw32_HOST_OS-	env = ["HOME"]+	myVal ["HOME"] homeDirectory #else-	env = ["USERPROFILE", "HOME"] -- HOME is used in Cygwin+	myVal ["USERPROFILE", "HOME"] -- HOME is used in Cygwin #endif  {- Current user's user name. -} myUserName :: IO (Either String String)-myUserName = myVal env userName-  where+myUserName = #ifndef mingw32_HOST_OS-	env = ["USER", "LOGNAME"]+	myVal ["USER", "LOGNAME"] userName #else-	env = ["USERNAME", "USER", "LOGNAME"]+	myVal ["USERNAME", "USER", "LOGNAME"] #endif  myUserGecos :: IO (Maybe String)@@ -54,16 +55,20 @@ myUserGecos = eitherToMaybe <$> myVal [] userGecos #endif +#ifndef mingw32_HOST_OS myVal :: [String] -> (UserEntry -> String) -> IO (Either String String) myVal envvars extract = go envvars   where 	go [] = either (const $ envnotset) (Right . extract) <$> get 	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v-#ifndef mingw32_HOST_OS 	-- This may throw an exception if the system doesn't have a 	-- passwd file etc; don't let it crash. 	get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID #else-	get = return envnotset+myVal :: [String] -> IO (Either String String)+myVal envvars = go envvars+  where+	go [] = return envnotset+	go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v #endif 	envnotset = Left ("environment not set: " ++ show envvars)

@@ -1,35 +1,51 @@ # NAME -git-annex diffdriver - external git diff driver shim+git-annex diffdriver - git diff driver  # SYNOPSIS +git annex diffdriver --text [-- --opts --]+ git annex diffdriver `-- cmd --opts --`  # DESCRIPTION -This is an external git diff driver shim. Normally, when using `git diff`-with an external diff driver, it will not see the contents of annexed-files, since git passes to it the git-annex symlinks or pointer files.-This command works around the problem, by running the -real external diff driver, and passing it the paths to the annexed content.+Normally, `git diff` when run on annexed files displays the changes that+are staged in git, eg annex symlinks and pointers. This command allows+`git diff` to diff the content of annexed files instead. -To use this, you will need to have installed some git external diff driver-command. This is not the regular diff command; it takes a git-specific-input. See git's documentation of `GIT_EXTERNAL_DIFF` and+This command can be used either as a simple text differ,+or as a shim that runs an external git diff driver.++If some of your annexed files are textual in form, and can be usefully+diffed with diff(1), you can configure git to use this command to diff+them, by configuring `.gitattributes` to contain eg `*.txt diff=annextextdiff`+and setting `git config diff.annextextdiff.command "git annex diffdriver --text"`.++If your annexed files are not textual in form, you will need an external+diff driver program that is able to diff the file format(s) you use.+See git's documentation of `GIT_EXTERNAL_DIFF` and gitattributes(5)'s documentation of external diff drivers. -Configure git to use "git-annex diffdriver -- cmd params --"+Normally, when using `git diff` with an external diff driver, it will not+see the contents of annexed files, since git passes to it the git-annex+symlinks or pointer files. This command works around the problem, by+running the real external diff driver, and passing it the paths to the+annexed content. Configure git to use "git-annex diffdriver -- cmd params --" as the external diff driver, where cmd is the external diff driver you want it to run, and params are any extra parameters to pass to it. Note the trailing "--", which is required. -For example, set `GIT_EXTERNAL_DIFF=git-annex diffdriver -- j-c-diff --`+For example, to use the j-c-diff program as the external diff driver, +set `GIT_EXTERNAL_DIFF="git-annex diffdriver -- j-c-diff --"`  # OPTIONS -Normally "--" followed by the diff driver command, its options, -and another "--"+To diff text files with diff(1), use the "--text" option.+To pass additional options to diff(1), use eg "--text -- --color --"++To use an external diff driver command, the options must start with+"--" followed by the diff driver command, its options, and another "--"  Also the [[git-annex-common-options]](1) can be used. 

@@ -28,6 +28,14 @@   the last repository that is storing their content. Data loss can   result from using this option. +* `--jobs=N` `-JN`++  Runs multiple drop jobs in parallel. This is particularly useful+  when git-annex has to contact remotes to check if it can drop content.+  For example: `-J4`  ++  Setting this to "cpus" will run one job per CPU core.+ * `--json`    Enable JSON output. This is intended to be parsed by programs that use

@@ -72,7 +72,7 @@   The default template is '${feedtitle}/${itemtitle}${extension}'      The available variables in the template include these that-  are information about the feed: feedtitle, feedauthor+  are information about the feed: feedtitle, feedauthor, feedurl    And these that are information about individual items in the feed:   itemtitle, itemauthor, itemsummary, itemdescription, itemrights,

@@ -53,6 +53,11 @@   Tell what the mime encoding of the file is. Only needed when using   --largefiles with a mimeencoding= expression. +* `--explain`++  Display explanation of what parts of the preferred content expression+  match, and which parts don't match.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO

@@ -127,6 +127,12 @@   Matches only when git-annex believes content is present in   all repositories in the specified group. +* `--onlyingroup=groupname`++  Matches only when git-annex believes content is present in at least one+  repository that is in the specified group, and is not present in any+  repositories that are not in the specified group.+ * `--smallerthan=size` * `--largerthan=size` 

@@ -73,6 +73,9 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +  Note that unlike all other commands that support `--json`, this command+  outputs different types of json objects in different circumstances.+ * `--json-progress`    Include progress objects in JSON output.

@@ -123,6 +123,12 @@   Matches only files that git-annex believes are present in all repositories   in the specified group. +* `onlyingroup=groupname`++  Matches files that git-annex believes are present in at least one+  repository that is in the specified group, and are not present in any+  repositories that are not in the specified group.+ * `smallerthan=size` / `largerthan=size`    Matches only files whose content is smaller than, or larger than the@@ -282,6 +288,13 @@ For example, git annex find --want-get --not --in . will find all the files that git annex get --auto will want to get, and git annex find --want-drop --in . will find all the files that git annex drop --auto will want to drop.++The --explain option can be used to understand why a complex preferred+content expression matches or fails to match. The expression will+be displayed, with each term followed by "[TRUE]" or "[FALSE]" to indicate+the value. Irrelevant terms will be ommitted from the explanation,+for example `"exclude=* and copies=1"` will be displayed as +`"exclude=*[FALSE]"`  # SEE ALSO 

@@ -33,7 +33,7 @@ Normally this tries to download the content of each annexed file, from any remote that it's pulling from that has a copy.  To control which files it downloads, configure the preferred-content of the local repository.It will also drop files from a+content of the local repository. It will also drop files from a remote that are not preferred content of the remote. See [[git-annex-preferred-content]](1). @@ -135,6 +135,8 @@ [[git-annex-sync]](1)  [[git-annex-preferred-content]](1)++[[git-annex-satisfy]](1)  # AUTHOR 

@@ -134,6 +134,8 @@  [[git-annex-preferred-content]](1) +[[git-annex-satisfy]](1)+ # AUTHOR  Joey Hess <id@joeyh.name>

@@ -54,6 +54,20 @@   Specify the key-value backend to use when checking if a file is known   with the `--known` option. +* `--guesskeys`++  With this option, each specified source file is checked to see if it+  has the name of a git-annex key, and if so it is imported as the content+  of that key.++  This can be used to pluck git-annex objects out of `lost+found`,+  as long as the original filename has not been lost,+  and is particularly useful when using key-value backends that don't hash+  to the content of a file.++  When the key-value backend does support hashing, the content of the file+  is verified before importing it.+ * `--json`    Enable JSON output. This is intended to be parsed by programs that use

@@ -0,0 +1,66 @@+# NAME++git-annex satisfy - transfer and drop content as configured++# SYNOPSIS++git annex satisfy `[remote ...]`++# DESCRIPTION++This transfers and drops content of annexed files to work toward satisfying+the preferred content settings of the local repository and remotes.++It does the same thing as `git-annex sync --content` without the pulling+and pushing of git repositories, and without changing the trees that are+imported to or exported from special remotes.++# OPTIONS++* `[remote]`++  By default this command operates on all remotes, except for remotes+  that have `remote.<name>.annex-sync` set to false.++  By specifying the names of remotes (or remote groups), you can control+  which ones to operate on.++* `--content-of=path` `-C path`++  Operate on only files in the specified path. The default is to operate on+  all files in the working tree.++  This option can be repeated multiple times with different paths.++* `--jobs=N` `-JN`++  Enables parallel processing with up to the specified number of jobs+  running at once. For example: `-J10`++  Setting this to "cpus" will run one job per CPU core.++* `--all` `-A`++  Usually this command operates on annexed files in the current branch.+  This option makes it operate on all available versions of all annexed files+  (when preferred content settings allow).++  Note that preferred content settings that use `include=` or `exclude=`+  will only match the version of files currently in the work tree, but not+  past versions of files.++* Also the [[git-annex-common-options]](1) can be used.++# SEE ALSO++[[git-annex]](1)++[[git-annex-sync]](1)++[[git-annex-preferred-content]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.

@@ -76,6 +76,8 @@  [[git-annex-assist]](1) +[[git-annex-satisfy]](1)+ # AUTHOR  Joey Hess <id@joeyh.name>

@@ -138,6 +138,12 @@      See [[git-annex-assist]](1) for details. +* `satisfy [remote ...]`++  Satisfy preferred content settings by transferring and dropping content.+  +  See [[git-annex-satisfy]](1) for details.+ * `mirror [path ...] [--to=remote|--from=remote]`    Mirror content of files to/from another repository.@@ -731,8 +737,7 @@  * `diffdriver` -  This can be used to make `git diff` use an external diff driver with-  annexed files.+  This can be used to make `git diff` diff the content of annexed files.    See [[git-annex-diffdriver]](1) for details. 

@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20230626+Version: 10.20230802 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -35,6 +35,7 @@ -- make cabal install git-annex work. Extra-Source-Files:   stack.yaml+  stack-lts-18.13.yaml   README   CHANGELOG   NEWS@@ -118,6 +119,7 @@   doc/git-annex-restage.mdwn   doc/git-annex-resolvemerge.mdwn   doc/git-annex-rmurl.mdwn+  doc/git-annex-satisfy.mdwn   doc/git-annex-schedule.mdwn   doc/git-annex-semitrust.mdwn   doc/git-annex-setkey.mdwn@@ -298,13 +300,19 @@   location: git://git-annex.branchable.com/  custom-setup-  Setup-Depends: base (>= 4.11.1.0 && < 5.0), split, unix-compat (< 0.7), -    filepath, exceptions, bytestring, IfElse, data-default,+  Setup-Depends:+    base (>= 4.11.1.0 && < 5.0),+    split,+    filepath,+    exceptions,+    bytestring,     filepath-bytestring (>= 1.4.2.1.4),     process (>= 1.6.3),     time (>= 1.5.0),     directory (>= 1.2.7.0),-    async, utf8-string, transformers, Cabal (< 4.0)+    async,+    utf8-string,+    Cabal (< 4.0)  Executable git-annex   Main-Is: git-annex.hs@@ -322,7 +330,7 @@    case-insensitive,    random,    dlist,-   unix-compat (>= 0.5 && < 0.7),+   unix-compat (>= 0.5 && < 0.8),    SafeSemaphore,    async,    directory (>= 1.2.7.0),@@ -341,7 +349,6 @@    bloomfilter (>= 2.0.0),    edit-distance,    resourcet,-   connection (>= 0.2.6),    http-client (>= 0.5.3),    http-client-tls,    http-types (>= 0.7),@@ -789,6 +796,7 @@     Command.ResolveMerge     Command.Restage     Command.RmUrl+    Command.Satisfy     Command.Schedule     Command.Semitrust     Command.SendKey@@ -1125,6 +1133,7 @@     Utility.MoveFile     Utility.Network     Utility.NotificationBroadcaster+    Utility.OpenFd     Utility.OptParse     Utility.OSX     Utility.PID

@@ -0,0 +1,27 @@+flags:+  git-annex:+    production: true+    assistant: true+    pairing: true+    torrentparser: true+    magicmime: false+    dbus: false+    debuglocks: false+    benchmark: true+    gitlfs: true+packages:+- '.'+resolver: lts-18.13+extra-deps:+- IfElse-0.85+- aws-0.22+- bloomfilter-2.0.1.0+- git-lfs-1.2.0+- http-client-restricted-0.0.4+- network-multicast-0.3.2+- sandi-0.5+- torrent-10000.1.1+- base16-bytestring-0.1.1.7+- base64-bytestring-1.0.0.3+- bencode-0.6.1.1+- http-client-0.7.9

@@ -11,17 +11,13 @@     gitlfs: true packages: - '.'-resolver: lts-18.13+resolver: nightly-2023-08-01 extra-deps:-- IfElse-0.85-- aws-0.22-- bloomfilter-2.0.1.0-- git-lfs-1.2.0-- http-client-restricted-0.0.4-- network-multicast-0.3.2-- sandi-0.5+- git-lfs-1.2.1+- http-client-restricted-0.1.0 - torrent-10000.1.1-- base16-bytestring-0.1.1.7-- base64-bytestring-1.0.0.3 - bencode-0.6.1.1-- http-client-0.7.9+- feed-1.3.2.1+- git: https://github.com/sjakobi/bloomfilter.git+  commit: fb79b39c44404fd791a3bed973e9d844fb084f1e+allow-newer: true