packages feed

git-annex 10.20230407 → 10.20230626

raw patch · 311 files changed

+4514/−2051 lines, 311 filesdep ~optparse-applicative

Dependency ranges changed: optparse-applicative

Files

Annex.hs view
@@ -183,8 +183,8 @@ 	, hashobjecthandle :: Maybe (ResourcePool HashObjectHandle) 	, checkattrhandle :: Maybe (ResourcePool CheckAttrHandle) 	, checkignorehandle :: Maybe (ResourcePool CheckIgnoreHandle)-	, globalnumcopies :: Maybe NumCopies-	, globalmincopies :: Maybe MinCopies+	, globalnumcopies :: Maybe (Maybe NumCopies)+	, globalmincopies :: Maybe (Maybe MinCopies) 	, limit :: ExpandableMatcher Annex 	, timelimit :: Maybe (Duration, POSIXTime) 	, sizelimit :: Maybe (TVar Integer)
Annex/Action.hs view
@@ -37,14 +37,14 @@ action a = tryNonAsync a >>= \case 	Right () -> return True 	Left e -> do-		warning (show e)+		warning (UnquotedString (show e)) 		return False  verifiedAction :: Annex Verification -> Annex (Bool, Verification) verifiedAction a = tryNonAsync a >>= \case 	Right v -> return (True, v) 	Left e -> do-		warning (show e)+		warning (UnquotedString (show e)) 		return (False, UnVerified)
Annex/AdjustedBranch.hs view
@@ -67,7 +67,9 @@ import qualified Database.Keys import Config import Logs.View (is_branchView)+import Logs.AdjustedBranchUpdate +import Data.Time.Clock.POSIX import qualified Data.Map as M  class AdjustTreeItem t where@@ -209,7 +211,7 @@ 		let adjbranch = adjBranch $ originalToAdjusted origbranch adj 		ifM (inRepo (Git.Ref.exists adjbranch) <&&> (not <$> Annex.getRead Annex.force) <&&> pure (not (is_branchView origbranch))) 			( do-				mapM_ (warning . unwords)+				mapM_ (warning . UnquotedString . unwords) 					[ [ "adjusted branch" 					  , Git.Ref.describe adjbranch 					  , "already exists."@@ -223,9 +225,13 @@ 					] 				return False 			, do+				starttime <- liftIO getPOSIXTime 				b <- preventCommits $ const $  					adjustBranch adj origbranch-				checkoutAdjustedBranch b False+				ok <- checkoutAdjustedBranch b False+				when ok $+					recordAdjustedBranchUpdateFinished starttime+				return ok 			)  checkoutAdjustedBranch :: AdjBranch -> Bool -> Annex Bool@@ -255,20 +261,22 @@ 			_ <- propigateAdjustedCommits' origbranch adj commitlck 			 			origheadfile <- inRepo $ readFileStrict . Git.Ref.headFile+			origheadsha <- inRepo (Git.Ref.sha currbranch)+			+			b <- adjustBranch adj origbranch  			-- Git normally won't do anything when asked to check 			-- out the currently checked out branch, even when its 			-- ref has changed. Work around this by writing a raw 			-- sha to .git/HEAD.-			newheadfile <- inRepo (Git.Ref.sha currbranch) >>= \case-				Just headsha -> do+			newheadfile <- case origheadsha of+				Just s -> do 					inRepo $ \r -> do-						let newheadfile = fromRef headsha+						let newheadfile = fromRef s 						writeFile (Git.Ref.headFile r) newheadfile 						return (Just newheadfile) 				_ -> return Nothing 	-			b <- adjustBranch adj origbranch 			return (b, origheadfile, newheadfile) 	 		-- Make git checkout quiet to avoid warnings about@@ -302,18 +310,22 @@ adjustedBranchRefresh :: AssociatedFile -> Annex a -> Annex a adjustedBranchRefresh _af a = do 	r <- a-	annexAdjustedBranchRefresh <$> Annex.getGitConfig >>= \case-		0 -> return ()-		n -> go n+	go 	return r   where-	go n = getCurrentBranch >>= \case+	go = getCurrentBranch >>= \case 		(Just origbranch, Just adj) ->-			unless (adjustmentIsStable adj) $-				ifM (checkcounter n)-					( update adj origbranch+			unless (adjustmentIsStable adj) $ do+				recordAdjustedBranchUpdateNeeded+				n <- annexAdjustedBranchRefresh <$> Annex.getGitConfig+				unless (n == 0) $ ifM (checkcounter n)+					-- This is slow, it would be better to incrementally+					-- adjust the AssociatedFile, and only call this once+					-- at shutdown to handle cases where not all+					-- AssociatedFiles are known.+					( adjustedBranchRefreshFull' adj origbranch 					, Annex.addCleanupAction AdjustedBranchUpdate $-						adjustedBranchRefreshFull adj origbranch+						adjustedBranchRefreshFull' adj origbranch 					) 		_ -> return () 	@@ -327,23 +339,24 @@ 			    !s' = s { Annex.adjustedbranchrefreshcounter = c' } 			    in pure (s', enough) -	-- This is slow, it would be better to incrementally-	-- adjust the AssociatedFile, and only call this once-	-- at shutdown to handle cases where not all-	-- AssociatedFiles are known.-	update adj origbranch =-		adjustedBranchRefreshFull adj origbranch- {- Slow, but more dependable version of adjustedBranchRefresh that  - does not rely on all AssociatedFiles being known. -} adjustedBranchRefreshFull :: Adjustment -> OrigBranch -> Annex ()-adjustedBranchRefreshFull adj origbranch = do+adjustedBranchRefreshFull adj origbranch =+	whenM isAdjustedBranchUpdateNeeded $ do+		adjustedBranchRefreshFull' adj origbranch++adjustedBranchRefreshFull' :: Adjustment -> OrigBranch -> Annex ()+adjustedBranchRefreshFull' adj origbranch = do 	-- Restage pointer files so modifications to them due to get/drop 	-- do not prevent checking out the updated adjusted branch. 	restagePointerFiles =<< Annex.gitRepo+	starttime <- liftIO getPOSIXTime 	let adjbranch = originalToAdjusted origbranch adj-	unlessM (updateAdjustedBranch adj adjbranch origbranch) $-		warning $ unwords [ "Updating adjusted branch failed." ]+	ifM (updateAdjustedBranch adj adjbranch origbranch)+		( recordAdjustedBranchUpdateFinished starttime+		, warning "Updating adjusted branch failed."+		)  adjustToCrippledFileSystem :: Annex () adjustToCrippledFileSystem = do@@ -497,7 +510,7 @@ 			Just currcommit -> 				newcommits >>= go origsha False >>= \case 					Left e -> do-						warning e+						warning (UnquotedString e) 						return (Nothing, return ()) 					Right newparent -> return 						( Just newparent@@ -505,7 +518,8 @@ 						) 			Nothing -> return (Nothing, return ()) 		Nothing -> do-			warning $ "Cannot find basis ref " ++ fromRef basis ++ "; not propagating adjusted commits to original branch " ++ fromRef origbranch+			warning $ UnquotedString $ +				"Cannot find basis ref " ++ fromRef basis ++ "; not propagating adjusted commits to original branch " ++ fromRef origbranch 			return (Nothing, return ())   where 	(BasisBranch basis) = basisBranch adjbranch
Annex/AdjustedBranch/Merge.hs view
@@ -98,7 +98,7 @@ 				-- (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 $ "Merging into " ++ fromRef (Git.Ref.base 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
Annex/BloomFilter.hs view
@@ -27,7 +27,8 @@ 	accuracy <- bloomAccuracy 	case safeSuggestSizing capacity (1 / fromIntegral accuracy) of 		Left e -> do-			warning $ "bloomfilter " ++ e ++ "; falling back to sane value"+			warning $ UnquotedString $+				"bloomfilter " ++ e ++ "; falling back to sane value" 			-- precaulculated value for 500000 (1/10000000) 			return (16777216,23) 		Right v -> return v
Annex/Branch.hs view
@@ -130,7 +130,7 @@ 			, Param $ fromRef name 			, Param $ fromRef originname 			]-		fromMaybe (error $ "failed to create " ++ fromRef name)+		fromMaybe (giveup $ "failed to create " ++ fromRef name) 			<$> branchsha 	go False = withIndex' True $ do 		-- Create the index file. This is not necessary,@@ -243,7 +243,7 @@ 				" into " ++ fromRef name 		localtransitions <- getLocalTransitions 		unless (null tomerge) $ do-			showSideAction merge_desc+			showSideAction (UnquotedString merge_desc) 			mapM_ checkBranchDifferences refs 			mergeIndex jl refs 		let commitrefs = nub $ fullname:refs
Annex/CheckAttr.hs view
@@ -6,6 +6,7 @@  -}  module Annex.CheckAttr (+	annexAttrs, 	checkAttr, 	checkAttrs, 	checkAttrStop,@@ -29,8 +30,11 @@ 	]  checkAttr :: Git.Attr -> RawFilePath -> Annex String-checkAttr attr file = withCheckAttrHandle $ \h -> -	liftIO $ Git.checkAttr h attr file+checkAttr attr file = withCheckAttrHandle $ \h -> do+	r <- liftIO $ Git.checkAttr h attr file+	if r == Git.unspecifiedAttr+		then return ""+		else return r  checkAttrs :: [Git.Attr] -> RawFilePath -> Annex [String] checkAttrs attrs file = withCheckAttrHandle $ \h ->
Annex/Common.hs view
@@ -10,6 +10,7 @@ import Annex.Locations as X import Annex.Debug as X (fastDebug, debug) import Messages as X+import Git.Quote as X #ifndef mingw32_HOST_OS import System.Posix.IO as X hiding (createPipe) #endif
Annex/Content.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Annex.Content ( 	inAnnex,@@ -101,6 +102,7 @@ import Utility.InodeCache import Utility.CopyFile import Utility.Metered+import Utility.FileMode import qualified Utility.RawFilePath as R  import qualified System.FilePath.ByteString as P@@ -170,7 +172,7 @@ type ContentLocker = RawFilePath -> Maybe LockFile -> (Annex (Maybe LockHandle), Maybe (Annex (Maybe LockHandle)))  #ifndef mingw32_HOST_OS-posixLocker :: (Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)) -> LockFile -> Annex (Maybe LockHandle)+posixLocker :: (Maybe ModeSetter -> LockFile -> Annex (Maybe LockHandle)) -> LockFile -> Annex (Maybe LockHandle) posixLocker takelock lockfile = do 	mode <- annexFileMode 	modifyContentDirWhenExists lockfile $@@ -447,7 +449,7 @@ checkSecureHashes' key = checkSecureHashes key >>= \case 	Nothing -> return True 	Just msg -> do-		warning $ msg ++ "to annex objects"+		warning $ UnquotedString $ msg ++ "to annex objects" 		return False  data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop@@ -760,9 +762,10 @@ 	go [] [] = return False 	go [] errs@((_, err):_) = do 		if listfailedurls-			then warning $ unlines $ flip map errs $ \(u, err') ->-				u ++ " " ++ err'-			else warning err+			then warning $ UnquotedString $+				unlines $ flip map errs $ \(u, err') ->+					u ++ " " ++ err'+			else warning $ UnquotedString err 		return False  {- Copies a key's content, when present, to a temp file.
Annex/Content/LowLevel.hs view
@@ -126,7 +126,8 @@ 				let delta = need + reserve - have - alreadythere + inprogress 				let ok = delta <= 0 				unless ok $-					warning $ needMoreDiskSpace delta+					warning $ UnquotedString $ +						needMoreDiskSpace delta 				return ok 			_ -> return True 	)
Annex/Difference.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.Difference ( 	module Types.Difference, 	setDifferences,
Annex/Export.hs view
@@ -15,6 +15,7 @@ import Types.Key import qualified Git import qualified Types.Remote as Remote+import Git.Quote import Messages  import Data.Maybe@@ -63,7 +64,7 @@ 		(False, True) -> ("imported from", "git-annex import") 		(True, False) -> ("exported to", "git-annex export") 		_ -> ("exported to and/or imported from", "git-annex export")-	toplevelWarning True $ unwords+	toplevelWarning True $ UnquotedString $ unwords 		[ "Conflict detected. Different trees have been" 		, ops, Remote.name r ++ ". Use" 		, resolvcmd
Annex/FileMatcher.hs view
@@ -43,7 +43,6 @@ import Types.Remote (RemoteConfig) import Types.ProposedAccepted import Annex.CheckAttr-import Git.CheckAttr (unspecifiedAttr) import qualified Git.Config #ifdef WITH_MAGICMIME import Annex.Magic@@ -233,7 +232,7 @@ 		return $ const $ return matcher 	go v = return $ \file -> do 		expr <- checkAttr "annex.largefiles" file-		if null expr || expr == unspecifiedAttr+		if null expr 			then case v of 				HasGlobalConfig (Just expr') -> 					mkmatcher expr' "git-annex config"
Annex/GitOverlay.hs view
@@ -73,7 +73,7 @@ 	(const a)   where 	modlocation l@(Local {}) = l { worktree = Just (toRawFilePath d) }-	modlocation _ = error "withWorkTree of non-local git repo"+	modlocation _ = giveup "withWorkTree of non-local git repo"  {- Runs an action with the git index file and HEAD, and a few other  - files that are related to the work tree coming from an overlay
Annex/Hook.hs view
@@ -66,7 +66,8 @@ hookWarning :: Git.Hook -> String -> Annex () hookWarning h msg = do 	r <- gitRepo-	warning $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg+	warning $ UnquotedString $+		Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg  {- Runs a hook. To avoid checking if the hook exists every time,  - the existing hooks are cached. -}@@ -84,4 +85,4 @@   where 	run = unlessM (inRepo $ Git.runHook hook) $ do 		h <- fromRepo $ Git.hookFile hook-		warning $ h ++ " failed"+		warning $ UnquotedString $ h ++ " failed"
Annex/Import.hs view
@@ -1,6 +1,6 @@ {- git-annex import from remotes  -- - Copyright 2019-2021 Joey Hess <id@joeyh.name>+ - Copyright 2019-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -14,6 +14,9 @@ 	buildImportTrees, 	recordImportTree, 	canImportKeys,+	ImportResult(..),+	Imported,+	importChanges, 	importKeys, 	makeImportMatcher, 	getImportableContents,@@ -27,6 +30,7 @@ import Git.Sha import Git.FilePath import Git.History+import qualified Git.DiffTree import qualified Git.Ref import qualified Git.Branch import qualified Annex@@ -38,6 +42,7 @@ import Annex.HashObject import Annex.Transfer import Annex.CheckIgnore+import Annex.CatFile import Annex.VectorClock import Command import Backend@@ -46,6 +51,8 @@ import Messages.Progress import Utility.DataUnits import Utility.Metered+import Utility.Hash (sha1s)+import Logs.Import import Logs.Export import Logs.Location import Logs.PreferredContent@@ -62,6 +69,7 @@ import qualified Data.Set as S import qualified System.FilePath.Posix.ByteString as Posix import qualified System.FilePath.ByteString as P+import qualified Data.ByteArray.Encoding as BA  {- Configures how to build an import tree. -} data ImportTreeConfig@@ -98,9 +106,9 @@ 	:: Remote 	-> ImportTreeConfig 	-> ImportCommitConfig-	-> ImportableContentsChunkable Annex (Either Sha Key)+	-> Imported 	-> Annex (Maybe Ref)-buildImportCommit remote importtreeconfig importcommitconfig importable =+buildImportCommit remote importtreeconfig importcommitconfig imported = 	case importCommitTracking importcommitconfig of 		Nothing -> go Nothing 		Just trackingcommit -> inRepo (Git.Ref.tree trackingcommit) >>= \case@@ -108,8 +116,8 @@ 			Just _ -> go (Just trackingcommit)   where 	go trackingcommit = do-		(imported, updatestate) <- recordImportTree remote importtreeconfig importable-		buildImportCommit' remote importcommitconfig trackingcommit imported >>= \case+		(importedtree, updatestate) <- recordImportTree remote importtreeconfig imported+		buildImportCommit' remote importcommitconfig trackingcommit importedtree >>= \case 			Just finalcommit -> do 				updatestate 				return (Just finalcommit)@@ -123,11 +131,11 @@ recordImportTree 	:: Remote 	-> ImportTreeConfig-	-> ImportableContentsChunkable Annex (Either Sha Key)+	-> Imported 	-> Annex (History Sha, Annex ())-recordImportTree remote importtreeconfig importable = do-	imported@(History finaltree _) <- buildImportTrees basetree subdir importable-	return (imported, updatestate finaltree)+recordImportTree remote importtreeconfig imported = do+	importedtree@(History finaltree _) <- buildImportTrees basetree subdir imported+	return (importedtree, updatestate finaltree)   where 	basetree = case importtreeconfig of 		ImportTree -> emptyTree@@ -259,25 +267,129 @@ 			parents <- mapM (mknewcommits oldhc old) (S.toList hs) 			mkcommit parents importedtree -{- Builds a history of git trees reflecting the ImportableContents.+{- Builds a history of git trees for an import.  -- - When a subdir is provided, imported tree is grafted into the basetree at- - that location, replacing any object that was there.+ - When a subdir is provided, the imported tree is grafted into + - the basetree at that location, replacing any object that was there.  -} buildImportTrees 	:: Ref 	-> Maybe TopFilePath-	-> ImportableContentsChunkable Annex (Either Sha Key)+	-> Imported 	-> Annex (History Sha)-buildImportTrees basetree msubdir (ImportableContentsComplete importable) = do+buildImportTrees basetree msubdir (ImportedFull imported) = +	buildImportTreesGeneric convertImportTree basetree msubdir imported+buildImportTrees basetree msubdir (ImportedDiff (LastImportedTree oldtree) imported) = do+	importtree <- if null (importableContents imported)+		then pure oldtree+		else applydiff 	repo <- Annex.gitRepo-	withMkTreeHandle repo $ buildImportTrees' basetree msubdir importable-buildImportTrees basetree msubdir importable@(ImportableContentsChunked {}) = do+	t <- withMkTreeHandle repo $+		graftImportTree basetree msubdir importtree+	-- Diffing is not currently implemented when the history is not empty.+	return (History t mempty)+  where+	applydiff = do+		let (removed, new) = partition isremoved+			(importableContents imported)+		newtreeitems <- catMaybes <$> mapM mktreeitem new+		let removedfiles = map (mkloc . fst) removed+		inRepo $ adjustTree+			(pure . Just) +			-- ^ keep files that are not added/removed the same+			newtreeitems+			(\_oldti newti -> newti)+			-- ^ prefer newly added version of file+			removedfiles+			oldtree+	+	mktreeitem (loc, DiffChanged v) = +		Just <$> mkImportTreeItem msubdir loc v+	mktreeitem (_, DiffRemoved) = +		pure Nothing++	mkloc = asTopFilePath . fromImportLocation+		+	isremoved (_, v) = v == DiffRemoved++convertImportTree :: Maybe TopFilePath -> [(ImportLocation, Either Sha Key)] -> Annex Tree+convertImportTree msubdir ls = +	treeItemsToTree <$> mapM (uncurry $ mkImportTreeItem msubdir) ls++mkImportTreeItem :: Maybe TopFilePath -> ImportLocation -> Either Sha Key -> Annex TreeItem+mkImportTreeItem msubdir loc v = case v of+	Right k -> do+		relf <- fromRepo $ fromTopFilePath topf+		symlink <- calcRepo $ gitAnnexLink relf k+		linksha <- hashSymlink symlink+		return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha+	Left sha -> +		return $ TreeItem treepath (fromTreeItemType TreeFile) sha+  where+	lf = fromImportLocation loc+	treepath = asTopFilePath lf+	topf = asTopFilePath $+		maybe lf (\sd -> getTopFilePath sd P.</> lf) msubdir++{- Builds a history of git trees using ContentIdentifiers.+ -+ - These are not the final trees that are generated by the import, which+ - use Keys. The purpose of these trees is to allow quickly determining+ - which files in the import have changed, and which are unchanged, to+ - avoid needing to look up the Keys for unchanged ContentIdentifiers.+ - When the import has a large number of files, that can be slow.+ -}+buildContentIdentifierTree+	:: ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)+	-> Annex (History Sha, M.Map Sha (ContentIdentifier, ByteSize))+buildContentIdentifierTree importable = do+	mv <- liftIO $ newTVarIO M.empty+	r <- buildImportTreesGeneric (convertContentIdentifierTree mv) emptyTree Nothing importable+	m <- liftIO $ atomically $ readTVar mv+	return (r, m)++{- For speed, and to avoid bloating the repository, the ContentIdentifiers+ - are not actually checked into git, instead a sha1 hash is calculated+ - internally.+ -}+convertContentIdentifierTree+	:: TVar (M.Map Sha (ContentIdentifier, ByteSize))+	-> Maybe TopFilePath+	-> [(ImportLocation, (ContentIdentifier, ByteSize))]+	-> Annex Tree+convertContentIdentifierTree mv _ ls = do+	let (tis, ml) = unzip (map mktreeitem ls)+	liftIO $ atomically $ modifyTVar' mv $+		M.union (M.fromList ml)+	return (treeItemsToTree tis)+  where+	mktreeitem (loc, v@((ContentIdentifier cid), _sz)) =+		(TreeItem p mode sha1, (sha1, v))+	  where+		p = asTopFilePath (fromImportLocation loc)+		mode = fromTreeItemType TreeFile+		-- Note that this hardcodes sha1, even if git has started+		-- defaulting to some other checksum method. That should be+		-- ok, hopefully. This checksum never needs to be verified+		-- by git, which is why this does not bother to prefix the+		-- cid with its length, like git would.+		sha1 = Ref $ BA.convertToBase BA.Base16 $ sha1s cid++buildImportTreesGeneric+	:: (Maybe TopFilePath -> [(ImportLocation, v)] -> Annex Tree)+	-> Ref+	-> Maybe TopFilePath+	-> ImportableContentsChunkable Annex v+	-> Annex (History Sha)+buildImportTreesGeneric converttree basetree msubdir (ImportableContentsComplete importable) = do 	repo <- Annex.gitRepo+	withMkTreeHandle repo $ buildImportTreesGeneric' converttree basetree msubdir importable+buildImportTreesGeneric converttree basetree msubdir importable@(ImportableContentsChunked {}) = do+	repo <- Annex.gitRepo 	withMkTreeHandle repo $ \hdl -> 		History 			<$> go hdl-			<*> buildImportTreesHistory basetree msubdir+			<*> buildImportTreesHistory converttree basetree msubdir 				(importableHistoryComplete importable) hdl   where 	go hdl = do@@ -291,7 +403,7 @@ 		let fullprefix = asTopFilePath $ case msubdir of 			Nothing -> subdir 			Just d -> getTopFilePath d Posix.</> subdir-		Tree ts <- convertImportTree (Just fullprefix) $+		Tree ts <- converttree (Just fullprefix) $ 			map (\(p, i) -> (mkImportLocation p, i)) 				(importableContentsSubTree c) 		-- Record this subtree before getting next chunk, this@@ -302,24 +414,26 @@ 			Nothing -> return (Tree (tc:l)) 			Just c' -> gochunks (tc:l) c' hdl -buildImportTrees'-	:: Ref+buildImportTreesGeneric'+	:: (Maybe TopFilePath -> [(ImportLocation, v)] -> Annex Tree)+	-> Ref 	-> Maybe TopFilePath-	-> ImportableContents (Either Sha Key)+	-> ImportableContents v 	-> MkTreeHandle 	-> Annex (History Sha)-buildImportTrees' basetree msubdir importable hdl = History-	<$> buildImportTree basetree msubdir (importableContents importable) hdl-	<*> buildImportTreesHistory basetree msubdir (importableHistory importable) hdl+buildImportTreesGeneric' converttree basetree msubdir importable hdl = History+	<$> buildImportTree converttree basetree msubdir (importableContents importable) hdl+	<*> buildImportTreesHistory converttree basetree msubdir (importableHistory importable) hdl  buildImportTree-	:: Ref+	:: (Maybe TopFilePath -> [(ImportLocation, v)] -> Annex Tree)+	-> Ref 	-> Maybe TopFilePath-	-> [(ImportLocation, Either Sha Key)]+	-> [(ImportLocation, v)] 	-> MkTreeHandle 	-> Annex Sha-buildImportTree basetree msubdir ls hdl = do-	importtree <- liftIO . recordTree' hdl =<< convertImportTree msubdir ls+buildImportTree converttree basetree msubdir ls hdl = do+	importtree <- liftIO . recordTree' hdl =<< converttree msubdir ls 	graftImportTree basetree msubdir importtree hdl  graftImportTree@@ -333,31 +447,15 @@ 	Just subdir -> inRepo $ \repo -> 		graftTree' tree subdir basetree repo hdl -convertImportTree :: Maybe TopFilePath -> [(ImportLocation, Either Sha Key)] -> Annex Tree-convertImportTree msubdir ls = treeItemsToTree <$> mapM mktreeitem ls-  where-	mktreeitem (loc, v) = case v of-		Right k -> do-			relf <- fromRepo $ fromTopFilePath topf-			symlink <- calcRepo $ gitAnnexLink relf k-			linksha <- hashSymlink symlink-			return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha-		Left sha -> -			return $ TreeItem treepath (fromTreeItemType TreeFile) sha-	  where-		lf = fromImportLocation loc-		treepath = asTopFilePath lf-		topf = asTopFilePath $-			maybe lf (\sd -> getTopFilePath sd P.</> lf) msubdir- buildImportTreesHistory-	:: Ref+	:: (Maybe TopFilePath -> [(ImportLocation, v)] -> Annex Tree)+	-> Ref 	-> Maybe TopFilePath-	-> [ImportableContents (Either Sha Key)]+	-> [ImportableContents v] 	-> MkTreeHandle 	-> Annex (S.Set (History Sha))-buildImportTreesHistory basetree msubdir history hdl = S.fromList-	<$> mapM (\ic -> buildImportTrees' basetree msubdir ic hdl) history+buildImportTreesHistory converttree basetree msubdir history hdl = S.fromList+	<$> mapM (\ic -> buildImportTreesGeneric' converttree basetree msubdir ic hdl) history  canImportKeys :: Remote -> Bool -> Bool canImportKeys remote importcontent =@@ -365,6 +463,135 @@   where 	ia = Remote.importActions remote +-- Result of an import. ImportUnfinished indicates that some file failed to+-- be imported. Running again should resume where it left off.+data ImportResult t+	= ImportFinished t+	| ImportUnfinished++data Diffed t+	= DiffChanged t+	| DiffRemoved+	deriving (Eq)++data Imported+	= ImportedFull (ImportableContentsChunkable Annex (Either Sha Key))+	| ImportedDiff LastImportedTree (ImportableContents (Diffed (Either Sha Key)))++newtype LastImportedTree = LastImportedTree Sha++{- Diffs between the previous and current ContentIdentifier trees, and + - runs importKeys on only the changed files.+ -+ - This will download the same content as if importKeys were run on all+ - files, but this speeds it up significantly when there are a lot of files+ - and only a few have changed. importKeys has to look up each+ - ContentIdentifier to see if a Key is known for it. This avoids doing+ - that lookup on files that have not changed.+ -+ - Diffing is not currently implemented when there is a History.+ -}+importChanges+	:: Remote+	-> ImportTreeConfig+	-> Bool+	-> Bool+	-> ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)+	-> Annex (ImportResult Imported)+importChanges remote importtreeconfig importcontent thirdpartypopulated importablecontents = do+	((History currcidtree currhistory), cidtreemap) <- buildContentIdentifierTree importablecontents+	-- diffimport below does not handle history, so when there is+	-- history, do a full import.+	if not (S.null currhistory)+		then fullimport currcidtree+		else do+			getContentIdentifierTree (Remote.uuid remote) >>= \case+				Nothing -> fullimport currcidtree+				Just prevcidtree -> candiffimport prevcidtree >>= \case+					Nothing -> fullimport currcidtree+					Just lastimportedtree -> diffimport cidtreemap prevcidtree currcidtree lastimportedtree+  where+	remember = recordContentIdentifierTree (Remote.uuid remote)++	-- In order to use a diff, the previous ContentIdentifier tree must+	-- not have been garbage collected. Which can happen since there+	-- are no git refs to it.+	--+	-- Also, a tree must have been imported before, and that tree must+	-- also have not been garbage collected (which is less likely to+	-- happen due to the remote tracking branch).+	candiffimport prevcidtree =+		catObjectMetaData prevcidtree >>= \case+			Nothing -> return Nothing+			Just _ -> getLastImportedTree remote >>= \case+				Nothing -> return Nothing+				Just lastimported@(LastImportedTree t) -> +					ifM (isJust <$> catObjectMetaData t)+						( return (Just lastimported)+						, return Nothing+						)++	fullimport currcidtree = +		importKeys remote importtreeconfig importcontent thirdpartypopulated importablecontents >>= \case+			ImportUnfinished -> return ImportUnfinished+			ImportFinished r -> do+				remember currcidtree+	 			return $ ImportFinished $ ImportedFull r+		+	diffimport cidtreemap prevcidtree currcidtree lastimportedtree = do+		(diff, cleanup) <- inRepo $ Git.DiffTree.diffTreeRecursive+			prevcidtree+			currcidtree+		let (removed, changed) = partition isremoval diff+		let mkicchanged ti = do+			v <- M.lookup (Git.DiffTree.dstsha ti) cidtreemap+			return (mkloc ti, v)+		let ic = ImportableContentsComplete $ ImportableContents+			{ importableContents = mapMaybe mkicchanged changed+			, importableHistory = []+			}+		importKeys remote importtreeconfig importcontent thirdpartypopulated ic >>= \case+			ImportUnfinished -> do+				void $ liftIO cleanup+				return ImportUnfinished+			ImportFinished (ImportableContentsComplete ic') -> +				liftIO cleanup >>= \case+					False -> return ImportUnfinished+					True -> do+						remember currcidtree+						return $ ImportFinished $ +							ImportedDiff lastimportedtree+								(mkdiff ic' removed)+			-- importKeys is not passed ImportableContentsChunked+			-- above, so it cannot return it+			ImportFinished (ImportableContentsChunked {}) -> error "internal"+		+	isremoval ti = Git.DiffTree.dstsha ti `elem` nullShas+	+	mkloc = mkImportLocation . getTopFilePath . Git.DiffTree.file++	mkdiff ic removed = ImportableContents+		{ importableContents = diffremoved ++ diffchanged+		, importableHistory = []+		}+	  where+		diffchanged = map+			(\(loc, v) -> (loc, DiffChanged v))+			(importableContents ic)+		diffremoved = map+			(\ti -> (mkloc ti, DiffRemoved))+			removed++{- Gets the tree that was last imported from the remote+ - (or exported to it if an export happened after the last import).+ -}+getLastImportedTree :: Remote -> Annex (Maybe LastImportedTree)+getLastImportedTree remote = do+	db <- Export.openDb (Remote.uuid remote)+	mtree <- liftIO $ Export.getExportTreeCurrent db+	Export.closeDb db+	return (LastImportedTree <$> mtree)+ {- Downloads all new ContentIdentifiers, or when importcontent is False,  - generates Keys without downloading.  -@@ -374,9 +601,6 @@  -  - Supports concurrency when enabled.  -- - If it fails on any file, the whole thing fails with Nothing, - - but it will resume where it left off.- -  - Note that, when a ContentIdentifier has been imported before,  - generates the same thing that was imported before, so annex.largefiles  - is not reapplied.@@ -387,7 +611,7 @@ 	-> Bool 	-> Bool 	-> ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)-	-> Annex (Maybe (ImportableContentsChunkable Annex (Either Sha Key)))+	-> Annex (ImportResult (ImportableContentsChunkable Annex (Either Sha Key))) importKeys remote importtreeconfig importcontent thirdpartypopulated importablecontents = do 	unless (canImportKeys remote importcontent) $ 		giveup "This remote does not support importing without downloading content."@@ -402,9 +626,9 @@ 	-- avoid two threads both importing the same content identifier. 	importing <- liftIO $ newTVarIO S.empty 	withciddb $ \db -> do-		CIDDb.needsUpdateFromLog db-			>>= maybe noop (CIDDb.updateFromLog db)-		(prepclock (run cidmap importing db))+		db' <- CIDDb.needsUpdateFromLog db+			>>= maybe (pure db) (CIDDb.updateFromLog db)+		(prepclock (run cidmap importing db'))   where 	-- When not importing content, reuse the same vector 	-- clock for all state that's recorded. This can save@@ -425,13 +649,13 @@ 		case importablecontents of 			ImportableContentsComplete ic -> 				go False largematcher cidmap importing db ic >>= return . \case-					Nothing -> Nothing-					Just v -> Just $ ImportableContentsComplete v+					Nothing -> ImportUnfinished+					Just v -> ImportFinished $ ImportableContentsComplete v 			ImportableContentsChunked {} -> do 				c <- gochunked db (importableContentsChunk importablecontents) 				gohistory largematcher cidmap importing db (importableHistoryComplete importablecontents) >>= return . \case-					Nothing -> Nothing-					Just h -> Just $ ImportableContentsChunked+					Nothing -> ImportUnfinished+					Just h -> ImportFinished $ ImportableContentsChunked 						{ importableContentsChunk = c 						, importableHistoryComplete = h 						}@@ -458,10 +682,10 @@ 	gochunked db c 		-- Downloading cannot be done when chunked, since only 		-- the first chunk is processed before returning.-		| importcontent = error "importKeys does not support downloading chunked import"+		| importcontent = giveup "importKeys does not support downloading chunked import" 		-- Chunked import is currently only used by thirdpartypopulated 		-- remotes.-		| not thirdpartypopulated = error "importKeys does not support chunked import when not thirdpartypopulated"+		| not thirdpartypopulated = giveup "importKeys does not support chunked import when not thirdpartypopulated" 		| otherwise = do 			l <- forM (importableContentsSubTree c) $ \(loc, i) -> do 				let loc' = importableContentsChunkFullLocation (importableContentsSubDir c) loc@@ -503,14 +727,14 @@ 			in return $ Left $ Just (loc, v) 		[] -> do 			job <- liftIO $ newEmptyTMVarIO-			let ai = ActionItemOther (Just (fromRawFilePath (fromImportLocation loc)))+			let ai = ActionItemOther (Just (QuotedPath (fromImportLocation loc))) 			let si = SeekInput [] 			let importaction = starting ("import " ++ Remote.name remote) ai si $ do 				when oldversion $ 					showNote "old version"-				tryNonAsync (importordownload cidmap db i largematcher) >>= \case+				tryNonAsync (importordownload cidmap i largematcher) >>= \case 					Left e -> next $ do-						warning (show e)+						warning (UnquotedString (show e)) 						liftIO $ atomically $ 							putTMVar job Nothing 						return False@@ -530,15 +754,15 @@ 			Just importkey -> 				tryNonAsync (importkey loc cid sz nullMeterUpdate) >>= \case 					Right (Just k) -> do-						recordcidkey' db cid k+						recordcidkeyindb db cid k 						logChange k (Remote.uuid remote) InfoPresent 						return $ Just (loc, Right k) 					Right Nothing -> return Nothing 					Left e -> do-						warning (show e)+						warning (UnquotedString (show e)) 						return Nothing 	-	importordownload cidmap db (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@@ -551,9 +775,9 @@ 					then dodownload 					else doimport 			else doimport-		act cidmap db (loc, (cid, sz)) f matcher+		act cidmap (loc, (cid, sz)) f matcher -	doimport cidmap db (loc, (cid, sz)) f matcher =+	doimport cidmap (loc, (cid, sz)) f matcher = 		case Remote.importKey ia of 			Nothing -> error "internal" -- checked earlier 			Just importkey -> do@@ -570,15 +794,15 @@ 				let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote) 				islargefile <- checkMatcher' matcher mi mempty 				metered Nothing sz bwlimit $ const $ if islargefile-					then doimportlarge importkey cidmap db loc cid sz f-					else doimportsmall cidmap db loc cid sz+					then doimportlarge importkey cidmap loc cid sz f+					else doimportsmall cidmap loc cid sz 	-	doimportlarge importkey cidmap db loc cid sz f p =+	doimportlarge importkey cidmap loc cid sz f p = 		tryNonAsync importer >>= \case 			Right (Just (k, True)) -> return $ Just (loc, Right k) 			Right _ -> return Nothing 			Left e -> do-				warning (show e)+				warning (UnquotedString (show e)) 				return Nothing 	  where 		importer = do@@ -591,7 +815,7 @@ 				Nothing -> return Nothing 				Just k -> checkSecureHashes k >>= \case 					Nothing -> do-						recordcidkey cidmap db cid k+						recordcidkey cidmap cid k 						logChange k (Remote.uuid remote) InfoPresent 						if importcontent 							then getcontent k@@ -618,7 +842,7 @@ 	-- The file is small, so is added to git, so while importing 	-- without content does not retrieve annexed files, it does 	-- need to retrieve this file.-	doimportsmall cidmap db loc cid sz p = do+	doimportsmall cidmap loc cid sz p = do 		let downloader tmpfile = do 			(k, _) <- Remote.retrieveExportWithContentIdentifier 				ia loc [cid] (fromRawFilePath tmpfile)@@ -626,7 +850,7 @@ 				p 			case keyGitSha k of 				Just sha -> do-					recordcidkey cidmap db cid k+					recordcidkey cidmap cid k 					return sha 				Nothing -> error "internal" 		checkDiskSpaceToGet tmpkey Nothing $@@ -634,13 +858,13 @@ 				tryNonAsync (downloader tmpfile) >>= \case 					Right sha -> return $ Just (loc, Left sha) 					Left e -> do-						warning (show e)+						warning (UnquotedString (show e)) 						return Nothing 	  where 		tmpkey = importKey cid sz 		mkkey tmpfile = gitShaKey <$> hashFile tmpfile 	-	dodownload cidmap db (loc, (cid, sz)) f matcher = do+	dodownload cidmap (loc, (cid, sz)) f matcher = do 		let af = AssociatedFile (Just f) 		let downloader tmpfile p = do 			(k, _) <- Remote.retrieveExportWithContentIdentifier@@ -651,18 +875,18 @@ 				Nothing -> do 					ok <- moveAnnex k af tmpfile 					when ok $ do-						recordcidkey cidmap db cid k+						recordcidkey cidmap cid k 						logStatus k InfoPresent 						logChange k (Remote.uuid remote) InfoPresent 					return (Right k, ok) 				Just sha -> do-					recordcidkey cidmap db cid k+					recordcidkey cidmap cid k 					return (Left sha, True) 		let rundownload tmpfile p = tryNonAsync (downloader tmpfile p) >>= \case 			Right (v, True) -> return $ Just (loc, v) 			Right (_, False) -> return Nothing 			Left e -> do-				warning (show e)+				warning (UnquotedString (show e)) 				return Nothing 		let bwlimit = remoteAnnexBwLimit (Remote.gitconfig remote) 		checkDiskSpaceToGet tmpkey Nothing $@@ -701,17 +925,29 @@ 				getTopFilePath subdir P.</> fromImportLocation loc  	getcidkey cidmap db cid = liftIO $-		CIDDb.getContentIdentifierKeys db rs cid >>= \case-			[] -> atomically $-				maybeToList . M.lookup cid <$> readTVar cidmap-			l -> return l+		-- Avoiding querying the database when it's empty speeds up+		-- the initial import.+		if CIDDb.databaseIsEmpty db+			then getcidkeymap cidmap cid+			else CIDDb.getContentIdentifierKeys db rs cid >>= \case+				[] -> getcidkeymap cidmap cid+				l -> return l -	recordcidkey cidmap db cid k = do+	getcidkeymap cidmap cid =+		atomically $ maybeToList . M.lookup cid <$> readTVar cidmap++	recordcidkey cidmap cid k = do 		liftIO $ atomically $ modifyTVar' cidmap $ 			M.insert cid k-		recordcidkey' db cid k-	recordcidkey' db cid k = do+		-- Only record in log now; the database will be updated+		-- later from the log, and the cidmap will be used for now.+		recordcidkeyinlog cid k+	+	recordcidkeyindb db cid k = do 		liftIO $ CIDDb.recordContentIdentifier db rs cid k+		recordcidkeyinlog cid k+	+	recordcidkeyinlog cid k = 		CIDLog.recordContentIdentifier rs cid k  	rs = Remote.remoteStateHandle remote@@ -813,7 +1049,10 @@ 				Just c' -> Just <$> filterunwantedchunk dbhandle c' 			) -	opendbhandle = Export.openDb (Remote.uuid r)+	opendbhandle = do+		h <- Export.openDb (Remote.uuid r)+		void $ Export.updateExportTreeFromLog h+		return h  	wanted dbhandle (loc, (_cid, sz)) 		| ingitdir = pure False
Annex/Ingest.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.Ingest ( 	LockedDown(..), 	LockDownConfig(..),@@ -85,7 +87,7 @@  -} lockDown :: LockDownConfig-> FilePath -> Annex (Maybe LockedDown) lockDown cfg file = either -		(\e -> warning (show e) >> return Nothing)+		(\e -> warning (UnquotedString (show e)) >> return Nothing) 		(return . Just) 	=<< lockDown' cfg file @@ -133,16 +135,16 @@ 		 	setperms = when (lockingFile cfg) $ do 		freezeContent file'-		when (checkWritePerms cfg) $-			maybe noop giveup =<< checkLockedDownWritePerms file' file'+		when (checkWritePerms cfg) $ do+			qp <- coreQuotePath <$> Annex.getGitConfig+			maybe noop (giveup . decodeBS . quote qp)+				=<< checkLockedDownWritePerms file' file' -checkLockedDownWritePerms :: RawFilePath -> RawFilePath -> Annex (Maybe String)+checkLockedDownWritePerms :: RawFilePath -> RawFilePath -> Annex (Maybe StringContainingQuotedPath) checkLockedDownWritePerms file displayfile = checkContentWritePerm file >>= return . \case-	Just False -> Just $ unwords-		[ "Unable to remove all write permissions from"-		, fromRawFilePath displayfile-		, "-- perhaps it has an xattr or ACL set."-		]+	Just False -> Just $ "Unable to remove all write permissions from "+		<> QuotedPath displayfile+		<> " -- perhaps it has an xattr or ACL set." 	_ -> Nothing  {- Ingests a locked down file into the annex. Updates the work tree and@@ -224,7 +226,7 @@ 		return (Just k, mcache)  	failure msg = do-		warning $ fromRawFilePath (keyFilename source) ++ " " ++ msg+		warning $ QuotedPath (keyFilename source) <> " " <> UnquotedString msg 		cleanCruft source 		return (Nothing, Nothing) @@ -296,7 +298,7 @@ 		-- content in the annex, and make a copy back to the file. 		obj <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) 		unlessM (liftIO $ copyFileExternal CopyTimeStamps obj (fromRawFilePath file)) $-			warning $ "Unable to restore content of " ++ fromRawFilePath file ++ "; it should be located in " ++ obj+			warning $ "Unable to restore content of " <> QuotedPath file <> "; it should be located in " <> QuotedPath (toRawFilePath obj) 		thawContent file 	throwM e @@ -409,11 +411,10 @@ addingExistingLink f k a = do 	unlessM (isKnownKey k <||> inAnnex k) $ do 		islink <- isJust <$> isAnnexLink f-		warning $ unwords-			[ fromRawFilePath f-			, "is a git-annex"-			, if islink then "symlink." else "pointer file."-			, "Its content is not available in this repository."-			, "(Maybe " ++ fromRawFilePath f ++ " was copied from another repository?)"-			]+		warning $+			QuotedPath f+			<> " is a git-annex "+			<> if islink then "symlink." else "pointer file."+			<> " Its content is not available in this repository."+			<> " (Maybe " <> QuotedPath f <> " was copied from another repository?)" 	a
Annex/Init.hs view
@@ -79,7 +79,7 @@ 	Just noannexmsg -> do 		warning "Initialization prevented by .noannex file (remove the file to override)" 		unless (null noannexmsg) $-			warning noannexmsg+			warning (UnquotedString noannexmsg) 		giveup "Not initialized."  initializeAllowed :: Annex Bool@@ -272,7 +272,7 @@ 		(Just (freezeContent' UnShared)) 		(Just (thawContent' UnShared)) 		=<< hasFreezeHook-	mapM_ warning warnings+	mapM_ (warning . UnquotedString) warnings 	return r  probeCrippledFileSystem'@@ -404,8 +404,8 @@ 		Right () -> return () 		Left e -> do 			showLongNote $ "Detected a filesystem where Sqlite does not work."-			showLongNote $ "(" ++ show e ++ ")"-			showLongNote $ "To work around this problem, you can set annex.dbdir " +++			showLongNote $ UnquotedString $ "(" ++ show e ++ ")"+			showLongNote $ "To work around this problem, you can set annex.dbdir " <> 				"to a directory on another filesystem." 			showLongNote $ "For example: git config annex.dbdir $HOME/cache/git-annex" 			giveup "Not initialized."
Annex/InodeSentinal.hs view
@@ -93,6 +93,8 @@ 		s <- annexSentinalFile 		createAnnexDirectory (parentDir (sentinalFile s)) 		liftIO $ writeSentinalFile s+		setAnnexFilePerm (sentinalFile s)+		setAnnexFilePerm (sentinalCacheFile s)   where 	alreadyexists = liftIO. sentinalFileExists =<< annexSentinalFile 	hasobjects
Annex/Journal.hs view
@@ -91,7 +91,10 @@ 	let tmpfile = tmp P.</> jfile 	liftIO $ withFile (fromRawFilePath tmpfile) WriteMode $ \h -> 		writeJournalHandle h content-	let mv = liftIO $ moveFile tmpfile (jd P.</> jfile)+	let dest = jd P.</> jfile+	let mv = do+		liftIO $ moveFile tmpfile dest+		setAnnexFilePerm dest 	-- avoid overhead of creating the journal directory when it already 	-- exists 	mv `catchIO` (const (createAnnexDirectory jd >> mv))@@ -227,8 +230,13 @@ {- Directory handle open on a journal directory. -} withJournalHandle :: (Git.Repo -> RawFilePath) -> (DirectoryHandle -> IO a) -> Annex a withJournalHandle getjournaldir a = do-	d <- fromRawFilePath <$> fromRepo getjournaldir-	bracketIO (openDirectory d) closeDirectory (liftIO . a)+	d <- fromRepo getjournaldir+	bracket (opendir d) (liftIO . closeDirectory) (liftIO . a)+  where+	-- avoid overhead of creating the journal directory when it already+	-- exists+	opendir d = liftIO (openDirectory (fromRawFilePath d))+		`catchIO` (const (createAnnexDirectory d >> opendir d))  {- Checks if there are changes in the journal. -} journalDirty :: (Git.Repo -> RawFilePath) -> Annex Bool
Annex/Link.hs view
@@ -186,7 +186,7 @@ restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex () restagePointerFile (Restage False) f orig = do 	flip writeRestageLog orig =<< inRepo (toTopFilePath f)-	toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f+	toplevelWarning True $ unableToRestage $ Just f restagePointerFile (Restage True) f orig = do 	flip writeRestageLog orig =<< inRepo (toTopFilePath f) 	-- Avoid refreshing the index if run by the@@ -319,16 +319,15 @@ 		ck = ConfigKey "filter.annex.process" 		ckd = ConfigKey "filter.annex.process-temp-disabled" -unableToRestage :: Maybe FilePath -> String-unableToRestage mf = unwords-	[ "git status will show " ++ fromMaybe "some files" mf-	, "to be modified, since content availability has changed"-	, "and git-annex was unable to update the index."-	, "This is only a cosmetic problem affecting git status; git add,"-	, "git commit, etc won't be affected."-	, "To fix the git status display, you can run:"-	, "git-annex restage"-	]+unableToRestage :: Maybe RawFilePath -> StringContainingQuotedPath+unableToRestage mf =+	"git status will show " <> maybe "some files" QuotedPath mf+	<> " to be modified, since content availability has changed"+	<> " and git-annex was unable to update the index."+	<> " This is only a cosmetic problem affecting git status; git add,"+	<> " git commit, etc won't be affected."+	<> " To fix the git status display, you can run:"+	<> " git-annex restage"  {- Parses a symlink target or a pointer file to a Key.  -
Annex/Locations.hs view
@@ -1,6 +1,6 @@ {- git-annex file locations  -- - Copyright 2010-2022 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -52,6 +52,8 @@ 	gitAnnexRestageLog, 	gitAnnexRestageLogOld, 	gitAnnexRestageLock,+	gitAnnexAdjustedBranchUpdateLog,+	gitAnnexAdjustedBranchUpdateLock, 	gitAnnexMoveLog, 	gitAnnexMoveLock, 	gitAnnexExportDir,@@ -59,6 +61,8 @@ 	gitAnnexExportLock, 	gitAnnexExportUpdateLock, 	gitAnnexExportExcludeLog,+	gitAnnexImportDir,+	gitAnnexImportLog, 	gitAnnexContentIdentifierDbDir, 	gitAnnexContentIdentifierLock, 	gitAnnexScheduleState,@@ -393,6 +397,14 @@ gitAnnexRestageLock :: Git.Repo -> RawFilePath gitAnnexRestageLock r = gitAnnexDir r P.</> "restage.lck" +{- .git/annex/adjust.log is used to log when the adjusted branch needs to+ - be updated. -}+gitAnnexAdjustedBranchUpdateLog :: Git.Repo -> RawFilePath+gitAnnexAdjustedBranchUpdateLog r = gitAnnexDir r P.</> "adjust.log"++gitAnnexAdjustedBranchUpdateLock :: Git.Repo -> RawFilePath+gitAnnexAdjustedBranchUpdateLock r = gitAnnexDir r P.</> "adjust.lck"+ {- .git/annex/move.log is used to log moves that are in progress,  - to better support resuming an interrupted move. -} gitAnnexMoveLog :: Git.Repo -> RawFilePath@@ -437,6 +449,16 @@ {- Lock file for writing to the content id database. -} gitAnnexContentIdentifierLock :: Git.Repo -> GitConfig -> RawFilePath gitAnnexContentIdentifierLock r c = gitAnnexContentIdentifierDbDir r c <> ".lck"++{- .git/annex/import/ is used to store information about+ - imports from special remotes. -}+gitAnnexImportDir :: Git.Repo -> GitConfig -> RawFilePath+gitAnnexImportDir r c = fromMaybe (gitAnnexDir r) (annexDbDir c) P.</> "import"++{- File containing state about the last import done from a remote. -}+gitAnnexImportLog :: UUID -> Git.Repo -> GitConfig -> RawFilePath+gitAnnexImportLog u r c = +	gitAnnexImportDir r c P.</> fromUUID u P.</> "log"  {- .git/annex/schedulestate is used to store information about when  - scheduled jobs were last run. -}
Annex/LockFile.hs view
@@ -36,7 +36,7 @@ 	go Nothing = do #ifndef mingw32_HOST_OS 		mode <- annexFileMode-		lockhandle <- noUmask mode $ lockShared (Just mode) file+		lockhandle <- lockShared (Just mode) file #else 		lockhandle <- liftIO $ waitToLock $ lockShared file #endif@@ -69,7 +69,7 @@ 	bracket (lock mode lockfile) (liftIO . dropLock) (const a)   where #ifndef mingw32_HOST_OS-	lock mode = noUmask mode . lockShared (Just mode)+	lock mode = lockShared (Just mode) #else 	lock _mode = liftIO . waitToLock . lockShared #endif@@ -90,7 +90,7 @@ 	lock mode lockfile   where #ifndef mingw32_HOST_OS-	lock mode = noUmask mode . lockExclusive (Just mode)+	lock mode = lockExclusive (Just mode) #else 	lock _mode = liftIO . waitToLock . lockExclusive #endif@@ -104,7 +104,7 @@ 	bracket (lock mode lockfile) (liftIO . unlock) go   where #ifndef mingw32_HOST_OS-	lock mode = noUmask mode . tryLockExclusive (Just mode)+	lock mode = tryLockExclusive (Just mode) #else 	lock _mode = liftIO . lockExclusive #endif
Annex/LockPool/PosixOrPid.hs view
@@ -26,25 +26,27 @@ import qualified Utility.LockPool.Posix as Posix import qualified Utility.LockPool.PidLock as Pid import qualified Utility.LockPool.LockHandle as H+import Utility.FileMode import Utility.LockPool.LockHandle (LockHandle, dropLock) import Utility.LockFile.Posix (openLockFile) import Utility.LockPool.STM (LockFile, LockMode(..)) import Utility.LockFile.LockStatus import Config (pidLockFile) import Messages (warning)+import Git.Quote  import System.Posix -lockShared :: Maybe FileMode -> LockFile -> Annex LockHandle+lockShared :: Maybe ModeSetter -> LockFile -> Annex LockHandle lockShared m f = pidLock m f LockShared $ Posix.lockShared m f -lockExclusive :: Maybe FileMode -> LockFile -> Annex LockHandle+lockExclusive :: Maybe ModeSetter -> LockFile -> Annex LockHandle lockExclusive m f = pidLock m f LockExclusive $ Posix.lockExclusive m f -tryLockShared :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)+tryLockShared :: Maybe ModeSetter -> LockFile -> Annex (Maybe LockHandle) tryLockShared m f = tryPidLock m f LockShared $ Posix.tryLockShared m f -tryLockExclusive :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)+tryLockExclusive :: Maybe ModeSetter -> LockFile -> Annex (Maybe LockHandle) tryLockExclusive m f = tryPidLock m f LockExclusive $ Posix.tryLockExclusive m f  checkLocked :: LockFile -> Annex (Maybe Bool)@@ -67,16 +69,16 @@ pidLockCheck posixcheck pidcheck = debugLocks $ 	liftIO . maybe posixcheck pidcheck =<< pidLockFile -pidLock :: Maybe FileMode -> LockFile -> LockMode -> IO LockHandle -> Annex LockHandle+pidLock :: Maybe ModeSetter -> LockFile -> LockMode -> IO LockHandle -> Annex LockHandle pidLock m f lockmode posixlock = debugLocks $ go =<< pidLockFile   where 	go Nothing = liftIO posixlock 	go (Just pidlock) = do 		timeout <- annexPidLockTimeout <$> Annex.getGitConfig 		liftIO $ dummyPosixLock m f-		Pid.waitLock f lockmode timeout pidlock warning+		Pid.waitLock f lockmode timeout pidlock (warning . UnquotedString) -tryPidLock :: Maybe FileMode -> LockFile -> LockMode -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle)+tryPidLock :: Maybe ModeSetter -> LockFile -> LockMode -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle) tryPidLock m f lockmode posixlock = debugLocks $ liftIO . go =<< pidLockFile   where 	go Nothing = posixlock@@ -87,5 +89,5 @@ -- The posix lock file is created even when using pid locks, in order to -- avoid complicating any code that might expect to be able to see that -- lock file. But, it's not locked.-dummyPosixLock :: Maybe FileMode -> LockFile -> IO ()+dummyPosixLock :: Maybe ModeSetter -> LockFile -> IO () dummyPosixLock m f = bracket (openLockFile ReadLock m f) closeFd (const noop)
Annex/MetaData.hs view
@@ -56,7 +56,7 @@ 					dateMetaData (posixSecondsToUTCTime mtime) old 			Nothing -> noop   where-	warncopied = warning $ +	warncopied = warning $ UnquotedString $ 		"Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++  		"If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file 	-- If the only fields copied were date metadata, and they'll
Annex/NumCopies.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings #-}  module Annex.NumCopies ( 	module Types.NumCopies,@@ -277,17 +277,17 @@ notEnoughCopies key neednum needmin have skip bad nolocmsg lockunsupported = do 	showNote "unsafe" 	if length have < fromNumCopies neednum-		then showLongNote $+		then showLongNote $ UnquotedString $ 			"Could only verify the existence of " ++ 			show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++  			" necessary " ++ pluralcopies (fromNumCopies neednum) 		else do-			showLongNote $ "Unable to lock down " ++ show (fromMinCopies needmin) ++ +			showLongNote $ UnquotedString $ "Unable to lock down " ++ show (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.)"-				else showLongNote $ "These remotes do not support locking: "+				else showLongNote $ UnquotedString $ "These remotes do not support locking: " 					++ Remote.listRemoteNames lockunsupported  	Remote.showTriedRemotes bad
Annex/Perms.hs view
@@ -1,6 +1,6 @@ {- git-annex file permissions  -- - Copyright 2012-2022 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -15,7 +15,6 @@ 	annexFileMode, 	createAnnexDirectory, 	createWorkTreeDirectory,-	noUmask, 	freezeContent, 	freezeContent', 	freezeContent'',@@ -44,7 +43,7 @@ import Utility.Directory.Create import qualified Utility.RawFilePath as R -import System.PosixCompat.Files (fileMode, intersectFileModes, nullFileMode, groupWriteMode, ownerWriteMode, ownerReadMode, groupReadMode, stdFileMode, ownerExecuteMode, groupExecuteMode)+import System.PosixCompat.Files (fileMode, intersectFileModes, nullFileMode, groupWriteMode, ownerWriteMode, ownerReadMode, groupReadMode, otherReadMode, stdFileMode, ownerExecuteMode, groupExecuteMode, otherExecuteMode, setGroupIDMode)  withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig@@ -60,23 +59,27 @@  - don't change the mode, but with core.sharedRepository set,  - allow the group to write, etc. -} setAnnexPerm :: Bool -> RawFilePath -> Annex ()-setAnnexPerm = setAnnexPerm' Nothing+setAnnexPerm isdir file = setAnnexPerm' Nothing isdir >>= \go -> liftIO (go file) -setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> RawFilePath -> Annex ()-setAnnexPerm' modef isdir file = unlessM crippledFileSystem $-	withShared $ liftIO . go+setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (RawFilePath -> IO ())+setAnnexPerm' modef isdir = ifM crippledFileSystem+	( return (const noop)+	, withShared $ \s -> return $ \file -> go s file+	)   where-	go GroupShared = void $ tryIO $ modifyFileMode file $ modef' $+	go GroupShared file = void $ tryIO $ modifyFileMode file $ modef' $ 		groupSharedModes ++ 		if isdir then [ ownerExecuteMode, groupExecuteMode ] else []-	go AllShared = void $ tryIO $ modifyFileMode file $ modef' $+	go AllShared file = void $ tryIO $ modifyFileMode file $ modef' $ 		readModes ++ 		[ ownerWriteMode, groupWriteMode ] ++ 		if isdir then executeModes else []-	go _ = case modef of+	go UnShared file = case modef of 		Nothing -> noop 		Just f -> void $ tryIO $ 			modifyFileMode file $ f []+	go (UmaskShared n) file = void $ tryIO $ R.setFileMode file $+		if isdir then umaskSharedDirectory n else n 	modef' = fromMaybe addModes modef  resetAnnexFilePerm :: RawFilePath -> Annex ()@@ -94,19 +97,19 @@ resetAnnexPerm isdir file = unlessM crippledFileSystem $ do 	defmode <- liftIO defaultFileMode 	let modef moremodes _oldmode = addModes moremodes defmode-	setAnnexPerm' (Just modef) isdir file+	setAnnexPerm' (Just modef) isdir >>= \go -> liftIO (go file) -{- Gets the appropriate mode to use for creating a file in the annex- - (other than content files, which are locked down more). The umask is not- - taken into account; this is for use with actions that create the file- - and apply the umask automatically. -}-annexFileMode :: Annex FileMode-annexFileMode = withShared $ return . go+{- Creates a ModeSetter which can be used for creating a file in the annex+ - (other than content files, which are locked down more). -}+annexFileMode :: Annex ModeSetter+annexFileMode = do+	modesetter <- setAnnexPerm' Nothing False+	withShared (\s -> pure $ mk s modesetter)   where-	go GroupShared = sharedmode-	go AllShared = combineModes (sharedmode:readModes)-	go _ = stdFileMode-	sharedmode = combineModes groupSharedModes+	mk GroupShared = ModeSetter stdFileMode+	mk AllShared = ModeSetter stdFileMode+	mk UnShared = ModeSetter stdFileMode+	mk (UmaskShared mode) = ModeSetter mode  {- Creates a directory inside the gitAnnexDir (or possibly the dbdir),   - creating any parent directories up to and including the gitAnnexDir.@@ -168,6 +171,7 @@ 	unlessM crippledFileSystem $ go sr 	freezeHook file   where+	go UnShared = liftIO $ nowriteadd [ownerReadMode] 	go GroupShared = if versionNeedsWritableContentFiles rv 		then liftIO $ ignoresharederr $ modmode $ addModes 			[ownerReadMode, groupReadMode, ownerWriteMode, groupWriteMode]@@ -178,7 +182,13 @@ 			(readModes ++ writeModes) 		else liftIO $ ignoresharederr $  			nowriteadd readModes-	go _ = liftIO $ nowriteadd [ownerReadMode]+	go (UmaskShared n) = if versionNeedsWritableContentFiles rv+		-- Assume that the configured mode includes write bits+		-- for all users who should be able to lock the file, so+		-- don't need to add any write modes.+		then liftIO $ ignoresharederr $ modmode $ const n+		else liftIO $ ignoresharederr $ modmode $ const $+			removeModes writeModes n  	ignoresharederr = void . tryIO @@ -206,14 +216,15 @@ 	, do 		rv <- getVersion 		hasfreezehook <- hasFreezeHook-		withShared $ \sr -> liftIO $-			checkContentWritePerm' sr file rv hasfreezehook+		withShared $ \sr ->+			liftIO $ checkContentWritePerm' sr file rv hasfreezehook 	)  checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool) checkContentWritePerm' sr file rv hasfreezehook 	| hasfreezehook = return (Just True) 	| otherwise = case sr of+		UnShared -> want Just (excludemodes writeModes) 		GroupShared 			| versionNeedsWritableContentFiles rv -> want sharedret 				(includemodes [ownerWriteMode, groupWriteMode])@@ -222,7 +233,11 @@ 			| versionNeedsWritableContentFiles rv ->  				want sharedret (includemodes writeModes) 			| otherwise -> want sharedret (excludemodes writeModes)-		_ -> want Just (excludemodes writeModes)+		UmaskShared n+			| versionNeedsWritableContentFiles rv -> want sharedret+				(\havemode -> havemode == n)+			| otherwise -> want sharedret+				(\havemode -> havemode == removeModes writeModes n)   where 	want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file) 		>>= return . \case@@ -247,7 +262,8 @@   where 	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file 	go AllShared = liftIO $ void $ tryIO $ groupWriteRead file-	go _ = liftIO $ allowWrite file+	go UnShared = liftIO $ allowWrite file+	go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode file n  {- Runs an action that thaws a file's permissions. This will probably  - fail on a crippled filesystem. But, if file modes are supported on a@@ -262,7 +278,7 @@ {- Blocks writing to the directory an annexed file is in, to prevent the  - file accidentally being deleted. However, if core.sharedRepository  - is set, this is not done, since the group must be allowed to delete the- - file.+ - file without eing able to thaw the directory.  -} freezeContentDir :: RawFilePath -> Annex () freezeContentDir file = do@@ -271,16 +287,26 @@ 	freezeHook dir   where 	dir = parentDir file+	go UnShared = liftIO $ preventWrite dir 	go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir 	go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir-	go _ = liftIO $ preventWrite dir+	go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode dir $+		umaskSharedDirectory $ +			-- If n includes group or other write mode, leave them set+			-- to allow them to delete the file without being able to+			-- thaw the directory.+			removeModes [ownerWriteMode] n  thawContentDir :: RawFilePath -> Annex () thawContentDir file = do 	fastDebug "Annex.Perms" ("thawing content directory " ++ fromRawFilePath dir)-	thawPerms (liftIO $ allowWrite dir) (thawHook dir)+	thawPerms (withShared (liftIO . go)) (thawHook dir)   where 	dir = parentDir file+	go UnShared = allowWrite dir+	go GroupShared = allowWrite dir+	go AllShared = allowWrite dir+	go (UmaskShared n) = R.setFileMode dir n  {- Makes the directory tree to store an annexed file's content,  - with appropriate permissions on each level. -}@@ -332,3 +358,17 @@ 	go basecmd = void $ liftIO $ 		boolSystem "sh" [Param "-c", Param $ gencmd basecmd] 	gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ]++{- Calculate mode to use for a directory from the mode to use for a file.+ -+ - This corresponds to git's handling of core.sharedRepository=0xxx+ -}+umaskSharedDirectory :: FileMode -> FileMode+umaskSharedDirectory n = flip addModes n $ map snd $ filter fst+	[ (isset ownerReadMode, ownerExecuteMode)+	, (isset groupReadMode, groupExecuteMode)+	, (isset otherReadMode, otherExecuteMode)+	, (isset groupReadMode || isset groupWriteMode, setGroupIDMode)+	]+  where+	isset v = checkMode v n
Annex/SpecialRemote.hs view
@@ -23,6 +23,7 @@ import Logs.Trust import qualified Types.Remote as Remote import Git.Types (RemoteName)+import Utility.SafeOutput  import qualified Data.Map as M @@ -95,11 +96,16 @@ 			Just (Sameas u') -> u' 			Nothing -> cu 		case (lookupName c, findType c) of-			(Just name, Right t) -> do-				showSideAction $ "Auto enabling special remote " ++ name+			-- Avoid auto-enabling when the name contains a+			-- control character, because git does not avoid+			-- displaying control characters in the name of a+			-- remote, and an attacker could leverage+			-- autoenabling it as part of an attack.+			(Just name, Right t) | safeOutput name == name -> do+				showSideAction $ UnquotedString $ "Auto enabling special remote " ++ name 				dummycfg <- liftIO dummyRemoteGitConfig 				tryNonAsync (setup t (AutoEnable c) (Just u) Nothing c dummycfg) >>= \case-					Left e -> warning (show e)+					Left e -> warning (UnquotedString (show e)) 					Right (_c, _u) -> 						when (cu /= u) $ 							setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu)
Annex/SpecialRemote/Config.hs view
@@ -109,8 +109,7 @@ 	, optionalStringParser sameasUUIDField HiddenField 	, optionalStringParser typeField 		(FieldDesc "type of special remote")-	, trueFalseParser autoEnableField (Just False)-		(FieldDesc "automatically enable special remote")+	, autoEnableFieldParser 	, costParser costField 		(FieldDesc "default cost of this special remote") 	, yesNoParser exportTreeField (Just False)@@ -121,6 +120,10 @@ 		(FieldDesc "directory whose content is preferred") 	] +autoEnableFieldParser :: RemoteConfigFieldParser+autoEnableFieldParser = trueFalseParser autoEnableField (Just False)+	(FieldDesc "automatically enable special remote")+ {- A remote with sameas-uuid set will inherit these values from the config  - of that uuid. These values cannot be overridden in the remote's config. -} sameasInherits :: S.Set RemoteConfigField@@ -134,8 +137,12 @@ 	, pubkeysField 	-- legacy chunking was either enabled or not, so has to be the same 	-- across configs for remotes that access the same data-	-- (new-style chunking does not have that limitation) 	, chunksizeField+	-- (new-style chunking does not have that limitation)+	-- but there is no benefit to picking a different chunk size+	-- for the sameas remote, since it's reading whatever chunks were+	-- stored+	, chunkField 	]  {- Each RemoteConfig that has a sameas-uuid inherits some fields
Annex/Ssh.hs view
@@ -120,8 +120,8 @@ 	 	warnnocaching whynocaching = 		whenM (annexAdviceNoSshCaching <$> Annex.getGitConfig) $ do-			warning nocachingwarning-			warning whynocaching+			warning $ UnquotedString nocachingwarning+			warning $ UnquotedString whynocaching 	 	nocachingwarning = unwords 		[ "You have enabled concurrency, but git-annex is not able"@@ -311,7 +311,7 @@ 		let lockfile = socket2lock socketfile 		unlockFile lockfile 		mode <- annexFileMode-		noUmask mode (tryLockExclusive (Just mode) lockfile) >>= \case+		tryLockExclusive (Just mode) lockfile >>= \case 			Nothing -> noop 			Just lck -> do 				forceStopSsh socketfile@@ -432,7 +432,7 @@ 			( unchanged 			, do 				let port = Git.Url.port remote-				let sshhost = either error id (mkSshHost host)+				let sshhost = either giveup id (mkSshHost host) 				(msockfile, cacheparams) <- sshCachingInfo (sshhost, port) 				case msockfile of 					Nothing -> use []
Annex/Transfer.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE CPP, BangPatterns, OverloadedStrings #-}  module Annex.Transfer ( 	module X,@@ -31,6 +31,7 @@ import Annex.Action import Utility.Metered import Utility.ThreadScheduler+import Utility.FileMode import Annex.LockPool import Types.Key import qualified Types.Remote as Remote@@ -144,7 +145,7 @@ 					else recordFailedTransfer t info 				return v 	-	prep :: RawFilePath -> Annex () -> FileMode -> Annex (Maybe LockHandle, Bool)+	prep :: RawFilePath -> Annex () -> ModeSetter -> Annex (Maybe LockHandle, Bool) #ifndef mingw32_HOST_OS 	prep tfile createtfile mode = catchPermissionDenied (const prepfailed) $ do 		let lck = transferLockFile tfile@@ -200,7 +201,7 @@ 				| observeBool v -> return v 				| otherwise -> checkretry 			Left e -> do-				warning (show e)+				warning (UnquotedString (show e)) 				checkretry 	  where 		checkretry = do@@ -289,7 +290,7 @@ 			) 		) 	blocked variety = do-		warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key"+		warning $ UnquotedString $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key" 		return observeFailure  type NumRetries = Integer@@ -339,7 +340,7 @@ 	if numretries < maxretries 		then do 			let retrydelay = Seconds (initretrydelay * 2^(numretries-1))-			showSideAction $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying."+			showSideAction $ UnquotedString $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying." 			liftIO $ threadDelaySeconds retrydelay 			return True 		else return False
Annex/UntrustedFilePath.hs view
@@ -10,6 +10,8 @@ import Data.Char import System.FilePath +import Utility.SafeOutput+ {- Given a string that we'd like to use as the basis for FilePath, but that  - was provided by a third party and is not to be trusted, returns the closest  - sane FilePath.@@ -52,8 +54,10 @@ sanitizeLeadingFilePathCharacter ('/':s) = '_':s sanitizeLeadingFilePathCharacter s = s -escapeSequenceInFilePath :: FilePath -> Bool-escapeSequenceInFilePath f = '\ESC' `elem` f+controlCharacterInFilePath :: FilePath -> Bool+controlCharacterInFilePath = any (not . safechar)+  where+	safechar c = safeOutputChar c && c /= '\n'  {- ../ is a path traversal, no matter where it appears.  -
Annex/Url.hs view
@@ -6,6 +6,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.Url ( 	withUrlOptions, 	withUrlOptionsPromptingCreds,@@ -166,13 +168,13 @@ checkBoth url expected_size uo = 	liftIO (U.checkBoth url expected_size uo) >>= \case 		Right r -> return r-		Left err -> warning err >> return False+		Left err -> warning (UnquotedString err) >> return False  download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool download meterupdate iv url file uo = 	liftIO (U.download meterupdate iv url file uo) >>= \case 		Right () -> return True-		Left err -> warning err >> return False+		Left err -> warning (UnquotedString err) >> return False  download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ()) download' meterupdate iv url file uo =@@ -181,7 +183,7 @@ exists :: U.URLString -> U.UrlOptions -> Annex Bool exists url uo = liftIO (U.exists url uo) >>= \case 	Right b -> return b-	Left err -> warning err >> return False+	Left err -> warning (UnquotedString err) >> return False  getUrlInfo :: U.URLString -> U.UrlOptions -> Annex (Either String U.UrlInfo) getUrlInfo url uo = liftIO (U.getUrlInfo url uo)
Annex/Verify.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Annex.Verify ( 	shouldVerify,@@ -127,7 +128,7 @@ 			liftIO $ catchDefaultIO (Just False) $ 				finalizeIncrementalVerifier iv 		| otherwise = do-			showAction (descIncrementalVerifier iv)+			showAction (UnquotedString (descIncrementalVerifier iv)) 			liftIO $ catchDefaultIO (Just False) $ 				withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do 					hSeek h AbsoluteSeek endpos@@ -152,7 +153,7 @@ 	Nothing -> return True  warnUnverifiableInsecure :: Key -> Annex ()-warnUnverifiableInsecure k = warning $ unwords+warnUnverifiableInsecure k = warning $ UnquotedString $ unwords 	[ "Getting " ++ kv ++ " keys with this remote is not secure;" 	, "the content cannot be verified to be correct." 	, "(Use annex.security.allow-unverified-downloads to bypass"
Annex/YoutubeDl.hs view
@@ -1,6 +1,6 @@-{- youtube-dl integration for git-annex+{- yt-dlp (and deprecated youtube-dl) integration for git-annex  -- - Copyright 2017-2021 Joey Hess <id@joeyh.name>+ - Copyright 2017-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -12,6 +12,7 @@ 	youtubeDlCheck, 	youtubeDlFileName, 	youtubeDlFileNameHtmlOnly,+	youtubeDlCommand, ) where  import Annex.Common@@ -22,13 +23,11 @@ import Utility.HtmlDetect import Utility.Process.Transcript import Utility.Metered-import Utility.DataUnits import Messages.Progress import Logs.Transfer  import Network.URI import Control.Concurrent.Async-import Data.Char import Text.Read  -- youtube-dl can follow redirects to anywhere, including potentially@@ -39,10 +38,10 @@  youtubeDlNotAllowedMessage :: String youtubeDlNotAllowedMessage = unwords-	[ "This url is supported by youtube-dl, but"-	, "youtube-dl could potentially access any address, and the"+	[ "This url is supported by yt-dlp, but"+	, "yt-dlp could potentially access any address, and the" 	, "configuration of annex.security.allowed-ip-addresses"-	, "does not allow that. Not using youtube-dl."+	, "does not allow that. Not using yt-dlp (or youtube-dl)." 	]  -- Runs youtube-dl in a work directory, to download a single media file@@ -50,16 +49,18 @@ -- -- Displays a progress meter as youtube-dl downloads. ----- If youtube-dl fails without writing any files to the work directory, --- or is not installed, returns Right Nothing.------ The work directory can contain files from a previous run of youtube-dl--- and it will resume. It should not contain any other files though,--- and youtube-dl needs to finish up with only one file in the directory--- so we know which one it downloaded.+-- If no file is downloaded, or the program is not installed,+-- returns Right Nothing. ----- (Note that we can't use --output to specify the file to download to,--- due to <https://github.com/rg3/youtube-dl/issues/14864>)+-- youtube-dl can write to multiple files, either temporary files, or+-- multiple videos found at the url, and git-annex needs only one file.+-- So we need to find the destination file, and make sure there is not+-- more than one. With yt-dlp use --print-to-file to make it record the +-- file(s) it downloads. With youtube-dl, the best that can be done is+-- to require that the work directory end up with only 1 file in it.+-- (This can fail, but youtube-dl is deprecated, and they closed my+-- issue requesting something like --print-to-file; +-- <https://github.com/rg3/youtube-dl/issues/14864>) youtubeDl :: URLString -> FilePath -> MeterUpdate -> Annex (Either String (Maybe FilePath)) youtubeDl url workdir p = ifM ipAddressesUnlimited 	( withUrlOptions $ youtubeDl' url workdir p@@ -68,28 +69,38 @@  youtubeDl' :: URLString -> FilePath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe FilePath)) youtubeDl' url workdir p uo-	| supportedScheme uo url = ifM (liftIO . inSearchPath =<< youtubeDlCommand)-		( runcmd >>= \case-			Right True -> workdirfiles >>= \case-				(f:[]) -> return (Right (Just f))-				[] -> return nofiles-				fs -> return (toomanyfiles fs)-			Right False -> workdirfiles >>= \case-				[] -> return (Right Nothing)-				_ -> return (Left "youtube-dl download is incomplete. Run the command again to resume.")-			Left msg -> return (Left msg)-		, return (Right Nothing)-		)+	| supportedScheme uo url = do+		cmd <- youtubeDlCommand+		ifM (liftIO $ inSearchPath cmd)+			( runcmd cmd >>= \case+				Right True -> downloadedfiles cmd >>= \case+					(f:[]) -> return (Right (Just f))+					[] -> return (nofiles cmd)+					fs -> return (toomanyfiles cmd fs)+				Right False -> workdirfiles >>= \case+					[] -> return (Right Nothing)+					_ -> return (Left $ cmd ++ " download is incomplete. Run the command again to resume.")+				Left msg -> return (Left msg)+			, return (Right Nothing)+			) 	| otherwise = return (Right Nothing)   where-	nofiles = Left "youtube-dl did not put any media in its work directory, perhaps it's been configured to store files somewhere else?"-	toomanyfiles fs = Left $ "youtube-dl downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs-	workdirfiles = liftIO $ filterM (doesFileExist) =<< dirContents workdir-	runcmd = youtubeDlMaxSize workdir >>= \case+	nofiles cmd = Left $ cmd ++ " did not put any media in its work directory, perhaps it's been configured to store files somewhere else?"+	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)+				`catchIO` (pure . const [])+		| otherwise = workdirfiles+	workdirfiles = liftIO $ filter (/= filelistfile) +		<$> (filterM (doesFileExist) =<< dirContents workdir)+	filelistfile = workdir </> filelistfilebase+	filelistfilebase = "git-annex-file-list-file"+	isytdlp cmd = cmd == "yt-dlp"+	runcmd cmd = youtubeDlMaxSize workdir >>= \case 		Left msg -> return (Left msg) 		Right maxsize -> do-			cmd <- youtubeDlCommand-			opts <- youtubeDlOpts (dlopts ++ maxsize)+			opts <- youtubeDlOpts (dlopts cmd ++ maxsize) 			oh <- mkOutputHandlerQuiet 			-- The size is unknown to start. Once youtube-dl 			-- outputs some progress, the meter will be updated@@ -97,21 +108,31 @@ 			-- meter is passed into commandMeter' 			let unknownsize = Nothing :: Maybe FileSize 			ok <- metered (Just p) unknownsize Nothing $ \meter meterupdate ->-				liftIO $ commandMeter' -					parseYoutubeDlProgress oh (Just meter) meterupdate cmd opts+				liftIO $ commandMeter'+					(if isytdlp cmd then parseYtdlpProgress else parseYoutubeDlProgress)+					oh (Just meter) meterupdate cmd opts 					(\pr -> pr { cwd = Just workdir }) 			return (Right ok)-	dlopts = +	dlopts cmd =  		[ Param url-		-- To make youtube-dl only download one file when given a+		-- To make it only download one file when given a 		-- page with a video and a playlist, download only the video. 		, Param "--no-playlist" 		-- And when given a page with only a playlist, download only 		-- the first video on the playlist. (Assumes the video is 		-- somewhat stable, but this is the only way to prevent-		-- youtube-dl from downloading the whole playlist.)+		-- it from downloading the whole playlist.) 		, Param "--playlist-items", Param "0"-		]+		] +++			if isytdlp cmd+				then +					[ Param "--progress-template"+					, Param progressTemplate+					, Param "--print-to-file"+					, Param "after_move:filepath"+					, Param filelistfilebase+					]+				else []  -- To honor annex.diskreserve, ask youtube-dl to not download too -- large a media file. Factors in other downloads that are in progress,@@ -148,7 +169,7 @@ 				return (Just True) 			Right Nothing -> return (Just False) 			Left msg -> do-				warning msg+				warning (UnquotedString msg) 				return Nothing 	return (fromMaybe False res) @@ -251,7 +272,10 @@ youtubeDlCommand :: Annex String youtubeDlCommand = annexYoutubeDlCommand <$> Annex.getGitConfig >>= \case 	Just c -> pure c-	Nothing -> fromMaybe "yt-dlp" <$> liftIO (searchPath "youtube-dl")+	Nothing -> ifM (liftIO $ inSearchPath "yt-dlp")+		( return "yt-dlp"+		, return "youtube-dl"+		)  supportedScheme :: UrlOptions -> URLString -> Bool supportedScheme uo url = case parseURIRelaxed url of@@ -264,41 +288,39 @@ 		"ftp:" -> False 		_ -> allowedScheme uo u -{- Strategy: Look for chunks prefixed with \r, which look approximately- - like this for youtube-dl:- - "ESC[K[download]  26.6% of 60.22MiB at 254.69MiB/s ETA 00:00"- - or for yt-dlp, like this:- - "\r[download]   1.8% of    1.14GiB at    1.04MiB/s ETA 18:23"- - Look at the number before "% of " and the number and unit after,- - to determine the number of bytes.+progressTemplate :: String+progressTemplate = "ANNEX %(progress.downloaded_bytes)i %(progress.total_bytes_estimate)i %(progress.total_bytes)i ANNEX"++{- The progressTemplate makes output look like "ANNEX 10 100 NA ANNEX" or+ - "ANNEX 10 NA 100 ANNEX" depending on whether the total bytes are estimated+ - or known. That makes parsing much easier (and less fragile) than parsing+ - the usual progress output.  -}-parseYoutubeDlProgress :: ProgressParser-parseYoutubeDlProgress = go [] . reverse . progresschunks+parseYtdlpProgress :: ProgressParser+parseYtdlpProgress = go [] . reverse . progresschunks   where 	delim = '\r' -	progresschunks = drop 1 . splitc delim+	progresschunks = splitc delim  	go remainder [] = (Nothing, Nothing, remainder)-	go remainder (x:xs) = case split "% of " x of-		(p:r:[]) -> case (parsepercent p, parsebytes r) of-			(Just percent, Just total) ->-				( Just (toBytesProcessed (calc percent total))-				, Just (TotalSize total)-				, remainder-				)-			_ -> go (delim:x++remainder) xs-		_ -> go (delim:x++remainder) xs--	calc :: Double -> Integer -> Integer-	calc percent total = round (percent * fromIntegral total / 100)--	parsepercent :: String -> Maybe Double-	parsepercent = readMaybe -		. reverse . takeWhile (not . isSpace) . reverse-		. dropWhile isSpace --	parsebytes = readSize units . takeWhile (not . isSpace) -		. dropWhile isSpace+	go remainder (x:xs) = case splitc ' ' x of+			("ANNEX":downloaded_bytes_s:total_bytes_estimate_s:total_bytes_s:"ANNEX":[]) ->+				case (readMaybe downloaded_bytes_s, readMaybe total_bytes_estimate_s, readMaybe total_bytes_s) of+					(Just downloaded_bytes, Nothing, Just total_bytes) ->+						( Just (BytesProcessed downloaded_bytes)+						, Just (TotalSize total_bytes)+						, remainder+						)+					(Just downloaded_bytes, Just total_bytes_estimate, _) ->+						( Just (BytesProcessed downloaded_bytes)+						, Just (TotalSize total_bytes_estimate)+						, remainder+						)+					_ -> go (remainder++x) xs+			_ -> go (remainder++x) xs -	units = committeeUnits ++ storageUnits+{- youtube-dl is deprecated, parsing its progress was attempted before but+ - was buggy and is no longer done. -}+parseYoutubeDlProgress :: ProgressParser+parseYoutubeDlProgress _ = (Nothing, Nothing, "")
Assistant/DeleteRemote.hs view
@@ -31,7 +31,7 @@  - Remote data. -} disableRemote :: UUID -> Assistant Remote disableRemote uuid = do-	remote <- fromMaybe (error "unknown remote")+	remote <- fromMaybe (giveup "unknown remote") 		<$> liftAnnex (Remote.remoteFromUUID uuid) 	liftAnnex $ do 		inRepo $ Git.Remote.Remove.remove (Remote.name remote)@@ -57,7 +57,7 @@ 	Just keys 		| null keys -> finishRemovingRemote urlrenderer uuid 		| otherwise -> do-			r <- fromMaybe (error "unknown remote")+			r <- fromMaybe (giveup "unknown remote") 				<$> liftAnnex (Remote.remoteFromUUID uuid) 			mapM_ (queueremaining r) keys 	Nothing -> noop
Assistant/MakeRemote.hs view
@@ -47,7 +47,7 @@ addRemote a = do 	name <- a 	remotesChanged-	maybe (error "failed to add remote") return+	maybe (giveup "failed to add remote") return 		=<< Remote.byName (Just name)  {- Inits a rsync special remote, and returns its name. -}@@ -94,7 +94,7 @@ enableSpecialRemote :: SpecialRemoteMaker enableSpecialRemote name remotetype mcreds config = 	Annex.SpecialRemote.findExisting name >>= \case-		[] -> error $ "Cannot find a special remote named " ++ name+		[] -> giveup $ "Cannot find a special remote named " ++ name 		((u, c, mcu):_) -> setupSpecialRemote' False name remotetype config mcreds (Just u, R.Enable c, c) mcu  setupSpecialRemote :: RemoteName -> RemoteType -> R.RemoteConfig -> Maybe CredPair -> (Maybe UUID, R.SetupStage, R.RemoteConfig) -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> Annex RemoteName
Assistant/MakeRepo.hs view
@@ -34,7 +34,7 @@ 		(transcript, ok) <- 			processTranscript "git" (toCommand params) Nothing 		unless ok $-			error $ "git init failed!\nOutput:\n" ++ transcript+			giveup $ "git init failed!\nOutput:\n" ++ transcript 		return True 	)   where
Assistant/Pairing/MakeRemote.hs view
@@ -24,11 +24,11 @@  - side can immediately begin syncing. -} setupAuthorizedKeys :: PairMsg -> FilePath -> IO () setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of-	Left err -> error err+	Left err -> giveup err 	Right pubkey -> do 		absdir <- fromRawFilePath <$> absPath (toRawFilePath repodir) 		unlessM (liftIO $ addAuthorizedKeys True absdir pubkey) $-			error "failed setting up ssh authorized keys"+			giveup "failed setting up ssh authorized keys"  {- When local pairing is complete, this is used to set up the remote for  - the host we paired with. -}
Assistant/Ssh.hs view
@@ -68,7 +68,7 @@  {- user@host or host -} genSshHost :: Text -> Maybe Text -> SshHost-genSshHost host user = either error id $ mkSshHost $+genSshHost host user = either giveup id $ mkSshHost $ 	maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host  {- Generates a ssh or rsync url from a SshData. -}@@ -218,7 +218,7 @@ 		, Param "-f", File $ dir </> "key" 		] 	unless ok $-		error "ssh-keygen failed"+		giveup "ssh-keygen failed" 	SshKeyPair 		<$> readFile (dir </> "key.pub") 		<*> readFile (dir </> "key")
Assistant/Threads/Committer.hs view
@@ -1,11 +1,11 @@ {- git-annex assistant commit thread  -- - Copyright 2012-2021 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, OverloadedStrings #-}  module Assistant.Threads.Committer where @@ -38,6 +38,8 @@ import Utility.InodeCache import qualified Database.Keys import qualified Command.Sync+import qualified Command.Add+import Config.GitConfig import Utility.Tuple import Utility.Metered import qualified Utility.RawFilePath as R@@ -56,6 +58,7 @@ 	delayadd <- liftAnnex $ 		fmap Seconds . annexDelayAdd <$> Annex.getGitConfig 	largefilematcher <- liftAnnex largeFilesMatcher+	annexdotfiles <- liftAnnex $ getGitConfigVal annexDotFiles 	msg <- liftAnnex Command.Sync.commitMsg 	lockdowndir <- liftAnnex $ fromRepo gitAnnexTmpWatcherDir 	liftAnnex $ do@@ -65,7 +68,7 @@ 			(fromRawFilePath lockdowndir) 		void $ createAnnexDirectory lockdowndir 	waitChangeTime $ \(changes, time) -> do-		readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher delayadd $+		readychanges <- handleAdds (fromRawFilePath lockdowndir) havelsof largefilematcher annexdotfiles delayadd $ 			simplifyChanges changes 		if shouldCommit False time (length readychanges) readychanges 			then do@@ -261,8 +264,8 @@  - Any pending adds that are not ready yet are put back into the ChangeChan,  - where they will be retried later.  -}-handleAdds :: FilePath -> Bool -> GetFileMatcher -> Maybe Seconds -> [Change] -> Assistant [Change]-handleAdds lockdowndir havelsof largefilematcher delayadd cs = returnWhen (null incomplete) $ do+handleAdds :: FilePath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change]+handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = returnWhen (null incomplete) $ do 	let (pending, inprocess) = partition isPendingAddChange incomplete 	let lockdownconfig = LockDownConfig 		{ lockingFile = False@@ -289,15 +292,22 @@ 		| c = return otherchanges 		| otherwise = a -	checksmall change =-		ifM (liftAnnex $ checkFileMatcher largefilematcher (toRawFilePath (changeFile change)))-			( return (Left change)-			, return (Right change)-			)+	checksmall change+		| not annexdotfiles && dotfile f =+			return (Right change)+		| otherwise =+			ifM (liftAnnex $ checkFileMatcher largefilematcher f)+				( return (Left change)+				, return (Right change)+				)+	  where+		f = toRawFilePath (changeFile change)  	addsmall [] = noop-	addsmall toadd = liftAnnex $ Annex.Queue.addCommand [] "add"-		[ Param "--force", Param "--"] (map changeFile toadd)+	addsmall toadd = liftAnnex $ void $ tryIO $+		forM (map (toRawFilePath . changeFile) toadd) $ \f ->+			Command.Add.addFile Command.Add.Small f+				=<< liftIO (R.getSymbolicLinkStatus f)  	{- Avoid overhead of re-injesting a renamed unlocked file, by 	 - examining the other Changes to see if a removed file has the@@ -333,7 +343,7 @@ 	  	ks = keySource ld 		doadd = sanitycheck ks $ do 			(mkey, _mcache) <- liftAnnex $ do-				showStart "add" (keyFilename ks) (SeekInput [])+				showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput [])) 				ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing 			maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey 	addannexed' _ _ = return Nothing@@ -433,8 +443,8 @@  	canceladd (InProcessAddChange { lockedDown = ld }) = do 		let ks = keySource ld-		warning $ fromRawFilePath (keyFilename ks)-			++ " still has writers, not adding"+		warning $ QuotedPath (keyFilename ks)+			<> " still has writers, not adding" 		-- remove the hard link 		when (contentLocation ks /= keyFilename ks) $ 			void $ liftIO $ tryIO $ removeFile $ fromRawFilePath $ contentLocation ks
Assistant/Threads/Merger.hs view
@@ -58,7 +58,7 @@  {- Called when there's an error with inotify. -} onErr :: Handler-onErr = error+onErr = giveup  {- Called when a new branch ref is written, or a branch ref is modified.  -
Assistant/Threads/MountWatcher.hs view
@@ -74,7 +74,7 @@ 	onerr :: E.SomeException -> Assistant () 	onerr e = do 		liftAnnex $-			warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")"+			warning $ UnquotedString $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")" 		pollingThread urlrenderer  {- Examine the list of services connected to dbus, to see if there
Assistant/Threads/NetWatcher.hs view
@@ -78,7 +78,7 @@ 		sendRemoteControl RESUME 	onerr e _ = do 		liftAnnex $-			warning $ "lost dbus connection; falling back to polling (" ++ show e ++ ")"+			warning $ UnquotedString $ "lost dbus connection; falling back to polling (" ++ show e ++ ")" 		{- Wait, in hope that dbus will come back -} 		liftIO $ threadDelaySeconds (Seconds 60)
Assistant/Threads/PairListener.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Assistant.Threads.PairListener where  import Assistant.Common@@ -49,7 +51,7 @@ 					debug ["ignoring message that looped back"] 					go reqs cache sock 				(_, _, False, _) -> do-					liftAnnex $ warning $+					liftAnnex $ warning $ UnquotedString $ 						"illegal control characters in pairing message; ignoring (" ++ show (pairMsgData m) ++ ")" 					go reqs cache sock 				-- PairReq starts a pairing process, so a
Assistant/Threads/SanityChecker.hs view
@@ -127,7 +127,7 @@ 		return r  	showerr e = do-		liftAnnex $ warning $ show e+		liftAnnex $ warning $ UnquotedString $ show e 		return False  {- Only run one check per day, from the time of the last check. -}@@ -198,7 +198,7 @@ 	toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) 	slop = fromIntegral tenMinutes 	insanity msg = do-		liftAnnex $ warning msg+		liftAnnex $ warning (UnquotedString msg) 		void $ addAlert $ sanityCheckFixAlert msg 	addsymlink file s = do 		Watcher.runHandler Watcher.onAddSymlink file s
Assistant/Threads/TransferWatcher.hs view
@@ -15,6 +15,7 @@ import Utility.DirWatcher import Utility.DirWatcher.Types import qualified Remote+import qualified Annex import Annex.Perms  import Control.Concurrent@@ -52,7 +53,7 @@  {- Called when there's an error with inotify. -} onErr :: Handler-onErr = error+onErr = giveup  {- Called when a new transfer information file is written. -} onAdd :: Handler@@ -62,7 +63,8 @@   where 	go _ Nothing = noop -- transfer already finished 	go t (Just info) = do-		debug [ "transfer starting:", describeTransfer t info ]+		qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig+		debug [ "transfer starting:", describeTransfer qp t info ] 		r <- liftAnnex $ Remote.remoteFromUUID $ transferUUID t 		updateTransferInfo t info { transferRemote = r }
Assistant/Threads/Watcher.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE DeriveDataTypeable, CPP #-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, CPP #-}  module Assistant.Threads.Watcher ( 	watchThread,@@ -184,7 +184,7 @@ runHandler handler file filestatus = void $ do 	r <- tryIO <~> handler (normalize file) filestatus 	case r of-		Left e -> liftAnnex $ warning $ show e+		Left e -> liftAnnex $ warning $ UnquotedString $ show e 		Right Nothing -> noop 		Right (Just change) -> recordChange change   where@@ -371,6 +371,6 @@ {- Called when there's an error with inotify or kqueue. -} onErr :: Handler onErr msg _ = do-	liftAnnex $ warning msg+	liftAnnex $ warning (UnquotedString msg) 	void $ addAlert $ warningAlert "watcher" msg 	noChange
Assistant/TransferQueue.hs view
@@ -31,6 +31,7 @@ import Types.Remote import qualified Remote import qualified Types.Remote as Remote+import qualified Annex import Annex.Wanted import Utility.TList @@ -139,7 +140,8 @@ 	| otherwise = go snocTList   where 	go modlist = whenM (add modlist) $ do-		debug [ "queued", describeTransfer t info, ": " ++ reason ]+		qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig+		debug [ "queued", describeTransfer qp t info, ": " ++ reason ] 		notifyTransfer 	add modlist = do 		q <- getAssistant transferQueue
Assistant/TransferSlots.hs view
@@ -123,14 +123,16 @@ 			return Nothing 		, ifM (liftAnnex $ shouldTransfer t info) 			( do-				debug [ "Transferring:" , describeTransfer t info ]+				qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig+				debug [ "Transferring:" , describeTransfer qp t info ] 				notifyTransfer 				let sd = remoteAnnexStallDetection 					(Remote.gitconfig remote) 				return $ Just (t, info, go remote sd) 			, do+				qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig 				debug [ "Skipping unnecessary transfer:",-					describeTransfer t info ]+					describeTransfer qp t info ] 				void $ removeTransfer t 				finishedTransfer t (Just info) 				return Nothing@@ -241,9 +243,11 @@ 				Later (transferKey t) (associatedFile info) Upload 	| otherwise = dodrops True   where-	dodrops fromhere = handleDrops-		("drop wanted after " ++ describeTransfer t info)-		fromhere (transferKey t) (associatedFile info) []+	dodrops fromhere = do+		qp <- liftAnnex $ coreQuotePath <$> Annex.getGitConfig+		handleDrops+			("drop wanted after " ++ describeTransfer qp t info)+			fromhere (transferKey t) (associatedFile info) [] finishedTransfer _ _ = noop  {- Pause a running transfer. -}
Assistant/Upgrade.hs view
@@ -205,7 +205,7 @@ 				, Param "--directory", File tmpdir 				] 			unless tarok $-				error $ "failed to untar " ++ distributionfile+				giveup $ "failed to untar " ++ distributionfile 			sanitycheck $ tmpdir </> installBase 			installby R.rename newdir (tmpdir </> installBase) 		let deleteold = do@@ -218,7 +218,7 @@ #endif 	sanitycheck dir =  		unlessM (doesDirectoryExist dir) $-			error $ "did not find " ++ dir ++ " in " ++ distributionfile+			giveup $ "did not find " ++ dir ++ " in " ++ distributionfile 	makeorigsymlink olddir = do 		let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) </> installBase 		removeWhenExistsWith R.removeLink (toRawFilePath origdir)@@ -227,7 +227,7 @@ {- Finds where the old version was installed. -} oldVersionLocation :: IO FilePath oldVersionLocation = readProgramFile >>= \case-	Nothing -> error "Cannot find old distribution bundle; not upgrading."+	Nothing -> giveup "Cannot find old distribution bundle; not upgrading." 	Just pf -> do 		let pdir = fromRawFilePath $ parentDir $ toRawFilePath pf #ifdef darwin_HOST_OS@@ -240,7 +240,7 @@ 		let olddir = pdir #endif 		when (null olddir) $-			error $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")"+			giveup $ "Cannot find old distribution bundle; not upgrading. (Looked in " ++ pdir ++ ")" 		return olddir  {- Finds a place to install the new version.
Assistant/WebApp/Configurators/Delete.hs view
@@ -34,7 +34,7 @@ 		then redirect DeleteCurrentRepositoryR 		else go =<< liftAnnex (Remote.remoteFromUUID uuid)   where-	go Nothing = error "Unknown UUID"+	go Nothing = giveup "Unknown UUID" 	go (Just _) = a  getDeleteRepositoryR :: UUID -> Handler Html@@ -45,7 +45,7 @@  getStartDeleteRepositoryR :: UUID -> Handler Html getStartDeleteRepositoryR uuid = do-	remote <- fromMaybe (error "unknown remote")+	remote <- fromMaybe (giveup "unknown remote") 		<$> liftAnnex (Remote.remoteFromUUID uuid) 	liftAnnex $ do 		trustSet uuid UnTrusted
Assistant/WebApp/Configurators/Edit.hs view
@@ -203,7 +203,7 @@ 		mremote <- liftAnnex $ Remote.remoteFromUUID uuid 		when (mremote == Nothing) $ 			whenM ((/=) uuid <$> liftAnnex getUUID) $-				error "unknown remote"+				giveup "unknown remote" 		curr <- liftAnnex $ getRepoConfig uuid mremote 		liftAnnex $ checkAssociatedDirectory curr mremote 		mrepo <- liftAnnex $
Assistant/WebApp/Configurators/Pairing.hs view
@@ -216,10 +216,10 @@ 	 - background. -} 	thread <- liftAssistant $ asIO $ do 		keypair <- liftIO $ genSshKeyPair-		let pubkey = either error id $ validateSshPubKey $ sshPubKey keypair+		let pubkey = either giveup id $ validateSshPubKey $ sshPubKey keypair 		pairdata <- liftIO $ PairData 			<$> getHostname-			<*> (either error id <$> myUserName)+			<*> (either giveup id <$> myUserName) 			<*> pure reldir 			<*> pure pubkey 			<*> (maybe genUUID return muuid)
Assistant/WebApp/Page.hs view
@@ -67,7 +67,7 @@ 					addScript $ StaticR js_longpolling_js 				$(widgetFile "page") 			withUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")-		Just msg -> error msg+		Just msg -> giveup msg   where 	navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
Backend.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Backend ( 	builtinList, 	defaultBackend,@@ -66,7 +68,8 @@ getBackend file k = maybeLookupBackendVariety (fromKey keyVariety k) >>= \case 	Just backend -> return $ Just backend 	Nothing -> do-		warning $ "skipping " ++ file ++ " (" ++ unknownBackendVarietyMessage (fromKey keyVariety k) ++ ")"+		warning $ "skipping " <> QuotedPath (toRawFilePath file) <> " (" <>+			UnquotedString (unknownBackendVarietyMessage (fromKey keyVariety k)) <> ")" 		return Nothing  unknownBackendVarietyMessage :: KeyVariety -> String
Backend/External.hs view
@@ -139,7 +139,8 @@ 		loop   where 	handleExceptionalMessage _ (ERROR err) = do-		warning ("external special remote error: " ++ err)+		warning $ UnquotedString $+			"external special remote error: " ++ err 		whenunavail 	handleExceptionalMessage loop (DEBUG msg) = do 		fastDebug "Backend.External" msg@@ -237,7 +238,7 @@   where 	basecmd = externalBackendProgram ebname 	warnonce msg = when (pid == 1) $-		warning msg+		warning (UnquotedString msg)  externalBackendProgram :: ExternalBackendName -> String externalBackendProgram (ExternalBackendName bname) = "git-annex-backend-X" ++ decodeBS bname
Backend/Hash.hs view
@@ -124,13 +124,13 @@ 	exists <- liftIO $ R.doesPathExist file 	case (exists, fast) of 		(True, False) -> do-			showAction descChecksum+			showAction (UnquotedString descChecksum) 			sameCheckSum key  				<$> hashFile hash file nullMeterUpdate 		_ -> return True   where 	hwfault e = do-		warning $ "hardware fault: " ++ show e+		warning $ UnquotedString $ "hardware fault: " ++ show e 		return False  sameCheckSum :: Key -> String -> Bool@@ -229,7 +229,7 @@ 	| hashsize == 224 = mkHasher sha2_224 sha2_224_context 	| hashsize == 384 = mkHasher sha2_384 sha2_384_context 	| hashsize == 512 = mkHasher sha2_512 sha2_512_context-	| otherwise = error $ "unsupported SHA2 size " ++ show hashsize+	| otherwise = giveup $ "unsupported SHA2 size " ++ show hashsize  sha3Hasher :: HashSize -> Hasher sha3Hasher (HashSize hashsize)@@ -237,13 +237,13 @@ 	| hashsize == 224 = mkHasher sha3_224 sha3_224_context 	| hashsize == 384 = mkHasher sha3_384 sha3_384_context 	| hashsize == 512 = mkHasher sha3_512 sha3_512_context-	| otherwise = error $ "unsupported SHA3 size " ++ show hashsize+	| otherwise = giveup $ "unsupported SHA3 size " ++ show hashsize  skeinHasher :: HashSize -> Hasher skeinHasher (HashSize hashsize) 	| hashsize == 256 = mkHasher skein256 skein256_context 	| hashsize == 512 = mkHasher skein512 skein512_context-	| otherwise = error $ "unsupported SKEIN size " ++ show hashsize+	| otherwise = giveup $ "unsupported SKEIN size " ++ show hashsize  blake2bHasher :: HashSize -> Hasher blake2bHasher (HashSize hashsize)@@ -252,25 +252,25 @@ 	| hashsize == 160 = mkHasher blake2b_160 blake2b_160_context 	| hashsize == 224 = mkHasher blake2b_224 blake2b_224_context 	| hashsize == 384 = mkHasher blake2b_384 blake2b_384_context-	| otherwise = error $ "unsupported BLAKE2B size " ++ show hashsize+	| otherwise = giveup $ "unsupported BLAKE2B size " ++ show hashsize  blake2bpHasher :: HashSize -> Hasher blake2bpHasher (HashSize hashsize) 	| hashsize == 512 = mkHasher blake2bp_512 blake2bp_512_context-	| otherwise = error $ "unsupported BLAKE2BP size " ++ show hashsize+	| otherwise = giveup $ "unsupported BLAKE2BP size " ++ show hashsize  blake2sHasher :: HashSize -> Hasher blake2sHasher (HashSize hashsize) 	| hashsize == 256 = mkHasher blake2s_256 blake2s_256_context 	| hashsize == 160 = mkHasher blake2s_160 blake2s_160_context 	| hashsize == 224 = mkHasher blake2s_224 blake2s_224_context-	| otherwise = error $ "unsupported BLAKE2S size " ++ show hashsize+	| otherwise = giveup $ "unsupported BLAKE2S size " ++ show hashsize  blake2spHasher :: HashSize -> Hasher blake2spHasher (HashSize hashsize) 	| hashsize == 256 = mkHasher blake2sp_256 blake2sp_256_context 	| hashsize == 224 = mkHasher blake2sp_224 blake2sp_224_context-	| otherwise = error $ "unsupported BLAKE2SP size " ++ show hashsize+	| otherwise = giveup $ "unsupported BLAKE2SP size " ++ show hashsize  sha1Hasher :: Hasher sha1Hasher = mkHasher sha1 sha1_context
Build/mdwn2man view
@@ -7,7 +7,7 @@ print ".TH $prog $section\n";  while (<>) {-	s{(\\?)\[\[([^\s\|\]]+)(\|[^\s\]]+)?\]\]}{$1 ? "[[$2]]" : $2}eg;+	s{(\\?)\[\[([^:\s\|\]]+)(\|[^\s\]]+)?\]\]}{$1 ? "[[$2]]" : $2}eg; 	s/\`([^\`]*)\`/\\fB$1\\fP/g; 	s/\`//g; 	s/^ *\./\\&./g;
CHANGELOG view
@@ -1,3 +1,103 @@+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.+    (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+    new files added and content transferred by default.+  * sync: Started a transition to --content being enabled by default.+    When used without --content or --no-content, warn about the upcoming+    transition, and suggest using one of the options, or setting+    annex.synccontent.+  * sync: Added -g as a short option for --no-content.+  * Many commands now quote filenames that contain unusual characters the+    same way that git does, to avoid exposing control characters to the+    terminal.+  * Support core.quotePath, which can be set to false to display utf8+    characters as-is in filenames.+  * Control characters in non-filename data coming from the repository or+    other possible untrusted sources are filtered out of the display of many+    commands. When the command output is intended for use in scripting,+    control characters are only filtered out when displaying to the+    terminal.+  * find, findkeys, examinekey: When outputting to a terminal and --format+    is not used, quote control characters. Output to a pipe is unchanged.+    (Similar to the behavior of GNU find.)+  * addurl --preserve-filename now rejects filenames that contain other+    control characters, besides the escape sequences it already rejected.+  * init: Avoid autoenabling special remotes that have control characters+    in their names.+  * Support core.sharedRepository=0xxx at long last.+  * Support --json and --json-error-messages in many more commands+    (addunused, configremote, dead, describe, dropunused, enableremote,+    expire, fix, importfeed, init, initremote, log, merge, migrate, reinit,+    reinject, rekey, renameremote, rmurl, semitrust, setpresentkey, trust,+    unannex, undo, uninit, untrust, unused, upgrade)+  * importfeed: Support -J+  * importfeed: Support --json-progress+  * httpalso: Support being used with special remotes that use chunking.+  * Several significant speedups to importing large trees from special+    remotes. Imports that took over an hour now take only a few minutes.+  * 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+    or --unlock-present.+  * config: Added the --show-origin and --for-file options.+  * config: Support annex.numcopies and annex.mincopies.+  * whereused: Fix display of branch:file when run in a subdirectory.+  * enableremote: Support enableremote of a git remote (that was previously+    set up with initremote) when additional parameters such as autoenable=+    are passed.+  * configremote: New command, currently limited to changing autoenable=+    setting of a special remote.+  * Honor --force option when operating on a local git remote.+  * When a nonexistant file is passed to a command and +    --json-error-messages is enabled, output a JSON object indicating the+    problem. (But git ls-files --error-unmatch still displays errors about+    such files in some situations.)+  * Bug fix: Create .git/annex/, .git/annex/fsckdb,+    .git/annex/sentinal, .git/annex/sentinal.cache, and+    .git/annex/journal/* with permissions configured by core.sharedRepository.+  * Bug fix: Lock files were created with wrong modes for some combinations+    of core.sharedRepository and umask.+  * initremote: Avoid creating a remote that is not encrypted when gpg is+    broken.+  * log: When --raw-date is used, display only seconds from the epoch, as+    documented, omitting a trailing "s" that was included in the output+    before.+  * addunused: Displays the names of the files that it adds.+  * reinject: Fix support for operating on multiple pairs of files and keys.+  * sync: Fix buggy handling of --no-pull and --no-push when syncing+    --content. With --no-pull, avoid downloading content, and with+    --no-push avoid uploading content. This was done before, but+    inconsistently.+  * uninit: Avoid buffering the names of all annexed files in memory.+  * Fix bug in -z handling of trailing NUL in input.+  * version: Avoid error message when entire output is not read.+  * Fix excessive CPU usage when parsing yt-dlp (or youtube-dl) progress+    output fails.+  * Use --progress-template with yt-dlp to fix a failure to parse+    progress output when only an estimated total size is known.+  * When yt-dlp is available, default to using it in preference to+    youtube-dl. Using youtube-dl is now deprecated, and git-annex no longer+    tries to parse its output to display download progress+  * Improve resuming interrupted download when using yt-dlp or youtube-dl.+  * assistant: Add dotfiles to git by default, unless annex.dotfiles+    is configured, the same as git-annex add does.+  * assistant --autostop: Avoid crashing when ~/.config/git-annex/autostart+    lists a directory that it cannot chdir to.+  * Fix display when run with -J1.+  * assistant: Fix a crash when a small file is deleted immediately after+    being created.+  * repair: Fix handling of git ref names on Windows.+  * repair: Fix a crash when .git/annex/journal/ does not exist.+  * Support building with optparse-applicative 0.18.1+    (Thanks, Peter Simons)++ -- Joey Hess <id@joeyh.name>  Mon, 26 Jun 2023 10:37:36 -0400+ git-annex (10.20230407) upstream; urgency=medium    * Fix laziness bug introduced in last release that breaks use
CmdLine.hs view
@@ -116,7 +116,7 @@ 		<*> getparser c 		<*> parserAnnexOptions (cmdannexoptions c) 	synopsis n d = n ++ " - " ++ d-	intro = mconcat $ concatMap (\l -> [H.text l, H.line])+	intro = mconcat $ concatMap (\l -> [H.pretty l, H.line]) 		(synopsis progname progdesc : commandList allcmds)  {- Selects the Command that matches the subcommand name.
CmdLine/Action.hs view
@@ -74,9 +74,7 @@ 	st <- Annex.getState id 	case getConcurrency' (Annex.concurrency st) of 		NonConcurrent -> runnonconcurrent (Annex.sizelimit st)-		Concurrent n-			| n > 1 -> runconcurrent (Annex.sizelimit st) (Annex.workers st)-			| otherwise -> runnonconcurrent (Annex.sizelimit st)+		Concurrent _ -> runconcurrent (Annex.sizelimit st) (Annex.workers st) 		ConcurrentPerCpu -> runconcurrent (Annex.sizelimit st) (Annex.workers st)   where 	runnonconcurrent sizelimit = start >>= \case@@ -192,7 +190,7 @@ 	Left err -> case fromException err of 		Just exitcode -> liftIO $ exitWith exitcode 		Nothing -> do-			toplevelWarning True (show err)+			toplevelWarning True (UnquotedString (show err)) 			showEndMessage startmsg False 			incerr   where@@ -235,8 +233,11 @@ 	let usegitcfg = setConcurrency (ConcurrencyGitConfig fromgitcfg) 	case (fromcmdline, fromgitcfg) of 		(NonConcurrent, NonConcurrent) -> a-		(Concurrent n, _) ->-			goconcurrent n+		(Concurrent n, _) +			| n > 1 -> goconcurrent n+			| otherwise -> do+				setConcurrency' NonConcurrent ConcurrencyCmdLine+				a 		(ConcurrentPerCpu, _) -> 			goconcurrentpercpu 		(NonConcurrent, Concurrent n) -> do
CmdLine/Batch.hs view
@@ -115,7 +115,17 @@   where 	splitter = case sep of 		BatchLine -> lines-		BatchNull -> splitc '\0'+		BatchNull -> elimemptyend . splitc '\0'++	-- When there is a trailing null on the input, eliminate the empty+	-- string that splitc generates. Other empty strings elsewhere in+	-- the list are preserved. This is the same effect as how `lines`+	-- handles a trailing newline.+	elimemptyend [] = []+	elimemptyend (x:[])+		| null x = []+		| otherwise = [x]+	elimemptyend (x:rest) = x : elimemptyend rest  -- When concurrency is enabled at the command line, it is used in batch -- mode. But, if it's only set in git config, don't use it, because the
CmdLine/GitAnnex.hs view
@@ -56,6 +56,7 @@ import qualified Command.Describe import qualified Command.InitRemote import qualified Command.EnableRemote+import qualified Command.ConfigRemote import qualified Command.RenameRemote import qualified Command.EnableTor import qualified Command.Multicast@@ -99,6 +100,9 @@ import qualified Command.Config import qualified Command.Vicfg import qualified Command.Sync+import qualified Command.Assist+import qualified Command.Pull+import qualified Command.Push import qualified Command.Mirror import qualified Command.AddUrl import qualified Command.ImportFeed@@ -144,6 +148,9 @@ 	, Command.Unlock.editcmd 	, Command.Lock.cmd 	, Command.Sync.cmd+	, Command.Assist.cmd+	, Command.Pull.cmd+	, Command.Push.cmd 	, Command.Mirror.cmd 	, Command.AddUrl.cmd 	, Command.ImportFeed.cmd@@ -154,6 +161,7 @@ 	, Command.Describe.cmd 	, Command.InitRemote.cmd 	, Command.EnableRemote.cmd+	, Command.ConfigRemote.cmd 	, Command.RenameRemote.cmd 	, Command.EnableTor.cmd 	, Command.Multicast.cmd
CmdLine/GitAnnex/Options.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}  module CmdLine.GitAnnex.Options where
CmdLine/GitAnnexShell/Checks.hs view
@@ -78,7 +78,7 @@ {- Modifies a Command to check that it is run in either a git-annex  - repository, or a repository with a gcrypt-id set. -} gitAnnexShellCheck :: Command -> Command-gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists+gitAnnexShellCheck = addCheck GitAnnexShellOk okforshell . dontCheck repoExists   where 	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $ 		giveup "Not a git-annex or gcrypt repository."
CmdLine/GitRemoteTorAnnex.hs view
@@ -25,7 +25,7 @@ 		"capabilities" -> putStrLn "connect" >> ready 		"connect git-upload-pack" -> go UploadPack 		"connect git-receive-pack" -> go ReceivePack-		l -> error $ "git-remote-helpers protocol error at " ++ show l+		l -> giveup $ "git-remote-helpers protocol error at " ++ show l   where 	(onionaddress, onionport) 		| '/' `elem` address = parseAddressPort $
CmdLine/Option.hs view
@@ -56,7 +56,7 @@ 		) 	, annexOption setdebugfilter $ strOption 		( long "debugfilter" <> metavar "NAME[,NAME..]"-		<> help "show debug messages coming from a module"+		<> help "show debug messages coming from the specified module" 		<> hidden 		) 	]
CmdLine/Seek.hs view
@@ -9,6 +9,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module CmdLine.Seek where  import Annex.Common@@ -145,9 +147,9 @@ 	pairs c (x:y:xs) = pairs ((x,y):c) xs 	pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek-withFilesToBeCommitted a l = seekFiltered (const (pure True)) a $-	seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l+withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek+withFilesToBeCommitted ww a l = seekFiltered (const (pure True)) a $+	seekHelper id ww (const LsFiles.stagedNotDeleted) l  {- unlocked pointer files that are staged, and whose content has not been  - modified-}@@ -313,7 +315,7 @@ 					in keyaction lt (SeekInput [], k, bfp) 				Nothing -> noop 			unlessM (liftIO cleanup) $-				error ("git ls-tree " ++ Git.fromRef b ++ " failed")+				giveup ("git ls-tree " ++ Git.fromRef b ++ " failed") 	 	runfailedtransfers = do 		keyaction <- mkkeyaction@@ -510,15 +512,15 @@ 		and <$> sequence cleanups seekHelper _ _ _ NoWorkTreeItems = return ([], pure True) -data WarnUnmatchWhen = WarnUnmatchLsFiles | WarnUnmatchWorkTreeItems+data WarnUnmatchWhen = WarnUnmatchLsFiles String | WarnUnmatchWorkTreeItems String  seekOptions :: WarnUnmatchWhen -> Annex [LsFiles.Options]-seekOptions WarnUnmatchLsFiles =+seekOptions (WarnUnmatchLsFiles _) = 	ifM (annexSkipUnknown <$> Annex.getGitConfig) 		( return []  		, return [LsFiles.ErrorUnmatch] 		)-seekOptions WarnUnmatchWorkTreeItems = return []+seekOptions (WarnUnmatchWorkTreeItems _) = return []  -- Items in the work tree, which may be files or directories. data WorkTreeItems@@ -552,23 +554,23 @@  workTreeItems' :: AllowHidden -> WarnUnmatchWhen -> CmdParams -> Annex WorkTreeItems workTreeItems' (AllowHidden allowhidden) ww ps = case ww of-	WarnUnmatchWorkTreeItems -> runcheck-	WarnUnmatchLsFiles -> +	(WarnUnmatchWorkTreeItems action) -> runcheck action+	(WarnUnmatchLsFiles action) ->  		ifM (annexSkipUnknown <$> Annex.getGitConfig)-			( runcheck+			( runcheck action 			, return $ WorkTreeItems ps 			)   where-	runcheck = do+	runcheck action = do 		currbranch <- getCurrentBranch 		stopattop <- prepviasymlink 		ps' <- flip filterM ps $ \p -> do 			let p' = toRawFilePath p 			relf <- liftIO $ relPathCwdToFile p' 			ifM (not <$> (exists p' <||> hidden currbranch relf))-				( prob (p ++ " not found")+				( prob action FileNotFound p' "not found" 				, ifM (viasymlink stopattop (upFrom relf))-					( prob (p ++ " is beyond a symbolic link")+					( prob action FileBeyondSymbolicLink p' "is beyond a symbolic link" 					, return True 					) 				)@@ -603,8 +605,8 @@ 			<$> catObjectMetaDataHidden f currbranch 		| otherwise = return False -	prob msg = do-		toplevelWarning False msg+	prob action errorid p msg = do+		toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromRawFilePath p]) 		Annex.incError 		return False 	@@ -628,7 +630,7 @@ 						swapTVar warningshownv True 					unless warningshown $ do 						Annex.changeState $ \s -> s { Annex.reachedlimit = True }-						warning $ "Time limit (" ++ fromDuration duration ++ ") reached! Shutting down..."+						warning $ UnquotedString $ "Time limit (" ++ fromDuration duration ++ ") reached! Shutting down..." 						cleanup 				else a
Command.hs view
@@ -25,7 +25,7 @@ import Annex.Init import Utility.Daemon import Types.Transfer-import Types.ActionItem+import Types.ActionItem as ReExported import Types.WorkerPool as ReExported import Remote.List @@ -125,17 +125,17 @@ commonChecks = [repoExists]  repoExists :: CommandCheck-repoExists = CommandCheck 0 (ensureInitialized remoteList)+repoExists = CommandCheck RepoExists (ensureInitialized remoteList)  notBareRepo :: Command -> Command-notBareRepo = addCheck checkNotBareRepo+notBareRepo = addCheck CheckNotBareRepo checkNotBareRepo  checkNotBareRepo :: Annex () checkNotBareRepo = whenM (fromRepo Git.repoIsLocalBare) $ 	giveup "You cannot run this command in a bare repository."  noDaemonRunning :: Command -> Command-noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $+noDaemonRunning = addCheck NoDaemonRunning $ whenM (isJust <$> daemonpid) $ 	giveup "You cannot run this command while git-annex watch or git-annex assistant is running."   where 	daemonpid = liftIO . checkDaemon . fromRawFilePath@@ -144,9 +144,9 @@ dontCheck :: CommandCheck -> Command -> Command dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c -addCheck :: Annex () -> Command -> Command-addCheck check cmd = mutateCheck cmd $ \c ->-	CommandCheck (length c + 100) check : c+addCheck :: CommandCheckId -> Annex () -> Command -> Command+addCheck cid check cmd = mutateCheck cmd $ \c ->+	CommandCheck cid check : c  mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }
Command/Add.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Add where  import Command@@ -84,7 +86,10 @@ 		(help "Do not check .gitignore when adding files")  seek :: AddOptions -> CommandSeek-seek o = startConcurrency commandStages $ do+seek o = startConcurrency commandStages (seek' o)++seek' :: AddOptions -> CommandSeek+seek' o = do 	largematcher <- largeFilesMatcher 	addunlockedmatcher <- addUnlockedMatcher 	annexdotfiles <- getGitConfigVal annexDotFiles @@ -117,7 +122,7 @@ 			-- are not known to git yet, since this will add 			-- them. Instead, have workTreeItems warn about other 			-- problems, like files that don't exist.-			let ww = WarnUnmatchWorkTreeItems+			let ww = WarnUnmatchWorkTreeItems "add" 			l <- workTreeItems ww (addThese o) 			let go b a = a ww (commandAction . gofile b) l 			unless (updateOnly o) $@@ -160,7 +165,10 @@ 		then hashBlob =<< liftIO (R.readSymbolicLink file) 		else if isRegularFile s 			then hashFile file-			else giveup $ fromRawFilePath file ++ " is not a regular file"+			else do+				qp <- coreQuotePath <$> Annex.getGitConfig+				giveup $ decodeBS $ quote qp $+					file <> " is not a regular file" 	let treetype = if isSymbolicLink s 		then TreeSymlink 		else if intersectFileModes ownerExecuteMode (fileMode s) /= 0@@ -169,7 +177,7 @@ 	s' <- liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file 	if maybe True (changed s) s' 		then do-			warning $ fromRawFilePath file ++ " changed while it was being added"+			warning $ QuotedPath file <> " changed while it was being added" 			return False 		else do 			case smallorlarge of
Command/AddUnused.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2012 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -15,28 +15,29 @@ import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)  cmd :: Command-cmd = command "addunused" SectionMaintenance -	"add back unused files"-	(paramRepeating paramNumRange) (withParams seek)+cmd = withAnnexOptions [jsonOptions] $+	command "addunused" SectionMaintenance +		"add back unused files"+		(paramRepeating paramNumRange) (withParams seek)  seek :: CmdParams -> CommandSeek seek = withUnusedMaps start  start :: UnusedMaps -> Int -> CommandStart-start = startUnused "addunused" perform-	(performOther "bad")-	(performOther "tmp")--perform :: Key -> CommandPerform-perform key = next $ do-	logStatus key InfoPresent-	addSymlink file key Nothing-	return True+start = startUnused go (other "bad") (other "tmp")   where-	file = "unused." <> keyFile key+	go n key = do+		let file = "unused." <> keyFile key+		starting "addunused"+			(ActionItemTreeFile file)+			(SeekInput [show n]) $+			next $ do+				logStatus key InfoPresent+				addSymlink file key Nothing+				return True -{- The content is not in the annex, but in another directory, and- - it seems better to error out, rather than moving bad/tmp content into- - the annex. -}-performOther :: String -> Key -> CommandPerform-performOther other _ = giveup $ "cannot addunused " ++ other ++ "content"+	{- The content is not in the annex, but in another directory, and+	 - it seems better to error out, rather than moving bad/tmp content+	 - into the annex. -}+	other n _ _ = giveup $ "cannot addunused " ++ n ++ "content"+
Command/AddUrl.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.AddUrl where  import Command@@ -145,13 +147,13 @@ 	pathmax <- liftIO $ fileNameLengthLimit "." 	let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption (downloadOptions o)) 	go deffile =<< maybe-		(error $ "unable to checkUrl of " ++ Remote.name r)+		(giveup $ "unable to checkUrl of " ++ Remote.name r) 		(tryNonAsync . flip id u) 		(Remote.checkUrl r)   where  	go _ (Left e) = void $ commandAction $ startingAddUrl si u o $ do-		warning (show e)+		warning (UnquotedString (show e)) 		next $ return False 	go deffile (Right (UrlContents sz mf)) = do 		f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o) mf@@ -180,8 +182,8 @@ 	let file' = joinPath $ map (truncateFilePath pathmax) $ 		splitDirectories file 	startingAddUrl si uri o $ do-		showNote $ "from " ++ Remote.name r -		showDestinationFile file'+		showNote $ UnquotedString $ "from " ++ Remote.name r +		showDestinationFile (toRawFilePath file') 		performRemote addunlockedmatcher r o uri (toRawFilePath file') sz  performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform@@ -231,7 +233,7 @@ 			else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case 				Right urlinfo -> go' url urlinfo 				Left err -> do-					warning err+					warning (UnquotedString err) 					next $ return False 	go' url urlinfo = do 		pathmax <- liftIO $ fileNameLengthLimit "."@@ -262,16 +264,18 @@ -- (and probably others, but at least this catches the most egrarious ones). checkPreserveFileNameSecurity :: FilePath -> Annex () checkPreserveFileNameSecurity f = do-	checksecurity escapeSequenceInFilePath False "escape sequence"-	checksecurity pathTraversalInFilePath True "path traversal"-	checksecurity gitDirectoryInFilePath True "contains a .git directory"+	checksecurity controlCharacterInFilePath "control character"+	checksecurity pathTraversalInFilePath "path traversal"+	checksecurity gitDirectoryInFilePath "contains a .git directory"   where-	checksecurity p canshow d = when (p f) $-		giveup $ concat-			[ "--preserve-filename was used, but the filename "-			, if canshow then "(" ++ f ++ ") " else ""-			, "has a security problem (" ++ d ++ "), not adding."-			]+	checksecurity p d = when (p f) $ do+		qp <- coreQuotePath <$> Annex.getGitConfig+		giveup $ decodeBS $ quote qp $+			"--preserve-filename was used, but the filename ("+				<> QuotedPath (toRawFilePath f)+				<> ") has a security problem ("+				<> d+				<> "), not adding."  performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> RawFilePath -> Url.UrlInfo -> CommandPerform performWeb addunlockedmatcher o url file urlinfo = lookupKey file >>= \case@@ -282,7 +286,7 @@ 	addurl = addUrlChecked o url file webUUID $ \k -> 		ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url) 			( return (Just (True, True, setDownloader url YoutubeDownloader))-			, checkRaw Nothing (downloadOptions o) Nothing $+			, checkRaw Nothing (downloadOptions o) (pure Nothing) $ 				return (Just (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url)) 			) @@ -292,7 +296,7 @@ addUrlChecked o url file u checkexistssize key = 	ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key)) 		( do-			showDestinationFile (fromRawFilePath file)+			showDestinationFile file 			next $ return True 		, checkexistssize key >>= \case 			Just (exists, samesize, url')@@ -301,7 +305,7 @@ 					logChange key u InfoPresent 					next $ return True 				| otherwise -> do-					warning $ "while adding a new url to an already annexed file, " ++ if exists+					warning $ UnquotedString $ "while adding a new url to an already annexed file, " ++ if exists 						then "url does not have expected file size (use --relaxed to bypass this check) " ++ url 						else "failed to verify url exists: " ++ url 					stop@@ -333,36 +337,41 @@ 		, normalfinish tmp backend 		) 	normalfinish tmp backend = checkCanAdd o file $ \canadd -> do-		showDestinationFile (fromRawFilePath file)+		showDestinationFile file 		createWorkTreeDirectory (parentDir file) 		Just <$> finishDownloadWith canadd addunlockedmatcher tmp backend webUUID url file 	-- Ask youtube-dl what filename it will download first,  	-- so it's only used when the file contains embedded media. 	tryyoutubedl tmp backend = youtubeDlFileNameHtmlOnly url >>= \case-		Right mediafile -> +		Right mediafile -> do+			liftIO $ liftIO $ removeWhenExistsWith R.removeLink tmp 			let f = youtubeDlDestFile o file (toRawFilePath mediafile)-			in lookupKey f >>= \case-				Just k -> alreadyannexed (fromRawFilePath f) k+			lookupKey f >>= \case+				Just k -> alreadyannexed f k 				Nothing -> dl f-		Left err -> checkRaw (Just err) o Nothing (normalfinish tmp backend)+		Left err -> checkRaw (Just err) o (pure Nothing) (normalfinish tmp backend) 	  where 		dl dest = withTmpWorkDir mediakey $ \workdir -> do 			let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)-			showNote "using youtube-dl"+			dlcmd <- youtubeDlCommand+			showNote ("using " <> UnquotedString dlcmd) 			Transfer.notifyTransfer Transfer.Download url $-				Transfer.download' webUUID mediakey (AssociatedFile Nothing) Nothing Transfer.noRetry $ \p ->+				Transfer.download' webUUID mediakey (AssociatedFile Nothing) Nothing Transfer.noRetry $ \p -> do+					showDestinationFile dest 					youtubeDl url (fromRawFilePath workdir) p >>= \case 						Right (Just mediafile) -> do 							cleanuptmp 							checkCanAdd o dest $ \canadd -> do-								showDestinationFile (fromRawFilePath dest) 								addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile)) 								return $ Just mediakey-						Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend) 						Left msg -> do 							cleanuptmp-							warning msg+							warning (UnquotedString msg) 							return Nothing+						Right Nothing -> do+							cleanuptmp+							warning (UnquotedString dlcmd <> " did not download anything")+							return Nothing 		mediaurl = setDownloader url YoutubeDownloader 		mediakey = Backend.URL.fromUrl mediaurl Nothing 		-- Does the already annexed file have the mediaurl@@ -372,17 +381,17 @@ 			if mediaurl `elem` us 				then return (Just k) 				else do-					warning $ dest ++ " already exists; not overwriting"+					warning $ QuotedPath dest <> " already exists; not overwriting" 					return Nothing 	-checkRaw :: (Maybe String) -> DownloadOptions -> a -> Annex a -> Annex a+checkRaw :: (Maybe String) -> DownloadOptions -> Annex a -> Annex a -> Annex a checkRaw failreason o f a 	| noRawOption o = do-		warning $ "Unable to use youtube-dl or a special remote and --no-raw was specified" +++		warning $ UnquotedString $ "Unable to use youtube-dl or a special remote and --no-raw was specified" ++ 			case failreason of 				Just msg -> ": " ++ msg 				Nothing -> ""-		return f+		f 	| otherwise = a  {- The destination file is not known at start time unless the user provided@@ -402,13 +411,13 @@ 	-- available and get added to it. That's ok, this is only 	-- used to prevent two threads running concurrently when that would 	-- likely fail.-	ai = OnlyActionOn urlkey (ActionItemOther (Just url))+	ai = OnlyActionOn urlkey (ActionItemOther (Just (UnquotedString url))) 	urlkey = Backend.URL.fromUrl url Nothing -showDestinationFile :: FilePath -> Annex ()+showDestinationFile :: RawFilePath -> Annex () showDestinationFile file = do-	showNote ("to " ++ file)-	maybeShowJSON $ JSONChunk [("file", file)]+	showNote ("to " <> QuotedPath file)+	maybeShowJSON $ JSONChunk [("file", fromRawFilePath file)]  {- The Key should be a dummy key, based on the URL, which is used  - for this download, before we can examine the file and find its real key.@@ -500,9 +509,9 @@ 		then nomedia 		else youtubeDlFileName url >>= \case 			Right mediafile -> usemedia (toRawFilePath mediafile)-			Left err -> checkRaw (Just err) o Nothing nomedia+			Left err -> checkRaw (Just err) o (pure Nothing) nomedia 	| otherwise = do-		warning $ "unable to access url: " ++ url+		warning $ UnquotedString $ "unable to access url: " ++ url 		return Nothing   where 	nomedia = do@@ -521,7 +530,7 @@  nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> RawFilePath -> Annex (Maybe Key) nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do-	showDestinationFile (fromRawFilePath file)+	showDestinationFile file 	createWorkTreeDirectory (parentDir file) 	addWorkTree canadd addunlockedmatcher webUUID url file key Nothing 	return (Just key)@@ -560,11 +569,11 @@ checkCanAdd :: DownloadOptions -> RawFilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a) checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ R.getSymbolicLinkStatus file)) 	( do-		warning $ fromRawFilePath file ++ " already exists; not overwriting"+		warning $ QuotedPath file <> " already exists; not overwriting" 		return Nothing 	, ifM (checkIgnored (checkGitIgnoreOption o) file) 		( do-			warning $ "not adding " ++ fromRawFilePath file ++ " which is .gitignored (use --no-check-gitignore to override)"+			warning $ "not adding " <> QuotedPath file <> " which is .gitignored (use --no-check-gitignore to override)" 			return Nothing 		, a CanAddFile 		)
+ Command/Assist.hs view
@@ -0,0 +1,42 @@+{- git-annex command+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Command.Assist (cmd) where++import Command+import qualified Command.Sync+import qualified Command.Add+import Annex.CheckIgnore+import qualified Annex.Queue++cmd :: Command+cmd = withAnnexOptions [jobsOption, backendOption] $+	command "assist" SectionCommon +		"add files and sync changes with remotes"+		(paramRepeating paramRemote)+		(myseek <--< Command.Sync.optParser Command.Sync.AssistMode)++myseek :: Command.Sync.SyncOptions -> CommandSeek+myseek o = startConcurrency transferStages $ 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.+	Command.Sync.prepMerge++	Command.Add.seek Command.Add.AddOptions+		{ Command.Add.addThese = Command.Sync.contentOfOption o+		, Command.Add.batchOption = NoBatch+		, Command.Add.updateOnly = False+		, Command.Add.largeFilesOverride = Nothing+		, Command.Add.checkGitIgnoreOption = CheckGitIgnore True+		, Command.Add.dryRunOption = DryRun False+		}+	waitForAllRunningCommandActions+	-- Flush added files to index so they will be committed.+	Annex.Queue.flush++	Command.Sync.seek' o
Command/Assistant.hs view
@@ -24,7 +24,7 @@ cmd = dontCheck repoExists $ notBareRepo $ 	noRepo (startNoRepo <$$> optParser) $ 		command "assistant" SectionCommon-			"automatically sync changes"+			"daemon to add files and automatically sync changes" 			paramNothing (seek <$$> optParser)  data AssistantOptions = AssistantOptions@@ -130,8 +130,11 @@ 	program <- programPath 	forM_ dirs $ \d -> do 		putStrLn $ "git-annex autostop in " ++ d-		setCurrentDirectory d-		ifM (boolSystem program [Param "assistant", Param "--stop"])-			( putStrLn "ok"-			, putStrLn "failed"-			)+		tryIO (setCurrentDirectory d) >>= \case+			Right () -> ifM (boolSystem program [Param "assistant", Param "--stop"])+				( putStrLn "ok"+				, putStrLn "failed"+				)+			Left e -> do+				putStrLn (show e)+				putStrLn "failed"
Command/CalcKey.hs view
@@ -11,6 +11,8 @@ import Backend (genKey, defaultBackend) import Types.KeySource import Utility.Metered+import Utility.Terminal+import Utility.SafeOutput  cmd :: Command cmd = noCommit $ noMessages $ dontCheck repoExists $@@ -23,7 +25,9 @@ run :: () -> SeekInput -> String -> Annex Bool run _ _ file = tryNonAsync (genKey ks nullMeterUpdate =<< defaultBackend) >>= \case 	Right (k, _) -> do-		liftIO $ putStrLn $ serializeKey k+		IsTerminal isterminal <- liftIO $ checkIsTerminal stdout+		let sk = serializeKey k+		liftIO $ putStrLn $ if isterminal then safeOutput sk else sk 		return True 	Left _err -> return False   where
Command/CheckPresentKey.hs view
@@ -10,6 +10,7 @@ import Command import qualified Remote import Remote.List+import Utility.SafeOutput  cmd :: Command cmd = noCommit $ noMessages $@@ -68,7 +69,7 @@ exitResult Present = liftIO exitSuccess exitResult NotPresent = liftIO exitFailure exitResult (CheckFailure msg) = liftIO $ do-	hPutStrLn stderr msg+	hPutStrLn stderr (safeOutput msg) 	exitWith $ ExitFailure 100  batchResult :: Result -> Annex ()
Command/Config.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2017-2020 Joey Hess <id@joeyh.name>+ - Copyright 2017-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -13,7 +13,12 @@ import Logs.Config import Config import Types.GitConfig (globalConfigs)-import Git.Types (fromConfigValue)+import Git.Types (fromConfigValue, fromConfigKey)+import qualified Git.Command+import Utility.SafeOutput+import Annex.CheckAttr+import Types.NumCopies+import Logs.NumCopies  import qualified Data.ByteString.Char8 as S8 @@ -26,12 +31,13 @@ 	= SetConfig ConfigKey ConfigValue 	| GetConfig ConfigKey 	| UnsetConfig ConfigKey+	| ShowOrigin ConfigKey (Maybe FilePath)  type Name = String type Value = String  optParser :: CmdParamsDesc -> Parser Action-optParser _ = setconfig <|> getconfig <|> unsetconfig+optParser _ = setconfig <|> getconfig <|> unsetconfig <|> showorigin   where 	setconfig = SetConfig 		<$> strOption@@ -52,40 +58,158 @@ 		<> help "unset configuration" 		<> metavar paramName 		)+	showorigin = ShowOrigin+		<$> strOption+			( long "show-origin"+			<> help "explain where a value is configured"+			<> metavar paramName+			)+		<*> optional (strOption+			( long "for-file"+			<> help "filename to check for in gitattributes"+			<> metavar paramFile+			))  seek :: Action -> CommandSeek-seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ commandAction $-	startingUsualMessages (decodeBS name) ai si $ do-		setGlobalConfig ck val+seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ \setter _unsetter _getter ->+	commandAction $ startingUsualMessages (decodeBS name) ai si $ do+		setter val 		when (needLocalUpdate ck) $ 			setConfig ck (fromConfigValue val) 		next $ return True   where-	ai = ActionItemOther (Just (fromConfigValue val))+	ai = ActionItemOther (Just (UnquotedString (fromConfigValue val))) 	si = SeekInput [decodeBS name]-seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $-	startingUsualMessages (decodeBS name) ai si $ do-		unsetGlobalConfig ck+seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ \_setter unsetter _getter ->+	commandAction $ startingUsualMessages (decodeBS name) ai si $ do+		unsetter 		when (needLocalUpdate ck) $ 			unsetConfig ck 		next $ return True   where 	ai = ActionItemOther (Just "unset") 	si = SeekInput [decodeBS name]-seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $-	startingCustomOutput ai $ do-		getGlobalConfig ck >>= \case-			Just (ConfigValue v) -> liftIO $ S8.putStrLn v+seek (GetConfig ck) = checkIsGlobalConfig ck $ \_setter _unsetter getter ->+	commandAction $	startingCustomOutput ai $ do+		getter >>= \case+			Just (ConfigValue v) -> liftIO $ S8.putStrLn $ safeOutput v 			Just NoConfigValue -> return () 			Nothing -> return () 		next $ return True   where 	ai = ActionItemOther Nothing+seek (ShowOrigin ck@(ConfigKey name) forfile) = commandAction $+	startingCustomOutput ai $ next $ checknotconfigured $+		case checkIsGlobalConfig' ck of+			Just (_setter, _unsetter, getter) ->+				ifM gitconfigorigin+					( return True+					, checkattrs (checkconfigbranch getter)+					)+			Nothing -> ifM gitconfigorigin+				( return True+				, checkattrs checkgitconfigunderride+				)+  where+	ai = ActionItemOther Nothing -checkIsGlobalConfig :: ConfigKey -> Annex a -> Annex a-checkIsGlobalConfig ck@(ConfigKey name) a-	| elem ck globalConfigs = a-	| otherwise = giveup $ decodeBS name ++ " is not a configuration setting that can be stored in the git-annex branch"+	gitconfigorigin+		| name `elem` gitconfigdoesnotoverride = return False+		| otherwise = gitconfigorigin'+	gitconfigorigin' = inRepo $ Git.Command.runBool+			[ Param "config"+			, Param "--show-origin"+			, Param (decodeBS name)+			]+	+	-- git configs for these do not override values from git attributes+	-- or the branch+	gitconfigdoesnotoverride =+		[ "annex.numcopies"+		, "annex.mincopies"+		]++	-- the git config for annex.numcopies is a special case; it's only+	-- used if not configured anywhere else+	checkgitconfigunderride+		| name == "annex.numcopies" = gitconfigorigin'+		| otherwise = return False++	-- Display similar to git config --show-origin+	showval loc v = liftIO $ do+		putStrLn $ loc ++ "\t" ++ v+		return True+	+	configbranch v+		| needLocalUpdate ck = checkgitconfigunderride+		| otherwise = showval "branch:git-annex" (decodeBS v)+	+	checkconfigbranch getter = getter >>= \case+		Just (ConfigValue v) -> configbranch v+		_ -> checkgitconfigunderride+	+	checkattrs cont+		| decodeBS name `elem` annexAttrs =+			case forfile of+				Just file -> do+					v <- checkAttr (decodeBS name) (toRawFilePath file)+					if null v+						then cont+						else showval "gitattributes" v		+				Nothing -> do+					warnforfile+					cont+		| otherwise = cont+	+	warnforfile = warning $ UnquotedString $ configKeyMessage ck $ unwords+		[ "may be configured in gitattributes."+		, "Pass --for-file= with a filename to check"+		]+	+	checknotconfigured a = do+		ok <- a+		unless ok $+			warning $ UnquotedString $ configKeyMessage ck+				"is not configured"+		return ok++type Setter = ConfigValue -> Annex ()+type Unsetter = Annex ()+type Getter = Annex (Maybe ConfigValue)++checkIsGlobalConfig :: ConfigKey -> (Setter -> Unsetter -> Getter -> Annex a) -> Annex a+checkIsGlobalConfig ck a = case checkIsGlobalConfig' ck of+	Just (setter, unsetter, getter) -> a setter unsetter getter+	Nothing -> giveup $ configKeyMessage ck "is not a configuration setting that can be stored in the git-annex branch"++checkIsGlobalConfig' :: ConfigKey -> Maybe (Setter, Unsetter, Getter)+checkIsGlobalConfig' ck+	| elem ck globalConfigs = Just+		( setGlobalConfig ck+		, unsetGlobalConfig ck+		, getGlobalConfig ck+		)+	-- These came before this command, but are also global configs,+	-- so support them here as well.+	| ck == ConfigKey "annex.numcopies" = Just+		( mksetter (setGlobalNumCopies . configuredNumCopies)+		, error "unsetting annex.numcopies is not supported"+		, mkgetter fromNumCopies getGlobalNumCopies+		)+	| ck == ConfigKey "annex.mincopies" = Just+		( mksetter (setGlobalMinCopies . configuredMinCopies)+		, error "unsetting annex.mincopies is not supported"+		, mkgetter fromMinCopies getGlobalMinCopies+		)+	| otherwise = Nothing+  where+	mksetter f = +		maybe (error ("invalid value for " ++ fromConfigKey ck)) f +			. readish . decodeBS . fromConfigValue+	mkgetter f g = fmap (ConfigValue . encodeBS . show . f) <$> g++configKeyMessage :: ConfigKey -> String -> String+configKeyMessage (ConfigKey name) msg = decodeBS name ++ " " ++ msg  needLocalUpdate :: ConfigKey -> Bool needLocalUpdate (ConfigKey "annex.securehashesonly") = True
+ Command/ConfigRemote.hs view
@@ -0,0 +1,64 @@+{- git-annex command+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Command.ConfigRemote where++import Command+import qualified Logs.Remote+import qualified Git.Types as Git+import qualified Annex.SpecialRemote as SpecialRemote+import qualified Types.Remote as Remote+import Types.ProposedAccepted+import Command.EnableRemote (unknownNameError, startSpecialRemote', PerformSpecialRemote, deadLast)++import qualified Data.Map as M++cmd :: Command+cmd = withAnnexOptions [jsonOptions] $+	command "configremote" SectionSetup+		"changes special remote configuration"+		(paramPair paramName $ paramOptional $ paramRepeating paramParamValue)+		(withParams seek)++seek :: CmdParams -> CommandSeek+seek = withWords (commandAction . start)++start :: [String] -> CommandStart+start [] = unknownNameError "Specify the remote to configure."+start (name:inputconfig) = deadLast name $+	startSpecialRemote (checkSafeConfig inputconfig) name+		(Logs.Remote.keyValToConfig Proposed inputconfig)++{- Since this command stores config without calling the remote's setup+ - method to validate it, it can only be used on fields that are known to+ - be safe to change in all remotes. -}+checkSafeConfig :: [String] -> Annex ()+checkSafeConfig cs = do+	let rc = Logs.Remote.keyValToConfig Proposed cs+	forM_ (M.keys rc) $ \k ->+		when (fromProposedAccepted k `notElem` safefields) $+			giveup $ "Cannot change field \"" ++ fromProposedAccepted k  ++ "\" with this command. Use git-annex enableremote instead."+	case SpecialRemote.parseRemoteConfig rc (Remote.RemoteConfigParser ps Nothing) of+		Left err -> giveup err+		Right _ -> return ()+  where+	ps = [ SpecialRemote.autoEnableFieldParser ]+	safefields = [ fromProposedAccepted SpecialRemote.autoEnableField ]++startSpecialRemote :: Annex () -> Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart+startSpecialRemote = startSpecialRemote' "configremote" . performSpecialRemote++performSpecialRemote :: Annex () -> PerformSpecialRemote+performSpecialRemote precheck _ u _ c _ mcu = do+	precheck+	case mcu of+		Nothing -> Logs.Remote.configSet u c+		Just (SpecialRemote.ConfigFrom cu) ->+			Logs.Remote.configSet cu c+	next $ return True
Command/Copy.hs view
@@ -60,7 +60,7 @@ 		Batch fmt -> batchOnly (keyOptions o) (copyFiles o) $ 			batchAnnexed fmt seeker keyaction   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "copy" 	 	seeker = AnnexedFileSeeker 		{ startAction = start o fto
Command/Dead.hs view
@@ -15,8 +15,9 @@ import Git.Types  cmd :: Command-cmd = command "dead" SectionSetup "hide a lost repository or key"-	(paramRepeating paramRepository) (seek <$$> optParser)+cmd = withAnnexOptions [jsonOptions] $+	command "dead" SectionSetup "hide a lost repository or key"+		(paramRepeating paramRepository) (seek <$$> optParser)  data DeadOptions = DeadRemotes [RemoteName] | DeadKeys [Key]
Command/Describe.hs view
@@ -23,10 +23,10 @@ start :: [String] -> CommandStart start (name:description) | not (null description) = do 	u <- Remote.nameToUUID name+	let ai = ActionItemUUID u (UnquotedString name) 	starting "describe" ai si $ 		perform u $ unwords description   where-	ai = ActionItemOther (Just name) 	si = SeekInput [name] start _ = giveup "Specify a repository and a description."
Command/Drop.hs view
@@ -74,7 +74,7 @@ 		Batch fmt -> batchOnly (keyOptions o) (dropFiles o) $ 			batchAnnexed fmt seeker (startKeys o from)   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "drop"  start :: DropOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart start o from si file key = start' o from key afile ai si@@ -233,10 +233,10 @@ 			if afile == afile' 				then showLongNote "That file is required content. It cannot be dropped!" 				else showLongNote $ "That file has the same content as another file"-					++ case afile' of-						AssociatedFile (Just f) -> " (" ++ fromRawFilePath f ++ "),"+					<> case afile' of+						AssociatedFile (Just f) -> " (" <> QuotedPath f <> ")," 						AssociatedFile Nothing -> ""-					++ " which is required content. It cannot be dropped!"+					<> " which is required content. It cannot be dropped!" 			showLongNote "(Use --force to override this check, or adjust required content configuration.)" 			return False
Command/DropUnused.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.DropUnused where  import Command@@ -18,9 +20,10 @@ import qualified Utility.RawFilePath as R  cmd :: Command-cmd = command "dropunused" SectionMaintenance-	"drop unused file content"-	(paramRepeating paramNumRange) (seek <$$> optParser)+cmd = withAnnexOptions [jsonOptions] $+	command "dropunused" SectionMaintenance+		"drop unused file content"+		(paramRepeating paramNumRange) (seek <$$> optParser)  data DropUnusedOptions = DropUnusedOptions 	{ rangesToDrop :: CmdParams@@ -40,15 +43,20 @@ 	withUnusedMaps (start from numcopies mincopies) (rangesToDrop o)  start :: Maybe Remote -> NumCopies -> MinCopies -> UnusedMaps -> Int -> CommandStart-start from numcopies mincopies = startUnused "dropunused"-	(perform from numcopies mincopies)-	(performOther gitAnnexBadLocation)-	(performOther gitAnnexTmpObjectLocation)+start from numcopies mincopies = startUnused+	(go (perform from numcopies mincopies))+	(go (performOther gitAnnexBadLocation))+	(go (performOther gitAnnexTmpObjectLocation))+  where+	go a n key = starting "dropunused" +		(ActionItemOther $ Just $ UnquotedString $ show n)+		(SeekInput [show n])+		(a key)  perform :: Maybe Remote -> NumCopies -> MinCopies -> Key -> CommandPerform perform from numcopies mincopies key = case from of 	Just r -> do-		showAction $ "from " ++ Remote.name r+		showAction $ UnquotedString $ "from " ++ Remote.name r 		Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r ud 	Nothing -> ifM (inAnnex key) 		( droplocal
Command/EnableRemote.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2013-2020 Joey Hess <id@joeyh.name>+ - Copyright 2013-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -30,10 +30,11 @@ import qualified Data.Map as M  cmd :: Command-cmd = command "enableremote" SectionSetup-	"enables git-annex to use a remote"-	(paramPair paramName $ paramOptional $ paramRepeating paramParamValue)-	(withParams seek)+cmd = withAnnexOptions [jsonOptions] $+	command "enableremote" SectionSetup+		"enables git-annex to use a remote"+		(paramPair paramName $ paramOptional $ paramRepeating paramParamValue)+		(withParams seek)  seek :: CmdParams -> CommandSeek seek = withWords (commandAction . start)@@ -43,61 +44,60 @@ start (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes   where 	matchingname r = Git.remoteName r == Just name-	go [] = -		let use = startSpecialRemote name (Logs.Remote.keyValToConfig Proposed rest)-		in SpecialRemote.findExisting' name >>= \case-			-- enable dead remote only when there is no-			-- other remote with the same name-			([], l) -> use l-			(l, _) -> use l-	go (r:_) = do-		-- This could be either a normal git remote or a special-		-- remote that has an url (eg gcrypt).-		rs <- Remote.remoteList-		case filter (\rmt -> Remote.name rmt == name) rs of-			(rmt:_) | Remote.remotetype rmt == Remote.Git.remote ->-				startNormalRemote name rest r-			_  -> go []+	go [] = deadLast name $ +		startSpecialRemote name (Logs.Remote.keyValToConfig Proposed rest)+	go (r:_)+		| not (null rest) = go []+		| otherwise = do+			-- This could be either a normal git remote or a special+			-- remote that has an url (eg gcrypt).+			rs <- Remote.remoteList+			case filter (\rmt -> Remote.name rmt == name) rs of+				(rmt:_) | Remote.remotetype rmt == Remote.Git.remote ->+					startNormalRemote name r+				_  -> go [] --- Normal git remotes are special-cased; enableremote retries probing--- the remote uuid.-startNormalRemote :: Git.RemoteName -> [String] -> Git.Repo -> CommandStart-startNormalRemote name restparams r-	| null restparams = starting "enableremote" ai si $ do-		setRemoteIgnore r False-		r' <- Remote.Git.configRead False r-		u <- getRepoUUID r'-		next $ return $ u /= NoUUID-	| otherwise = giveup $-		"That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams+-- enableremote of a normal git remote with no added parameters is a special case+-- that retries probing the remote uuid.+startNormalRemote :: Git.RemoteName -> Git.Repo -> CommandStart+startNormalRemote name r = starting "enableremote (normal)" ai si $ do+	setRemoteIgnore r False+	r' <- Remote.Git.configRead False r+	u <- getRepoUUID r'+	next $ return $ u /= NoUUID   where-	ai = ActionItemOther (Just name)+	ai = ActionItemOther (Just (UnquotedString name)) 	si = SeekInput [name]  startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart-startSpecialRemote name config [] = do+startSpecialRemote = startSpecialRemote' "enableremote" performSpecialRemote++type PerformSpecialRemote = RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform++startSpecialRemote' :: String -> PerformSpecialRemote -> Git.RemoteName -> Remote.RemoteConfig -> [(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> CommandStart+startSpecialRemote' cname perform name config [] = do 	m <- SpecialRemote.specialRemoteMap 	confm <- Logs.Remote.remoteConfigMap 	Remote.nameToUUID' name >>= \case 		([u], _) | u `M.member` m ->-			startSpecialRemote name config $+			startSpecialRemote' cname perform name config $ 				[(u, fromMaybe M.empty (M.lookup u confm), Nothing)] 		(_, msg) -> unknownNameError msg-startSpecialRemote name config ((u, c, mcu):[]) =-	starting "enableremote" ai si $ do+startSpecialRemote' cname perform name config ((u, c, mcu):[]) =+	starting cname ai si $ do 		let fullconfig = config `M.union` c	 		t <- either giveup return (SpecialRemote.findType fullconfig) 		gc <- maybe (liftIO dummyRemoteGitConfig)  			(return . Remote.gitconfig) 			=<< Remote.byUUID u-		performSpecialRemote t u c fullconfig gc mcu+		perform t u c fullconfig gc mcu   where-	ai = ActionItemOther (Just name)+	ai = ActionItemOther (Just (UnquotedString name)) 	si = SeekInput [name]-startSpecialRemote _ _ _ =-	giveup "Multiple remotes have that name. Either use git-annex renameremote to rename them, or specify the uuid of the remote to enable."+startSpecialRemote' _ _ _ _ _ =+	giveup "Multiple remotes have that name. Either use git-annex renameremote to rename them, or specify the uuid of the remote." -performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform+performSpecialRemote :: PerformSpecialRemote performSpecialRemote t u oldc c gc mcu = do 	(c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc 	next $ cleanupSpecialRemote t u' c' mcu@@ -105,8 +105,7 @@ cleanupSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandCleanup cleanupSpecialRemote t u c mcu = do 	case mcu of-		Nothing -> -			Logs.Remote.configSet u c+		Nothing -> Logs.Remote.configSet u c 		Just (SpecialRemote.ConfigFrom cu) -> do 			setConfig (remoteAnnexConfig c "config-uuid") (fromUUID cu) 			Logs.Remote.configSet cu c@@ -140,3 +139,11 @@ 		, liftIO . getDynamicConfig . remoteAnnexIgnore 			=<< Annex.getRemoteGitConfig r 		]++-- Use dead remote only when there is no other remote+-- with the same name+deadLast :: Git.RemoteName -> ([(UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID))] -> Annex a) -> Annex a+deadLast name use =+	SpecialRemote.findExisting' name >>= \case+		([], l) -> use l+		(l, _) -> use l
Command/EnableTor.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings, CPP #-}  module Command.EnableTor where @@ -61,7 +61,7 @@ 			let ps = [Param (cmdname cmd), Param (show curruserid)] 			sucommand <- liftIO $ mkSuCommand gitannex ps 			cleanenv <- liftIO $ cleanStandaloneEnvironment-			maybe noop showLongNote+			maybe noop (showLongNote . UnquotedString) 				(describePasswordPrompt' sucommand) 			ifM (liftIO $ runSuCommand sucommand cleanenv) 				( next checkHiddenService@@ -111,7 +111,7 @@ 		-- we just want to know if the tor circuit works. 		liftIO (tryNonAsync $ connectPeer g addr) >>= \case 			Left e -> do-				warning $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.."+				warning $ UnquotedString $ "Unable to connect to hidden service. It may not yet have propigated to the Tor network. (" ++ show e ++ ") Will retry.." 				liftIO $ threadDelaySeconds (Seconds 2) 				check (n-1) addrs 			Right conn -> do
Command/ExamineKey.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.ExamineKey where  import Command@@ -14,6 +16,7 @@ import Backend import Types.Backend import Types.Key+import Utility.Terminal  import Data.Char import qualified Data.ByteString as B@@ -54,7 +57,8 @@ 	 	objectpath <- calcRepo $ gitAnnexLocation k 	let objectpointer = formatPointer k-	showFormatted (format o) (serializeKey' k) $+	isterminal <- liftIO $ checkIsTerminal stdout+	showFormatted isterminal (format o) (serializeKey' k) $ 		[ ("objectpath", fromRawFilePath objectpath) 		, ("objectpointer", fromRawFilePath objectpointer) 		] ++ formatVars k af
Command/Expire.hs view
@@ -22,9 +22,10 @@ import qualified Data.Map as M  cmd :: Command-cmd = command "expire" SectionMaintenance-	"expire inactive repositories"-	paramExpire (seek <$$> optParser)+cmd = withAnnexOptions [jsonOptions] $+	command "expire" SectionMaintenance+		"expire inactive repositories"+		paramExpire (seek <$$> optParser)  paramExpire :: String paramExpire = (paramRepeating $ paramOptional paramRemote ++ ":" ++ paramTime)@@ -61,13 +62,13 @@ 	case lastact of 		Just ent | notexpired ent -> checktrust (== DeadTrusted) $ 			starting "unexpire" ai si $ do-				showNote =<< whenactive+				showNote . UnquotedString =<< whenactive 				unless noact $ 					trustSet u SemiTrusted 				next $ return True 		_ -> checktrust (/= DeadTrusted) $ 			starting "expire" ai si $ do-				showNote =<< whenactive+				showNote . UnquotedString =<< whenactive 				unless noact $ 					trustSet u DeadTrusted 				next $ return True@@ -79,7 +80,7 @@ 			return $ "last active: " ++ fromDuration d ++ " ago" 		_  -> return "no activity" 	desc = fromUUID u ++ " " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs))-	ai = ActionItemOther (Just desc)+	ai = ActionItemUUID u (UnquotedString desc) 	si = SeekInput [] 	notexpired ent = case ent of 		Unknown -> False
Command/Export.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2017-2019 Joey Hess <id@joeyh.name>+ - Copyright 2017-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -413,13 +413,15 @@ 	loc = mkExportLocation f' 	f' = getTopFilePath f 	tmploc = exportTempName ek-	ai = ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc)+	ai = ActionItemOther $ Just $ +		QuotedPath f' <> " -> " <> QuotedPath (fromExportLocation tmploc) 	si = SeekInput []  startMoveFromTempName :: Remote -> ExportHandle -> Key -> TopFilePath -> CommandStart startMoveFromTempName r db ek f = do 	let tmploc = exportTempName ek-	let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))+	let ai = ActionItemOther $ Just $+		QuotedPath (fromExportLocation tmploc) <> " -> " <> QuotedPath f' 	stopUnless (liftIO $ elem tmploc <$> getExportedLocation db ek) $ 		starting ("rename " ++ name r) ai si $ 			performRename r db ek tmploc loc@@ -433,7 +435,7 @@ 	tryNonAsync (renameExport (exportActions r) ek src dest) >>= \case 		Right (Just ()) -> next $ cleanupRename r db ek src dest 		Left err -> do-			warning $ "rename failed (" ++ show err ++ "); deleting instead"+			warning $ UnquotedString $ "rename failed (" ++ show err ++ "); deleting instead" 			fallbackdelete 		-- remote does not support renaming 		Right Nothing -> fallbackdelete
Command/FilterBranch.hs view
@@ -192,4 +192,4 @@ 	c <- inRepo $ Git.commitTree cmode cmessage [] t 	liftIO $ putStrLn (fromRef c)   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "filter-branch"
Command/Find.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -19,6 +19,7 @@ import Git.FilePath import qualified Utility.Format import Utility.DataUnits+import Utility.Terminal  cmd :: Command cmd = withAnnexOptions [annexedMatchingOptions] $ mkCommand $@@ -60,20 +61,21 @@ seek o = do 	unless (isJust (keyOptions o)) $ 		checkNotBareRepo+	isterminal <- liftIO $ checkIsTerminal stdout 	seeker <- contentPresentUnlessLimited $ AnnexedFileSeeker-		{ startAction = start o+		{ startAction = start o isterminal 		, checkContentPresent = Nothing 		, usesLocationLog = False 		} 	case batchOption o of 		NoBatch -> withKeyOptions (keyOptions o) False seeker-			(commandAction . startKeys o)+			(commandAction . startKeys o isterminal) 			(withFilesInGitAnnex ww seeker) 			=<< workTreeItems ww (findThese o) 		Batch fmt -> batchOnly (keyOptions o) (findThese o) $ 			batchAnnexedFiles fmt seeker   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "find"  -- Default to needing content to be present, but if the user specified a -- limit, content does not need to be present.@@ -86,22 +88,25 @@ 			else Just True 		} -start :: FindOptions -> SeekInput -> RawFilePath -> Key -> CommandStart-start o _ file key = startingCustomOutput key $ do-	showFormatted (formatOption o) file +start :: FindOptions -> IsTerminal -> SeekInput -> RawFilePath -> Key -> CommandStart+start o isterminal _ file key = startingCustomOutput key $ do+	showFormatted isterminal (formatOption o) file 		(formatVars key (AssociatedFile (Just file))) 	next $ return True -startKeys :: FindOptions -> (SeekInput, Key, ActionItem) -> CommandStart-startKeys o (si, key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = -	start o si (getTopFilePath topf) key-startKeys _ _ = stop+startKeys :: FindOptions -> IsTerminal -> (SeekInput, Key, ActionItem) -> CommandStart+startKeys o isterminal (si, key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = +	start o isterminal si (getTopFilePath topf) key+startKeys _ _ _ = stop -showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex ()-showFormatted format unformatted vars =+showFormatted :: IsTerminal -> Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex ()+showFormatted (IsTerminal isterminal) format unformatted vars = 	unlessM (showFullJSON $ JSONChunk vars) $ 		case format of-			Nothing -> liftIO $ S8.putStrLn unformatted+			Nothing -> do+				liftIO $ S8.putStrLn $ if isterminal+					then Utility.Format.encode_c (const False) unformatted+					else unformatted 			Just formatter -> liftIO $ putStr $ 				Utility.Format.format formatter $ 					M.fromList vars
Command/FindKeys.hs view
@@ -8,8 +8,9 @@ module Command.FindKeys where  import Command-import qualified Utility.Format import qualified Command.Find+import qualified Utility.Format+import Utility.Terminal  cmd :: Command cmd = withAnnexOptions [keyMatchingOptions] $ Command.Find.mkCommand $@@ -26,22 +27,23 @@  seek :: FindKeysOptions -> CommandSeek seek o = do+	isterminal <- liftIO $ checkIsTerminal stdout 	seeker <- Command.Find.contentPresentUnlessLimited $ AnnexedFileSeeker 		{ checkContentPresent = Nothing 		, usesLocationLog = False 		-- startAction is not actually used since this 		-- is not used to seek files-		, startAction = \_ _ key -> start' o key+		, startAction = \_ _ key -> start' o isterminal key 		} 	withKeyOptions (Just WantAllKeys) False seeker-		(commandAction . start o)+		(commandAction . start o isterminal) 		(const noop) (WorkTreeItems []) -start :: FindKeysOptions -> (SeekInput, Key, ActionItem) -> CommandStart-start o (_si, key, _ai) = start' o key+start :: FindKeysOptions -> IsTerminal -> (SeekInput, Key, ActionItem) -> CommandStart+start o isterminal (_si, key, _ai) = start' o isterminal key -start' :: FindKeysOptions -> Key -> CommandStart-start' o key = startingCustomOutput key $ do-	Command.Find.showFormatted (formatOption o) (serializeKey' key)+start' :: FindKeysOptions -> IsTerminal -> Key -> CommandStart+start' o isterminal key = startingCustomOutput key $ do+	Command.Find.showFormatted isterminal (formatOption o) (serializeKey' key) 		(Command.Find.formatVars key (AssociatedFile Nothing)) 	next $ return True
Command/Fix.hs view
@@ -26,7 +26,7 @@ #endif  cmd :: Command-cmd = noCommit $ withAnnexOptions [annexedMatchingOptions] $+cmd = noCommit $ withAnnexOptions [annexedMatchingOptions, jsonOptions] $ 	command "fix" SectionMaintenance 		"fix up links to annexed content" 		paramPaths (withParams seek)@@ -35,7 +35,7 @@ seek ps = unlessM crippledFileSystem $ 	withFilesInGitAnnex ww seeker =<< workTreeItems ww ps   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "fix" 	seeker = AnnexedFileSeeker 		{ startAction = start FixAll 		, checkContentPresent = Nothing@@ -76,7 +76,7 @@ 		let tmp' = toRawFilePath tmp 		mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file 		unlessM (checkedCopyFile key obj tmp' mode) $-			error "unable to break hard link"+			giveup "unable to break hard link" 		thawContent tmp' 		Database.Keys.storeInodeCaches key [tmp'] 		modifyContentDir obj $ freezeContent obj@@ -87,7 +87,7 @@ 	replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do 		mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file 		linkFromAnnex' key (toRawFilePath tmp) mode >>= \case-			LinkAnnexFailed -> error "unable to make hard link"+			LinkAnnexFailed -> giveup "unable to make hard link" 			_ -> noop 	next $ return True
Command/Forget.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Forget where  import Command@@ -42,7 +44,7 @@ 		else basets 	perform ts =<< Annex.getRead Annex.force   where-	ai = ActionItemOther (Just (fromRef Branch.name))+	ai = ActionItemOther (Just (UnquotedString (fromRef Branch.name))) 	si = SeekInput []  perform :: Transitions -> Bool -> CommandPerform
Command/FromKey.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.FromKey where  import Command@@ -130,7 +132,7 @@ 		| otherwise -> hasothercontent   where 	hasothercontent = do-		warning $ fromRawFilePath file ++ " already exists with different content"+		warning $ QuotedPath file <> " already exists with different content" 		next $ return False 	 	linkunlocked = linkFromAnnex key file Nothing >>= \case
Command/Fsck.hs view
@@ -42,7 +42,6 @@ import qualified Database.Fsck as FsckDb import Types.CleanupActions import Types.Key-import Types.ActionItem import qualified Utility.RawFilePath as R  import Data.Time.Clock.POSIX@@ -114,7 +113,7 @@ 	cleanupIncremental i 	void $ tryIO $ recordActivity Fsck u   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "fsck"  checkDeadRepo :: UUID -> Annex () checkDeadRepo u =@@ -160,14 +159,15 @@ 	dispatch =<< Remote.hasKey remote key   where 	dispatch (Left err) = do-		showNote err+		showNote (UnquotedString err) 		return False 	dispatch (Right True) = withtmp $ \tmpfile -> 		getfile tmpfile >>= \case 			Nothing -> go True Nothing 			Just (Right verification) -> go True (Just (tmpfile, verification)) 			Just (Left _) -> do-				warning (decodeBS (actionItemDesc ai) ++ ": failed to download file from remote")+				warning $ actionItemDesc ai+					<> ": failed to download file from remote" 				void $ go True Nothing 				return False 	dispatch (Right False) = go False Nothing@@ -320,7 +320,7 @@ 			KeyLockedThin -> thawContent obj 			_ -> freezeContent obj 		checkContentWritePerm obj >>= \case-			Nothing -> warning $ "** Unable to set correct write mode for " ++ fromRawFilePath obj ++ " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set"+			Nothing -> warning $ "** Unable to set correct write mode for " <> QuotedPath obj <> " ; perhaps you don't own that file, or perhaps it has an xattr or ACL set" 			_ -> return () 	whenM (liftIO $ R.doesPathExist $ parentDir obj) $ 		freezeContentDir obj@@ -331,7 +331,7 @@ 	 - config was set. -} 	whenM (pure present <&&> (not <$> Backend.isCryptographicallySecure key)) $ 		whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $-			warning $ "** Despite annex.securehashesonly being set, " ++ fromRawFilePath obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key"+			warning $ "** Despite annex.securehashesonly being set, " <> QuotedPath obj <> " has content present in the annex using an insecure " <> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key))) <> " key"  	verifyLocationLog' key ai present u (logChange key u) @@ -351,9 +351,9 @@ 		(False, True) -> do 			fix InfoMissing 			warning $-				"** Based on the location log, " ++-				decodeBS (actionItemDesc ai) ++-				"\n** was expected to be present, " +++				"** Based on the location log, " <>+				actionItemDesc ai <>+				"\n** was expected to be present, " <> 				"but its content is missing." 			return False 		(False, False) -> do@@ -391,10 +391,10 @@ 			else do 				missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs 				warning $-					"** Required content " ++-					decodeBS (actionItemDesc ai) ++-					" is missing from these repositories:\n" ++-					missingrequired+					"** Required content " <>+					actionItemDesc ai <>+					" is missing from these repositories:\n" <>+					UnquotedString missingrequired 				return False verifyRequiredContent _ _ = return True @@ -465,13 +465,11 @@ 		return same 	badsize a b = do 		msg <- bad key-		warning $ concat-			[ decodeBS (actionItemDesc ai)-			, ": Bad file size ("-			, compareSizes storageUnits True a b-			, "); "-			, msg-			]+		warning $ actionItemDesc ai+			<> ": Bad file size ("+			<> UnquotedString (compareSizes storageUnits True a b)+			<> "); "+			<> UnquotedString msg  {- Check for keys that are upgradable.  -@@ -483,13 +481,12 @@ checkKeyUpgrade backend key ai (AssociatedFile (Just file)) = 	case Types.Backend.canUpgradeKey backend of 		Just a | a key -> do-			warning $ concat-				[ decodeBS (actionItemDesc ai)-				, ": Can be upgraded to an improved key format. "-				, "You can do so by running: git annex migrate --backend="-				, decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " "-				, decodeBS file-				]+			warning $ actionItemDesc ai+				<> ": Can be upgraded to an improved key format. "+				<> "You can do so by running: git annex migrate --backend="+				<> UnquotedByteString (formatKeyVariety (fromKey keyVariety key))+				<> " "+				<> QuotedPath file 			return True 		_ -> return True checkKeyUpgrade _ _ _ (AssociatedFile Nothing) =@@ -534,11 +531,9 @@ 			ok <- verifier key file 			unless ok $ do 				msg <- bad key-				warning $ concat-					[ decodeBS (actionItemDesc ai)-					, ": Bad file content; "-					, msg-					]+				warning $ actionItemDesc ai+					<> ": Bad file content; "+					<> UnquotedString msg 			return ok 		Nothing -> return True @@ -562,17 +557,15 @@ 				withTSDelta (liftIO . genInodeCache content) >>= \case 					Nothing -> noop 					Just ic' -> whenM (compareInodeCaches ic ic') $ do-						warning $ concat-							[ decodeBS (actionItemDesc ai)-							, ": Stale or missing inode cache; updating."-							]+						warning $ actionItemDesc ai+							<> ": Stale or missing inode cache; updating." 						Database.Keys.addInodeCaches key [ic]  checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool checkKeyNumCopies key afile numcopies = do 	let (desc, hasafile) = case afile of-		AssociatedFile Nothing -> (serializeKey key, False)-		AssociatedFile (Just af) -> (fromRawFilePath af, True)+		AssociatedFile Nothing -> (serializeKey' key, False)+		AssociatedFile (Just af) -> (af, True) 	locs <- loggedLocations key 	(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs 	(deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations@@ -592,21 +585,21 @@ 			) 		else return True -missingNote :: String -> Int -> NumCopies -> String -> String -> String+missingNote :: RawFilePath -> Int -> NumCopies -> String -> String -> StringContainingQuotedPath missingNote file 0 _ [] dead = -		"** No known copies exist of " ++ file ++ honorDead dead+		"** No known copies exist of " <> QuotedPath file <> UnquotedString (honorDead dead) missingNote file 0 _ untrusted dead =-		"Only these untrusted locations may have copies of " ++ file ++-		"\n" ++ untrusted ++-		"Back it up to trusted locations with git-annex copy." ++ honorDead dead+		"Only these untrusted locations may have copies of " <> QuotedPath file <>+		"\n" <> UnquotedString untrusted <>+		"Back it up to trusted locations with git-annex copy." <> UnquotedString (honorDead dead) missingNote file present needed [] _ =-		"Only " ++ show present ++ " of " ++ show (fromNumCopies needed) ++ -		" trustworthy copies exist of " ++ file +++		"Only " <> UnquotedString (show present) <> " of " <> UnquotedString (show (fromNumCopies needed)) <>+		" trustworthy copies exist of " <> QuotedPath file <> 		"\nBack it up with git-annex copy." missingNote file present needed untrusted dead = -		missingNote file present needed [] dead ++-		"\nThe following untrusted locations may also have copies: " ++-		"\n" ++ untrusted+		missingNote file present needed [] dead <>+		"\nThe following untrusted locations may also have copies: " <>+		"\n" <> UnquotedString untrusted 	 honorDead :: String -> String honorDead dead
Command/FuzzTest.hs view
@@ -37,7 +37,7 @@ start = do 	guardTest 	logf <- fromRepo gitAnnexFuzzTestLogFile-	showStart "fuzztest" (toRawFilePath logf) (SeekInput [])+	showStartMessage (StartMessage "fuzztest" (ActionItemOther (Just (UnquotedString logf))) (SeekInput [])) 	logh <- liftIO $ openFile logf WriteMode 	void $ forever $ fuzz logh 	stop
Command/Get.hs view
@@ -53,7 +53,7 @@ 		Batch fmt -> batchOnly (keyOptions o) (getFiles o) $ 			batchAnnexed fmt seeker (startKeys from)   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "get"  start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart start o from si file key = start' expensivecheck from key afile ai si@@ -93,7 +93,7 @@ getKey' key afile = dispatch   where 	dispatch [] = do-		showNote "not available"+		showNote (UnquotedString "not available") 		showlocs [] 		return False 	dispatch remotes = notifyTransfer Download afile $ \witness -> do@@ -116,6 +116,6 @@ 			either (const False) id <$> Remote.hasKey r key 		| otherwise = return True 	docopy r witness = do-		showAction $ "from " ++ Remote.name r+		showAction $ UnquotedString $ "from " ++ Remote.name r 		logStatusAfter key $ 			download r key afile stdRetry witness
Command/Group.hs view
@@ -11,6 +11,7 @@ import qualified Remote import Logs.Group import Types.Group+import Utility.SafeOutput  import qualified Data.Set as S @@ -27,12 +28,12 @@ 	startingUsualMessages "group" ai si $ 		setGroup u (toGroup g)   where-	ai = ActionItemOther (Just name)+	ai = ActionItemOther (Just (UnquotedString name)) 	si = SeekInput ps start (name:[]) = do 	u <- Remote.nameToUUID name 	startingCustomOutput (ActionItemOther Nothing) $ do-		liftIO . putStrLn . unwords . map fmt . S.toList+		liftIO . putStrLn . safeOutput . unwords . map fmt . S.toList 			=<< lookupGroups u 		next $ return True   where
Command/GroupWanted.hs view
@@ -27,6 +27,6 @@ start ps@(g:expr:[]) = startingUsualMessages "groupwanted" ai si $ 	performSet groupPreferredContentSet expr (toGroup g)   where-	ai = ActionItemOther (Just g)+	ai = ActionItemOther (Just (UnquotedString g)) 	si = SeekInput ps start _ = giveup "Specify a group."
Command/Import.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE ApplicativeDo, OverloadedStrings #-}  module Command.Import where @@ -125,7 +125,10 @@ 	inrepops <- liftIO $ filter (dirContains repopath) 		<$> mapM (absPath . toRawFilePath) (importFiles o) 	unless (null inrepops) $ do-		giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords (map fromRawFilePath inrepops)+		qp <- coreQuotePath <$> Annex.getGitConfig+		giveup $ decodeBS $ quote qp $ +			"cannot import files from inside the working tree (use git annex add instead): "+				<> quotedPaths inrepops 	largematcher <- largeFilesMatcher 	addunlockedmatcher <- addUnlockedMatcher 	(commandAction . startLocal o addunlockedmatcher largematcher (duplicateMode o))@@ -151,7 +154,7 @@ 	si = SeekInput []  	deletedup k = do-		showNote $ "duplicate of " ++ serializeKey k+		showNote $ UnquotedString $ "duplicate of " ++ serializeKey k 		verifyExisting k destfile 			( do 				liftIO $ R.removeLink srcfile@@ -167,7 +170,7 @@ 		ignored <- checkIgnored (checkGitIgnoreOption o) destfile 		if ignored 			then do-				warning $ "not importing " ++ fromRawFilePath destfile ++ " which is .gitignored (use --no-check-gitignore to override)"+				warning $ "not importing " <> QuotedPath destfile <> " which is .gitignored (use --no-check-gitignore to override)" 				stop 			else do 				existing <- liftIO (catchMaybeIO $ R.getSymbolicLinkStatus destfile)@@ -195,7 +198,7 @@ 			Just s 				| isDirectory s -> cont 				| otherwise -> do-					warning $ "not importing " ++ fromRawFilePath destfile ++ " because " ++ fromRawFilePath destdir ++ " is not a directory"+					warning $ "not importing " <> QuotedPath destfile <> " because " <> QuotedPath destdir <> " is not a directory" 					stop  	importfilechecked ld k = do@@ -221,7 +224,8 @@ 			checkLockedDownWritePerms destfile srcfile >>= \case 				Just err -> do 					liftIO unwind-					giveup err+					qp <- coreQuotePath <$> Annex.getGitConfig+					giveup (decodeBS $ quote qp err) 				Nothing -> noop 		-- Get the inode cache of the dest file. It should be 		-- weakly the same as the originally locked down file's@@ -252,7 +256,7 @@ 			, Command.Add.addSmall (DryRun False) destfile s 			) 	notoverwriting why = do-		warning $ "not overwriting existing " ++ fromRawFilePath destfile ++ " " ++ why+		warning $ "not overwriting existing " <> QuotedPath destfile <> " " <> UnquotedString why 		stop 	lockdown a = do 		let mi = MatchingFile $ FileInfo@@ -296,7 +300,9 @@ 			(reinject k) 			(importfile ld k) 		_ -> importfile ld k-	skipbecause s = showNote (s ++ "; skipping") >> next (return True)+	skipbecause s = do+		showNote (s <> "; skipping")+		next (return True)  verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform verifyExisting key destfile (yes, no) = do@@ -329,13 +335,13 @@ 	void $ includeCommandAction (listContents remote importtreeconfig ci importabletvar) 	liftIO (atomically (readTVar importabletvar)) >>= \case 		Nothing -> return ()-		Just importable -> importKeys remote importtreeconfig importcontent False importable >>= \case-			Nothing -> warning $ concat+		Just importable -> importChanges remote importtreeconfig importcontent False importable >>= \case+			ImportUnfinished -> warning $ UnquotedString $ concat 				[ "Failed to import some files from " 				, Remote.name remote 				, ". Re-run command to resume import." 				]-			Just imported -> void $+			ImportFinished imported -> void $ 				includeCommandAction $  					commitimport imported   where@@ -351,7 +357,7 @@ 		liftIO $ atomically $ writeTVar tvar importable 		next $ return True   where-	ai = ActionItemOther (Just (Remote.name remote))+	ai = ActionItemOther (Just (UnquotedString (Remote.name remote))) 	si = SeekInput []  listContents' :: Remote -> ImportTreeConfig -> CheckGitIgnore -> (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, Remote.ByteSize)) -> Annex a) -> Annex a@@ -367,13 +373,13 @@ 			, err 			] -commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContentsChunkable Annex (Either Sha Key) -> CommandStart-commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable =+commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> Imported -> CommandStart+commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig imported = 	starting "update" ai si $ do-		importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable+		importcommit <- buildImportCommit remote importtreeconfig importcommitconfig imported 		next $ updateremotetrackingbranch importcommit   where-	ai = ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)+	ai = ActionItemOther (Just $ UnquotedString $ fromRef $ fromRemoteTrackingBranch tb) 	si = SeekInput [] 	-- Update the tracking branch. Done even when there 	-- is nothing new to import, to make sure it exists.@@ -383,5 +389,5 @@ 				setRemoteTrackingBranch tb c 				return True 			Nothing -> do-				warning $ "Nothing to import and " ++ fromRef branch ++ " does not exist."+				warning $ UnquotedString $ "Nothing to import and " ++ fromRef branch ++ " does not exist." 				return False
Command/ImportFeed.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - 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.  -}@@ -16,11 +16,11 @@ import Text.Feed.Types import qualified Data.Set as S import qualified Data.Map as M-import Data.Char import Data.Time.Clock import Data.Time.Format import Data.Time.Calendar import Data.Time.LocalTime+import Control.Concurrent.STM import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified System.FilePath.ByteString as P@@ -37,7 +37,7 @@ import qualified Utility.Format import Utility.Tmp import Utility.Metered-import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..), checkCanAdd)+import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..), checkCanAdd, addWorkTree, checkRaw) import Annex.UUID import Backend.URL (fromUrl) import Annex.Content@@ -47,16 +47,17 @@ import Logs.MetaData import Annex.MetaData import Annex.FileMatcher-import Command.AddUrl (addWorkTree, checkRaw) import Annex.UntrustedFilePath import qualified Annex.Branch import Logs import qualified Utility.RawFilePath as R  cmd :: Command-cmd = notBareRepo $ withAnnexOptions [backendOption] $+cmd = notBareRepo $ withAnnexOptions os $ 	command "importfeed" SectionCommon "import files from podcast feeds" 		(paramRepeating paramUrl) (seek <$$> optParser)+  where+	os = [jobsOption, jsonOptions, jsonProgressOption, backendOption]  data ImportFeedOptions = ImportFeedOptions 	{ feedUrls :: CmdParams@@ -74,42 +75,103 @@ 	<*> parseDownloadOptions False  seek :: ImportFeedOptions -> CommandSeek-seek o = do+seek o = startConcurrency commandStages $ do 	addunlockedmatcher <- addUnlockedMatcher 	cache <- getCache (templateOption o)-	forM_ (feedUrls o) (getFeed addunlockedmatcher o cache)+	dlst <- liftIO $ newTMVarIO M.empty+	checkst <- liftIO $ newTVarIO M.empty -getFeed :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> URLString -> CommandSeek-getFeed addunlockedmatcher opts cache url = do-	showStartOther "importfeed" (Just url) (SeekInput [])-	withTmpFile "feed" $ \tmpf h -> do+	forM_ (feedUrls o) $ \url -> do+		liftIO $ atomically $ do+			m <- takeTMVar dlst+			putTMVar dlst (M.insert url Nothing m)+		commandAction $ getFeed url dlst+		startpendingdownloads addunlockedmatcher cache dlst checkst False+	+	startpendingdownloads addunlockedmatcher cache dlst checkst True++	clearfeedproblems checkst+  where+  	getpendingdownloads dlst blocking+		| blocking = do+			m <- takeTMVar dlst+			if M.null m+				then do+					putTMVar dlst m+					return m+				else+					let (pending, rest) = M.partition ispending m+					in if M.null pending+						then retry+						else do+							putTMVar dlst rest+							return pending+		| otherwise = do+			m <- takeTMVar dlst+			let (pending, rest) = M.partition ispending m+			putTMVar dlst rest+			return pending+	  where+		ispending Nothing = False+		ispending (Just _) = True++	startpendingdownloads addunlockedmatcher cache dlst checkst blocking = do+		m <- liftIO $ atomically $ getpendingdownloads dlst blocking+		+		forM_ (M.toList m) $ \(url, v) -> case v of+			Nothing -> noop+			Just Nothing -> noop+			Just (Just is) -> +				forM_ is $ \i -> do+					cv <- liftIO newEmptyTMVarIO+					liftIO $ atomically $ modifyTVar checkst $+						M.insertWith (++) url [cv]+					commandAction $+						startDownload addunlockedmatcher o cache cv i+	+	clearfeedproblems checkst = do+		m <- liftIO $ atomically $ readTVar checkst+		forM_ (M.toList m) $ \(url, cvl) ->+			whenM (and <$> mapM (liftIO . atomically . takeTMVar) cvl) $+				clearFeedProblem url++getFeed+	:: URLString+	-> TMVar (M.Map URLString (Maybe (Maybe [ToDownload])))+	-> CommandStart+getFeed url st =+	starting "importfeed" (ActionItemOther (Just (UnquotedString url))) (SeekInput [url]) $+		get `onException` recordfail+  where+	record v = liftIO $ atomically $ do+		m <- takeTMVar st+		putTMVar st (M.insert url v m)+	recordfail = record (Just Nothing)+	+	get = withTmpFile "feed" $ \tmpf h -> do 		liftIO $ hClose h 		ifM (downloadFeed url tmpf)-			( go tmpf-			, showEndResult =<< feedProblem url-				"downloading the feed failed"+			( parse tmpf+			, do+				recordfail+				next $ feedProblem url+					"downloading the feed failed" 			)-  where+ 	-- Use parseFeedFromFile rather than reading the file 	-- ourselves because it goes out of its way to handle encodings.-	go tmpf = liftIO (parseFeedFromFile' tmpf) >>= \case+	parse tmpf = liftIO (parseFeedFromFile' tmpf) >>= \case 		Nothing -> debugfeedcontent tmpf "parsing the feed failed" 		Just f -> do-			case map sanitizetitle $ decodeBS $ fromFeedText $ getFeedTitle f of+			case decodeBS $ fromFeedText $ getFeedTitle f of 				"" -> noop-				t -> showNote ('"' : t ++ "\"")+				t -> showNote (UnquotedString ('"' : t ++ "\"")) 			case findDownloads url f of 				[] -> debugfeedcontent tmpf "bad feed content; no enclosures to download" 				l -> do-					showEndOk-					ifM (and <$> mapM (performDownload addunlockedmatcher opts cache) l)-						( clearFeedProblem url-						, void $ feedProblem url -							"problem downloading some item(s) from feed"-						)-	sanitizetitle c-		| isControl c = '_'-		| otherwise = c+					record (Just (Just l))+					next $ return True+	 	debugfeedcontent tmpf msg = do 		feedcontent <- liftIO $ readFile tmpf 		fastDebug "Command.ImportFeed" $ unlines@@ -117,7 +179,8 @@ 			, feedcontent 			, "end of feed content" 			]-		showEndResult =<< feedProblem url+		recordfail+		next $ feedProblem url 			(msg ++ " (use --debug --debugfilter=ImportFeed to see the feed content that was downloaded)")  parseFeedFromFile' :: FilePath -> IO (Maybe Feed)@@ -148,9 +211,12 @@ getCache opttemplate = ifM (Annex.getRead Annex.force) 	( ret S.empty S.empty 	, do-		showStart "importfeed" "gathering known urls" (SeekInput [])+		j <- jsonOutputEnabled+		unless j $+			showStartMessage (StartMessage "importfeed" (ActionItemOther (Just "gathering known urls")) (SeekInput [])) 		(us, is) <- knownItems-		showEndOk+		unless j+			showEndOk 		ret (S.fromList us) (S.fromList is) 	)   where@@ -203,51 +269,9 @@ 	| otherwise = Url.withUrlOptions $ 		Url.download nullMeterUpdate Nothing url f -performDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> ToDownload -> Annex Bool-performDownload = performDownload' False--performDownload' :: Bool -> AddUnlockedMatcher -> ImportFeedOptions -> Cache -> ToDownload -> Annex Bool-performDownload' started addunlockedmatcher opts cache todownload = case location todownload of-	Enclosure url -> checkknown url $ do-		starturl url-		rundownload url (takeWhile (/= '?') $ takeExtension url) $ \f -> do-			let f' = fromRawFilePath f-			r <- Remote.claimingUrl url-			if Remote.uuid r == webUUID || rawOption (downloadOptions opts)-				then checkRaw (Just url) (downloadOptions opts) Nothing $ do-					let dlopts = (downloadOptions opts)-						-- force using the filename-						-- chosen here-						{ fileOption = Just f'-						-- don't use youtube-dl-						, rawOption = True-						}-					let go urlinfo = Just . maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f-					if relaxedOption (downloadOptions opts)-						then go Url.assumeUrlExists-						else Url.withUrlOptions (Url.getUrlInfo url) >>= \case-							Right urlinfo -> go urlinfo-							Left err -> do-								warning err-								return (Just [])-				else do-					res <- tryNonAsync $ maybe-						(error $ "unable to checkUrl of " ++ Remote.name r)-						(flip id url)-						(Remote.checkUrl r)-					case res of-						Left _ -> return (Just [])-						Right (UrlContents sz _) ->-							Just . maybeToList <$>-								downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz-						Right (UrlMulti l) -> do-							kl <- forM l $ \(url', sz, subf) ->-								let dest = f P.</> toRawFilePath (sanitizeFilePath subf)-								in downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' dest sz-							return $ Just $ if all isJust kl-								then catMaybes kl-								else []-							+startDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> CommandStart+startDownload addunlockedmatcher opts cache cv todownload = case location todownload of+	Enclosure url -> startdownloadenclosure url 	MediaLink linkurl -> do 		let mediaurl = setDownloader linkurl YoutubeDownloader 		let mediakey = Backend.URL.fromUrl mediaurl Nothing@@ -267,114 +291,186 @@ 	 - associated with a file in the annex, unless forced. -} 	checkknown url a 		| knownitemid || S.member url (knownurls cache)-			= ifM forced (a, return True)+			= ifM forced (a, nothingtodo) 		| otherwise = a +	nothingtodo = recordsuccess >> stop++	recordsuccess = liftIO $ atomically $ putTMVar cv True+	+	startdownloadenclosure :: URLString -> CommandStart+	startdownloadenclosure url = checkknown url $ startUrlDownload cv todownload url $+		downloadEnclosure addunlockedmatcher opts cache cv todownload url + 	knownitemid = case getItemId (item todownload) of 		Just (_, itemid) -> 			S.member (decodeBS $ fromFeedText itemid) (knownitems cache) 		_ -> False -	rundownload url extension getter = do-		dest <- makeunique url (1 :: Integer) $-			feedFile (template cache) todownload extension-		case dest of-			Nothing -> return True-			Just f -> getter (toRawFilePath f) >>= \case-				Just ks-					-- Download problem.-					| null ks -> do-						showEndFail-						checkFeedBroken (feedurl todownload)-					| otherwise -> do-						forM_ ks $ \key ->-							ifM (annexGenMetaData <$> Annex.getGitConfig)-								( addMetaData key $ extractMetaData todownload-								, addMetaData key $ minimalMetaData todownload-								)-						showEndOk-						return True-				-- Was not able to add anything, but not-				-- because of a download problem.-				Nothing -> do-					showEndFail-					return False--	{- Find a unique filename to save the url to.-	 - If the file exists, prefixes it with a number.-	 - When forced, the file may already exist and have the same-	 - url, in which case Nothing is returned as it does not need-	 - to be re-downloaded. -}-	makeunique url n file = ifM alreadyexists-		( ifM forced-			( lookupKey (toRawFilePath f) >>= \case-				Just k -> checksameurl k-				Nothing -> tryanother-			, tryanother-			)-		, return $ Just f-		)-	  where-		f = if n < 2-			then file-			else-				let (d, base) = splitFileName file-				in d </> show n ++ "_" ++ base-		tryanother = makeunique url (n + 1) file-		alreadyexists = liftIO $ isJust <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f))-		checksameurl k = ifM (elem url <$> getUrls k)-			( return Nothing-			, tryanother-			)-	 	downloadmedia linkurl mediaurl mediakey-		| rawOption (downloadOptions opts) = downloadlink False+		| rawOption (downloadOptions opts) = startdownloadlink 		| otherwise = ifM (youtubeDlSupported linkurl)-			( do-				starturl linkurl-				r <- withTmpWorkDir mediakey $ \workdir -> do+			( startUrlDownload cv todownload linkurl $+				withTmpWorkDir mediakey $ \workdir -> do 					dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate 					case dl of 						Right (Just mediafile) -> do 							let ext = case takeExtension mediafile of 								[] -> ".m" 								s -> s-							ok <- rundownload linkurl ext $ \f ->+							runDownload todownload linkurl ext cache cv $ \f -> 								checkCanAdd (downloadOptions opts) f $ \canadd -> do 									addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile)) 									return (Just [mediakey])-							return (Just ok) 						-- youtube-dl didn't support it, so 						-- download it as if the link were 						-- an enclosure.-						Right Nothing -> Just <$> downloadlink True+						Right Nothing -> contdownloadlink 						Left msg -> do-							warning $ linkurl ++ ": " ++ msg-							return Nothing-				return (fromMaybe False r)-			, downloadlink False+							warning $ UnquotedString $ linkurl ++ ": " ++ msg+							liftIO $ atomically $ putTMVar cv False+							next $ return False+			, startdownloadlink 			) 	  where-		downloadlink started' = checkRaw (Just linkurl) (downloadOptions opts) False $-			performDownload' started' addunlockedmatcher opts cache todownload-				{ location = Enclosure linkurl }+		startdownloadlink = checkRaw (Just linkurl) (downloadOptions opts) nothingtodo $+			startdownloadenclosure linkurl+		contdownloadlink = downloadEnclosure addunlockedmatcher opts cache cv todownload linkurl  	addmediafast linkurl mediaurl mediakey = 		ifM (pure (not (rawOption (downloadOptions opts))) 		     <&&> youtubeDlSupported linkurl)-			( do-				starturl linkurl-				rundownload linkurl ".m" $ \f ->+			( startUrlDownload cv todownload linkurl $ do+				runDownload todownload linkurl ".m" cache cv $ \f -> 					checkCanAdd (downloadOptions opts) f $ \canadd -> do 						addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey Nothing 						return (Just [mediakey])-			, performDownload' started addunlockedmatcher opts cache todownload-				{ location = Enclosure linkurl }+			, startdownloadenclosure linkurl 			) -	starturl u = unless started $-		showStartOther "addurl" (Just u) (SeekInput [])+downloadEnclosure :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> URLString -> CommandPerform+downloadEnclosure addunlockedmatcher opts cache cv todownload url = +	runDownload todownload url (takeWhile (/= '?') $ takeExtension url) cache cv $ \f -> do+		let f' = fromRawFilePath f+		r <- Remote.claimingUrl url+		if Remote.uuid r == webUUID || rawOption (downloadOptions opts)+			then checkRaw (Just url) (downloadOptions opts) (pure Nothing) $ do+				let dlopts = (downloadOptions opts)+					-- force using the filename+					-- chosen here+					{ fileOption = Just f'+					-- don't use youtube-dl+					, rawOption = True+					}+				let go urlinfo = Just . maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f+				if relaxedOption (downloadOptions opts)+					then go Url.assumeUrlExists+					else Url.withUrlOptions (Url.getUrlInfo url) >>= \case+						Right urlinfo -> go urlinfo+						Left err -> do+							warning (UnquotedString err)+							return (Just [])+			else do+				res <- tryNonAsync $ maybe+					(giveup $ "unable to checkUrl of " ++ Remote.name r)+					(flip id url)+					(Remote.checkUrl r)+				case res of+					Left _ -> return (Just [])+					Right (UrlContents sz _) ->+						Just . maybeToList <$>+							downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz+					Right (UrlMulti l) -> do+						kl <- forM l $ \(url', sz, subf) ->+							let dest = f P.</> toRawFilePath (sanitizeFilePath subf)+							in downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' dest sz+						return $ Just $ if all isJust kl+							then catMaybes kl+							else [] +runDownload+	:: ToDownload+	-> URLString+	-> String+	-> Cache+	-> TMVar Bool+	-> (RawFilePath -> Annex (Maybe [Key]))+	-> CommandPerform+runDownload todownload url extension cache cv getter = do+	dest <- makeunique (1 :: Integer) $+		feedFile (template cache) todownload extension+	case dest of+		Nothing -> do+			recordsuccess+			stop+		Just f -> getter (toRawFilePath f) >>= \case+			Just ks+				-- Download problem.+				| null ks -> do+					broken <- checkFeedBroken (feedurl todownload)+					when broken $+						void $ feedProblem url "download failed"+					liftIO $ atomically $ putTMVar cv broken+					next $ return False+				| otherwise -> do+					forM_ ks $ \key ->+						ifM (annexGenMetaData <$> Annex.getGitConfig)+							( addMetaData key $ extractMetaData todownload+							, addMetaData key $ minimalMetaData todownload+							)+					recordsuccess+					next $  return True+			-- Was not able to add anything, but not+			-- because of a download problem.+			Nothing -> do+				recordsuccess+				next $ return False+  where+	recordsuccess = liftIO $ atomically $ putTMVar cv True++	forced = Annex.getRead Annex.force++	{- Find a unique filename to save the url to.+	 - If the file exists, prefixes it with a number.+	 - When forced, the file may already exist and have the same+	 - url, in which case Nothing is returned as it does not need+	 - to be re-downloaded. -}+	makeunique n file = ifM alreadyexists+		( ifM forced+			( lookupKey (toRawFilePath f) >>= \case+				Just k -> checksameurl k+				Nothing -> tryanother+			, tryanother+			)+		, return $ Just f+		)+	  where+		f = if n < 2+			then file+			else+				let (d, base) = splitFileName file+				in d </> show n ++ "_" ++ base+		tryanother = makeunique (n + 1) file+		alreadyexists = liftIO $ isJust <$> catchMaybeIO (R.getSymbolicLinkStatus (toRawFilePath f))+		checksameurl k = ifM (elem url <$> getUrls k)+			( return Nothing+			, tryanother+			)++startUrlDownload :: TMVar Bool -> ToDownload -> URLString -> CommandPerform -> CommandStart+startUrlDownload cv todownload url a = do+	starting "addurl"+		(ActionItemOther (Just (UnquotedString url)))+		(SeekInput [feedurl todownload])+		(go `onException` recordfailure)+  where+	recordfailure = do+		void $ feedProblem url "download failed"+		liftIO $ atomically $ tryPutTMVar cv False+	go = do+		maybeAddJSONField "url" url+		a+ defaultTemplate :: String defaultTemplate = "${feedtitle}/${itemtitle}${extension}" @@ -477,10 +573,10 @@ feedProblem :: URLString -> String -> Annex Bool feedProblem url message = ifM (checkFeedBroken url) 	( do-		warning $ message ++ " (having repeated problems with feed: " ++ url ++ ")"+		warning $ UnquotedString $ message ++ " (having repeated problems with feed: " ++ url ++ ")" 		return False 	, do-		warning $ "warning: " ++ message+		warning $ UnquotedString $ "warning: " ++ message ++ " (feed: " ++ url ++ ")" 		return True 	)
Command/Info.hs view
@@ -43,7 +43,6 @@ import Types.Key import Types.TrustLevel import Types.FileMatcher-import Types.ActionItem import qualified Limit import Messages.JSON (DualDisp(..), ObjectMap(..)) import Annex.BloomFilter@@ -183,8 +182,12 @@  noInfo :: String -> SeekInput -> String -> Annex () noInfo s si msg = do-	showStart "info" (encodeBS s) si-	showNote msg+	-- The string may not really be a file, but use ActionItemTreeFile,+	-- rather than ActionItemOther to avoid breaking back-compat of+	-- json output.+	let ai = ActionItemTreeFile (toRawFilePath s)+	showStartMessage (StartMessage "info" ai si)+	showNote (UnquotedString msg) 	showEndFail 	Annex.incError @@ -455,15 +458,16 @@ 	uuidmap <- Remote.remoteMap id 	ts <- getTransfers 	maybeShowJSON $ JSONChunk [(desc, V.fromList $ map (uncurry jsonify) ts)]+	qp <- coreQuotePath <$> Annex.getGitConfig 	return $ if null ts 		then "none" 		else multiLine $-			map (uncurry $ line uuidmap) $ sort ts+			map (uncurry $ line qp uuidmap) $ sort ts   where 	desc = "transfers in progress"-	line uuidmap t i = unwords+	line qp uuidmap t i = unwords 		[ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing"-		, fromRawFilePath $ actionItemDesc $ mkActionItem+		, fromRawFilePath $ quote qp $ actionItemDesc $ mkActionItem 			(transferKey t, associatedFile i) 		, if transferDirection t == Upload then "to" else "from" 		, maybe (fromUUID $ transferUUID t) Remote.name $
Command/Init.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Init where  import Command@@ -17,7 +19,7 @@ import qualified Data.Map as M 	 cmd :: Command-cmd = dontCheck repoExists $+cmd = dontCheck repoExists $ withAnnexOptions [jsonOptions] $ 	command "init" SectionSetup "initialize git-annex" 		paramDesc (seek <$$> optParser) @@ -62,7 +64,7 @@ 		starting "init" (ActionItemOther (Just "autoenable")) si $ 			performAutoEnableOnly 	| otherwise = -		starting "init" (ActionItemOther (Just $ initDesc os)) si $+		starting "init" (ActionItemOther (Just $ UnquotedString $ initDesc os)) si $ 			perform os   where 	si = SeekInput []
Command/InitRemote.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -9,8 +9,6 @@  module Command.InitRemote where -import qualified Data.Map as M- import Command import Annex.SpecialRemote import qualified Remote@@ -24,11 +22,15 @@ import Config import Git.Config +import qualified Data.Map as M+import qualified Data.Text as T+ cmd :: Command-cmd = command "initremote" SectionSetup-	"creates a special (non-git) remote"-	(paramPair paramName $ paramOptional $ paramRepeating paramParamValue)-	(seek <$$> optParser)+cmd = withAnnexOptions [jsonOptions] $+	command "initremote" SectionSetup+		"creates a special (non-git) remote"+		(paramPair paramName $ paramOptional $ paramRepeating paramParamValue)+		(seek <$$> optParser)  data InitRemoteOptions = InitRemoteOptions 	{ cmdparams :: CmdParams@@ -64,29 +66,35 @@  start :: InitRemoteOptions -> [String] -> CommandStart start _ [] = giveup "Specify a name for the remote."-start o (name:ws) = ifM (not . null <$> findExisting name)-	( giveup $ "There is already a special remote named \"" ++ name ++-		"\". (Use enableremote to enable an existing special remote.)"-	, ifM (isJust <$> Remote.byNameOnly name)-		( giveup $ "There is already a remote named \"" ++ name ++ "\""-		, do-			sameasuuid <- maybe-				(pure Nothing)-				(Just . Sameas <$$> getParsed)-				(sameas o) -			c <- newConfig name sameasuuid-				(Logs.Remote.keyValToConfig Proposed ws)-				<$> remoteConfigMap-			t <- either giveup return (findType c)-			if whatElse o-				then startingCustomOutput (ActionItemOther Nothing) $-					describeOtherParamsFor c t-				else starting "initremote" (ActionItemOther (Just name)) si $-					perform t name c o-		)-	)+start o (name:ws) = do+	if whatElse o+		then ifM jsonOutputEnabled+			( starting "initremote" ai si $ prep $ \c t ->+				describeOtherParamsFor c t+			, startingCustomOutput (ActionItemOther Nothing) $ prep $ \c t ->+				describeOtherParamsFor c t+			)+		else starting "initremote" ai si $ prep $ \c t ->+			perform t name c o   where-	si = SeekInput [name]+	prep a = do+		whenM (not . null <$> findExisting name) $+			giveup $ "There is already a special remote named \"" ++ name +++				"\". (Use enableremote to enable an existing special remote.)"+		whenM (isJust <$> Remote.byNameOnly name) $+			giveup $ "There is already a remote named \"" ++ name ++ "\""+		sameasuuid <- maybe+			(pure Nothing)+			(Just . Sameas <$$> getParsed)+			(sameas o) +		c <- newConfig name sameasuuid+			(Logs.Remote.keyValToConfig Proposed ws)+			<$> remoteConfigMap+		t <- either giveup return (findType c)+		a c t+	+	si = SeekInput (name:ws)+	ai = ActionItemOther (Just (UnquotedString name))  perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform perform t name c o = do@@ -126,18 +134,36 @@ 	cp <- R.configParser t c 	let l = map mk (filter notinconfig $ remoteConfigFieldParsers cp) 		++ map mk' (maybe [] snd (remoteConfigRestPassthrough cp))-	liftIO $ forM_ l $ \(p, fd, vd) -> case fd of-		HiddenField -> return ()-		FieldDesc d -> do-			putStrLn p-			putStrLn ("\t" ++ d)-			case vd of-				Nothing -> return ()-				Just (ValueDesc d') ->-					putStrLn $ "\t(" ++ d' ++ ")"+	ifM jsonOutputEnabled+		( maybeAddJSONField "whatelse" $ M.fromList $ mkjson l+		, liftIO $ forM_ l $ \(p, fd, vd) -> case fd of+			HiddenField -> return ()+			FieldDesc d -> do+				putStrLn p+				putStrLn ("\t" ++ d)+				case vd of+					Nothing -> return ()+					Just (ValueDesc d') ->+						putStrLn $ "\t(" ++ d' ++ ")"+		+		) 	next $ return True   where+	mkjson = mapMaybe $ \(p, fd, vd) ->+		case fd of+			HiddenField -> Nothing+			FieldDesc d -> Just +				( T.pack p+				, M.fromList+					[ ("description" :: T.Text, d)+					, ("valuedescription", case vd of+						Nothing -> ""+						Just (ValueDesc d') -> d')+					]+				)+ 	notinconfig fp = not (M.member (parserForField fp) c)+ 	mk fp = ( fromProposedAccepted (parserForField fp) 		, fieldDesc fp 		, valueDesc fp
Command/Inprogress.hs view
@@ -9,6 +9,8 @@  import Command import Annex.Transfer+import Utility.Terminal+import Utility.SafeOutput  import qualified Data.Set as S @@ -29,33 +31,34 @@  seek :: InprogressOptions -> CommandSeek seek o = do+	isterminal <- liftIO $ checkIsTerminal stdout 	ts <- map (transferKey . fst) <$> getTransfers 	case keyOptions o of 		Just WantAllKeys ->-			forM_ ts $ commandAction . start'+			forM_ ts $ commandAction . (start' isterminal) 		Just (WantSpecificKey k)-			| k `elem` ts -> commandAction (start' k)+			| k `elem` ts -> commandAction (start' isterminal k) 			| otherwise -> commandAction stop 		_ -> do 			let s = S.fromList ts 			let seeker = AnnexedFileSeeker-				{ startAction = start s+				{ startAction = start isterminal s 				, checkContentPresent = Nothing 				, usesLocationLog = False 				} 			withFilesInGitAnnex ww seeker 				=<< workTreeItems ww (inprogressFiles o)   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "inprogress" -start :: S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart-start s _si _file k-	| S.member k s = start' k+start :: IsTerminal -> S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart+start isterminal s _si _file k+	| S.member k s = start' isterminal k 	| otherwise = stop -start' :: Key -> CommandStart-start' k = startingCustomOutput k $ do+start' :: IsTerminal -> Key -> CommandStart+start' (IsTerminal isterminal) k = startingCustomOutput k $ do 	tmpf <- fromRawFilePath <$> fromRepo (gitAnnexTmpObjectLocation k) 	whenM (liftIO $ doesFileExist tmpf) $-		liftIO $ putStrLn tmpf+		liftIO $ putStrLn (if isterminal then safeOutput tmpf else tmpf) 	next $ return True
Command/List.hs view
@@ -6,20 +6,25 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.List where  import qualified Data.Set as S import qualified Data.Map as M import Data.Function import Data.Ord+import qualified Data.ByteString.Char8 as B8  import Command import Remote+import qualified Annex import Logs.Trust import Logs.UUID import Annex.UUID import Git.Types (RemoteName) import Utility.Tuple+import Utility.SafeOutput  cmd :: Command cmd = noCommit $ withAnnexOptions [annexedMatchingOptions] $@@ -51,7 +56,7 @@ 		} 	withFilesInGitAnnex ww seeker =<< workTreeItems ww (listThese o)   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "list"  getList :: ListOptions -> Annex [(UUID, RemoteName, TrustLevel)] getList o@@ -75,12 +80,14 @@ 			filter (\t -> thd3 t /= DeadTrusted) rs3  printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()-printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l+printHeader l = liftIO $ putStrLn $ safeOutput $ lheader $ map (\(_, n, t) -> (n, t)) l  start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> RawFilePath -> Key -> CommandStart start l _si file key = do 	ls <- S.fromList <$> keyLocations key-	liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file+	qp <- coreQuotePath <$> Annex.getGitConfig+	liftIO $ B8.putStrLn $ quote qp $+		format (map (\(u, _, t) -> (t, S.member u ls)) l) file 	stop  type Present = Bool@@ -93,8 +100,8 @@ 	trust UnTrusted = " (untrusted)" 	trust _ = "" -format :: [(TrustLevel, Present)] -> RawFilePath -> String-format remotes file = thereMap ++ " " ++ fromRawFilePath file+format :: [(TrustLevel, Present)] -> RawFilePath -> StringContainingQuotedPath+format remotes file = UnquotedString (thereMap) <> " " <> QuotedPath file   where  	thereMap = concatMap there remotes 	there (UnTrusted, True) = "x"
Command/Lock.hs view
@@ -32,7 +32,7 @@ seek :: CmdParams -> CommandSeek seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "lock" 	seeker = AnnexedFileSeeker 		{ startAction = start 		, checkContentPresent = Nothing
Command/Log.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Log where  import qualified Data.Set as S@@ -12,6 +14,7 @@ import Data.Char import Data.Time.Clock.POSIX import Data.Time+import qualified Data.ByteString.Char8 as B8 import qualified System.FilePath.ByteString as P  import Command@@ -36,7 +39,7 @@ type Outputter = LogChange -> POSIXTime -> [UUID] -> Annex ()  cmd :: Command-cmd = withAnnexOptions [annexedMatchingOptions] $+cmd = withAnnexOptions [jsonOptions, annexedMatchingOptions] $ 	command "log" SectionQuery "shows location log" 		paramPaths (seek <$$> optParser) @@ -86,7 +89,7 @@ 	( do 		m <- Remote.uuidDescriptions 		zone <- liftIO getCurrentTimeZone-		let outputter = mkOutputter m zone o+		outputter <- mkOutputter m zone o <$> jsonOutputEnabled 		let seeker = AnnexedFileSeeker 			{ startAction = start o outputter 			, checkContentPresent = Nothing@@ -102,19 +105,20 @@ 	, giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents displaying location log changes. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)" 	)   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "log" -start :: LogOptions -> (FilePath -> Outputter) -> SeekInput -> RawFilePath -> Key -> CommandStart-start o outputter _ file key = do+start :: LogOptions -> (ActionItem -> SeekInput -> Outputter) -> SeekInput -> RawFilePath -> Key -> CommandStart+start o outputter si file key = do 	(changes, cleanup) <- getKeyLog key (passthruOptions o)-	showLogIncremental (outputter (fromRawFilePath file)) changes+	let ai = mkActionItem (file, key)+	showLogIncremental (outputter ai si) changes 	void $ liftIO cleanup 	stop -startAll :: LogOptions -> (String -> Outputter) -> CommandStart+startAll :: LogOptions -> (ActionItem -> SeekInput -> Outputter) -> CommandStart startAll o outputter = do 	(changes, cleanup) <- getAllLog (passthruOptions o)-	showLog outputter changes+	showLog (\ai -> outputter ai (SeekInput [])) changes 	void $ liftIO cleanup 	stop @@ -149,42 +153,64 @@ {- Displays changes made. Streams, and can display changes affecting  - different keys, but does twice as much reading of logged values  - as showLogIncremental. -}-showLog :: (String -> Outputter) -> [RefChange] -> Annex ()+showLog :: (ActionItem -> Outputter) -> [RefChange] -> Annex () showLog outputter cs = forM_ cs $ \c -> do-	let keyname = serializeKey (changekey c)+	let ai = mkActionItem (changekey c) 	new <- S.fromList <$> loggedLocationsRef (newref c) 	old <- S.fromList <$> loggedLocationsRef (oldref c)-	sequence_ $ compareChanges (outputter keyname)+	sequence_ $ compareChanges (outputter ai) 		[(changetime c, new, old)] -mkOutputter :: UUIDDescMap -> TimeZone -> LogOptions -> FilePath -> Outputter-mkOutputter m zone o file-	| rawDateOption o = normalOutput lookupdescription file show-	| gourceOption o = gourceOutput lookupdescription file-	| otherwise = normalOutput lookupdescription file (showTimeStamp zone)+mkOutputter :: UUIDDescMap -> TimeZone -> LogOptions -> Bool -> ActionItem -> SeekInput -> Outputter+mkOutputter m zone o jsonenabled ai si+	| jsonenabled = jsonOutput m ai si+	| rawDateOption o = normalOutput lookupdescription ai rawTimeStamp+	| gourceOption o = gourceOutput lookupdescription ai +	| otherwise = normalOutput lookupdescription ai (showTimeStamp zone)   where 	lookupdescription u = maybe (fromUUID u) (fromUUIDDesc) (M.lookup u m) -normalOutput :: (UUID -> String) -> FilePath -> (POSIXTime -> String) -> Outputter-normalOutput lookupdescription file formattime logchange ts us =-	liftIO $ mapM_ (putStrLn . format) us+normalOutput :: (UUID -> String) -> ActionItem -> (POSIXTime -> String) -> Outputter+normalOutput lookupdescription ai formattime logchange ts us = do+	qp <- coreQuotePath <$> Annex.getGitConfig+	liftIO $ mapM_ (B8.putStrLn . quote qp . format) us   where 	time = formattime ts 	addel = case logchange of 		Added -> "+" 		Removed -> "-"-	format u = unwords [ addel, time, file, "|", -		fromUUID u ++ " -- " ++ lookupdescription u ]+	format u = UnquotedString addel <> " " +		<> UnquotedString time <> " " +		<> actionItemDesc ai <> " | " +		<> UnquotedByteString (fromUUID u) <> " -- "+		<> UnquotedString (lookupdescription u) -gourceOutput :: (UUID -> String) -> FilePath -> Outputter-gourceOutput lookupdescription file logchange ts us =+jsonOutput :: UUIDDescMap -> ActionItem -> SeekInput -> Outputter+jsonOutput m ai si logchange ts us = do+	showStartMessage $ StartMessage "log" ai si+	maybeShowJSON $ JSONChunk+		[ ("logged", case logchange of+			Added -> "addition"+			Removed -> "removal")+		, ("date", rawTimeStamp ts)+		]+	void $ Remote.prettyPrintUUIDsDescs "locations" m us+	showEndOk++gourceOutput :: (UUID -> String) -> ActionItem -> Outputter+gourceOutput lookupdescription ai logchange ts us = 	liftIO $ mapM_ (putStrLn . intercalate "|" . format) us   where 	time = takeWhile isDigit $ show ts 	addel = case logchange of 		Added -> "A"  		Removed -> "M"-	format u = [ time, lookupdescription u, addel, file ]+	format u =+		[ time+		, lookupdescription u+		, addel+		, decodeBS (noquote (actionItemDesc ai))+		]  {- Generates a display of the changes.  - Uses a formatter to generate a display of items that are added and@@ -192,10 +218,12 @@ compareChanges :: Ord a => (LogChange -> POSIXTime -> [a] -> b) -> [(POSIXTime, S.Set a, S.Set a)] -> [b] compareChanges format changes = concatMap diff changes   where-	diff (ts, new, old) =-		[ format Added ts   $ S.toList $ S.difference new old-		, format Removed ts $ S.toList $ S.difference old new-		]+	diff (ts, new, old)+		| new == old = []+		| otherwise = +			[ format Added ts   $ S.toList $ S.difference new old+			, format Removed ts $ S.toList $ S.difference old new+			]  {- Streams the git log for a given key's location log file.  -@@ -281,9 +309,12 @@ 	go _ = Nothing  parseTimeStamp :: String -> POSIXTime-parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (error "bad timestamp") .+parseTimeStamp = utcTimeToPOSIXSeconds . fromMaybe (giveup "bad timestamp") . 	parseTimeM True defaultTimeLocale "%s"  showTimeStamp :: TimeZone -> POSIXTime -> String showTimeStamp zone = formatTime defaultTimeLocale rfc822DateFormat  	. utcToZonedTime zone . posixSecondsToUTCTime++rawTimeStamp :: POSIXTime -> String+rawTimeStamp t = filter (/= 's') (show t)
Command/LookupKey.hs view
@@ -10,6 +10,8 @@ import Command import Annex.CatFile import qualified Git.LsFiles+import Utility.Terminal+import Utility.SafeOutput  cmd :: Command cmd = notBareRepo $ noCommit $ noMessages $@@ -23,7 +25,9 @@ 	Nothing -> return False 	Just file' -> catKeyFile file' >>= \case 		Just k  -> do-			liftIO $ putStrLn $ serializeKey k+			IsTerminal isterminal <- liftIO $ checkIsTerminal stdout+			let sk = serializeKey k+			liftIO $ putStrLn $ if isterminal then safeOutput sk else sk 			return True 		Nothing -> return False
Command/Map.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Map where  import qualified Data.Map as M@@ -62,11 +64,11 @@  runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool runViewer file [] = do-	showLongNote $ "left map in " ++ file+	showLongNote $ UnquotedString $ "left map in " ++ file 	return True runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c) 	( do-		showLongNote $ "running: " ++ c ++ unwords (toCommand ps)+		showLongNote $ UnquotedString $ "running: " ++ c ++ unwords (toCommand ps) 		showOutput 		liftIO $ boolSystem c ps 	, runViewer file rest@@ -196,7 +198,7 @@ {- reads the config of a remote, with progress display -} scan :: Git.Repo -> Annex Git.Repo scan r = do-	showStartOther "map" (Just $ Git.repoDescribe r) (SeekInput [])+	showStartMessage (StartMessage "map" (ActionItemOther (Just $ UnquotedString $ Git.repoDescribe r)) (SeekInput [])) 	v <- tryScan r 	case v of 		Just r' -> do
Command/Merge.hs view
@@ -16,9 +16,10 @@ import Git.Types  cmd :: Command-cmd = command "merge" SectionMaintenance-	"merge changes from remotes"-	(paramOptional paramRef) (seek <$$> optParser)+cmd = withAnnexOptions [jsonOptions] $+	command "merge" SectionMaintenance+		"merge changes from remotes"+		(paramOptional paramRef) (seek <$$> optParser)  data MergeOptions = MergeOptions 	{ mergeBranches :: [String]@@ -48,7 +49,7 @@ 	Annex.Branch.commit =<< Annex.Branch.commitMessage 	next $ return True   where-	ai = ActionItemOther (Just (fromRef Annex.Branch.name))+	ai = ActionItemOther (Just (UnquotedString (fromRef Annex.Branch.name))) 	si = SeekInput []  mergeSyncedBranch :: MergeOptions -> CommandStart@@ -63,5 +64,5 @@ 	let so = def { notOnlyAnnexOption = True } 	next $ merge currbranch mc so Git.Branch.ManualCommit r   where-	ai = ActionItemOther (Just (Git.fromRef r))+	ai = ActionItemOther (Just (UnquotedString (Git.fromRef r))) 	si = SeekInput []
Command/MetaData.hs view
@@ -12,10 +12,10 @@ import Annex.VectorClock import Logs.MetaData import Annex.WorkTree-import Messages.JSON (JSONActionItem(..), AddJSONActionItemFields(..)) import Types.Messages-import Utility.Aeson+import Utility.SafeOutput import Limit+import Messages.JSON (JSONActionItem(..), eitherDecode)  import qualified Data.Set as S import qualified Data.Map as M@@ -75,7 +75,7 @@ seek o = case batchOption o of 	NoBatch -> do 		c <- currentVectorClock-		let ww = WarnUnmatchLsFiles+		let ww = WarnUnmatchLsFiles "metadata" 		let seeker = AnnexedFileSeeker 			{ startAction = start c o 			, checkContentPresent = Nothing@@ -109,7 +109,7 @@ 	Get f -> startingCustomOutput k $ do 		l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k 		liftIO $ forM_ l $-			B8.putStrLn . fromMetaValue+			B8.putStrLn . safeOutput . fromMetaValue 		next $ return True 	_ -> starting "metadata" ai si $ 		perform c o k@@ -126,10 +126,8 @@ cleanup :: Key -> CommandCleanup cleanup k = do 	m <- getCurrentMetaData k-	case toJSON' (AddJSONActionItemFields m) of-		Object o -> maybeShowJSON $ AesonObject o-		_ -> noop-	showLongNote $ unlines $ concatMap showmeta $+	maybeAddJSONField "fields" m+	showLongNote $ UnquotedString $ unlines $ concatMap showmeta $ 		map unwrapmeta (fromMetaData m) 	return True   where
Command/Migrate.hs view
@@ -20,7 +20,7 @@ import Utility.Metered  cmd :: Command-cmd = withAnnexOptions [backendOption, annexedMatchingOptions] $+cmd = withAnnexOptions [backendOption, annexedMatchingOptions, jsonOptions] $ 	command "migrate" SectionUtility  		"switch data to different backend" 		paramPaths (seek <$$> optParser)@@ -41,7 +41,7 @@ seek :: MigrateOptions -> CommandSeek seek o = withFilesInGitAnnex ww seeker =<< workTreeItems ww (migrateThese o)   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "migrate" 	seeker = AnnexedFileSeeker 		{ startAction = start o 		, checkContentPresent = Nothing
Command/MinCopies.hs view
@@ -35,5 +35,5 @@ 	setGlobalMinCopies $ configuredMinCopies n 	next $ return True   where-	ai = ActionItemOther (Just $ show n)+	ai = ActionItemOther (Just $ UnquotedString $ show n) 	si = SeekInput [show n]
Command/Mirror.hs view
@@ -50,7 +50,7 @@ 	stages = case fromToOptions o of 		FromRemote _ -> transferStages 		ToRemote _ -> commandStages-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "mirror" 	seeker = AnnexedFileSeeker 		{ startAction = start o 		, checkContentPresent = Nothing
Command/Move.hs view
@@ -84,7 +84,7 @@ 		, usesLocationLog = True 		} 	keyaction = startKey fto (removeWhen o)-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "move"  stages :: FromToHereOptions -> UsedStages stages (FromOrToRemote (FromRemote _)) = transferStages@@ -157,10 +157,10 @@ 	srcuuid <- getUUID 	case isthere of 		Left err -> do-			showNote err+			showNote (UnquotedString err) 			stop 		Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do-			showAction $ "to " ++ Remote.name dest+			showAction $ UnquotedString $ "to " ++ Remote.name dest 			ok <- notifyTransfer Upload afile $ 				upload dest key afile stdRetry 			if ok@@ -260,7 +260,7 @@  fromPerform' :: Bool -> Bool -> Remote -> Key -> AssociatedFile -> Annex (RemoveWhen -> CommandPerform) fromPerform' present updatelocationlog src key afile = do-	showAction $ "from " ++ Remote.name src+	showAction $ UnquotedString $ "from " ++ Remote.name src 	destuuid <- getUUID 	logMove (Remote.uuid src) destuuid present key $ \deststartedwithcopy -> 		if present@@ -314,7 +314,7 @@  	faileddropremote = do 		showLongNote "(Use --force to override this check, or adjust numcopies.)"-		showLongNote $ "Content not dropped from " ++ Remote.name src ++ "."+		showLongNote $ UnquotedString $ "Content not dropped from " ++ Remote.name src ++ "." 		logMoveCleanup deststartedwithcopy 		next $ return False @@ -394,11 +394,13 @@ 		haskey <- Remote.hasKey dest key 		case haskey of                 	Left err -> do                   -				showNote err       +				showNote (UnquotedString err) 				stop 			Right True -> do-				showAction $ "from " ++ Remote.name src-				showAction $ "to " ++ Remote.name dest+				showAction $ UnquotedString $+					"from " ++ Remote.name src+				showAction $ UnquotedString $+					"to " ++ Remote.name dest 				-- The log may not indicate dest's copy 				-- yet, so make sure it does. 				logChange key (Remote.uuid dest) InfoPresent
Command/Multicast.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, OverloadedStrings #-}  module Command.Multicast where @@ -131,7 +131,7 @@ 	-- expensive. 	starting "sending files" (ActionItemOther Nothing) (SeekInput []) $ 		withTmpFile "send" $ \t h -> do-			let ww = WarnUnmatchLsFiles+			let ww = WarnUnmatchLsFiles "multicast" 			(fs', cleanup) <- seekHelper id ww LsFiles.inRepo 				=<< workTreeItems ww fs 			matcher <- Limit.getMatcher@@ -211,7 +211,7 @@ storeReceived f = do 	case deserializeKey (takeFileName f) of 		Nothing -> do-			warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file."+			warning $ "Received a file " <> QuotedPath (toRawFilePath f) <> " that is not a git-annex key. Deleting this file." 			liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) 		Just k -> void $ logStatusAfter k $ 			getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $
Command/NumCopies.hs view
@@ -49,5 +49,5 @@ 	setGlobalNumCopies $ configuredNumCopies n 	next $ return True   where-	ai = ActionItemOther (Just $ show n)+	ai = ActionItemOther (Just $ UnquotedString $ show n) 	si = SeekInput [show n]
Command/P2P.hs view
@@ -24,6 +24,7 @@ import Utility.Tmp.Dir import Utility.FileMode import Utility.ThreadScheduler+import Utility.SafeOutput import qualified Utility.RawFilePath as R import qualified Utility.MagicWormhole as Wormhole @@ -92,7 +93,7 @@ 	authtoken <- liftIO $ genAuthToken 128 	storeP2PAuthToken authtoken 	earlyWarning "These addresses allow access to this git-annex repository. Only share them with people you trust with that access, using trusted communication channels!"-	liftIO $ putStr $ unlines $+	liftIO $ putStr $ safeOutput $ unlines $ 		map formatP2PAddress $ 			map (`P2PAddressAuth` authtoken) addrs @@ -101,7 +102,7 @@ linkRemote remotename = starting "p2p link" ai si $ 	next promptaddr   where-	ai = ActionItemOther (Just remotename)+	ai = ActionItemOther (Just (UnquotedString remotename)) 	si = SeekInput [] 	promptaddr = do 		liftIO $ putStrLn ""@@ -131,7 +132,7 @@ 	, giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/" 	)   where-	ai = ActionItemOther (Just remotename)+	ai = ActionItemOther (Just (UnquotedString remotename)) 	si = SeekInput []  performPairing :: RemoteName -> [P2PAddress] -> CommandPerform@@ -152,7 +153,7 @@ 				warning "Failed receiving data from pair." 				return False 			LinkFailed e -> do-				warning $ "Failed linking to pair: " ++ e+				warning $ UnquotedString $ "Failed linking to pair: " ++ e 				return False   where 	ui observer producer = do
Command/PreCommit.hs view
@@ -32,10 +32,10 @@  seek :: CmdParams -> CommandSeek seek ps = do-	let ww = WarnUnmatchWorkTreeItems+	let ww = WarnUnmatchWorkTreeItems "pre-commit" 	l <- workTreeItems ww ps 	-- fix symlinks to files being committed-	flip withFilesToBeCommitted l $ \(si, f) -> commandAction $+	flip (withFilesToBeCommitted ww) l $ \(si, f) -> commandAction $ 		maybe stop (Command.Fix.start Command.Fix.FixSymlinks si f) 			=<< isAnnexLink f 	-- after a merge conflict or git cherry-pick or stash, pointer@@ -72,7 +72,7 @@ 	return True  showMetaDataChange :: MetaData -> Annex ()-showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData+showMetaDataChange = showLongNote . UnquotedString . unlines . concatMap showmeta . fromMetaData   where 	showmeta (f, vs) = map (showmetavalue f) $ S.toList vs 	showmetavalue f v = T.unpack (fromMetaField f) <> showset v <> "=" <> decodeBS (fromMetaValue v)
+ Command/Pull.hs view
@@ -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.Pull (cmd) where++import Command+import Command.Sync hiding (cmd)++cmd :: Command+cmd = withAnnexOptions [jobsOption, backendOption] $+	command "pull" SectionCommon +		"pull content from remotes"+		(paramRepeating paramRemote) (seek <--< optParser PullMode)
+ Command/Push.hs view
@@ -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.Push (cmd) where++import Command+import Command.Sync hiding (cmd)++cmd :: Command+cmd = withAnnexOptions [jobsOption, backendOption] $+	command "push" SectionCommon +		"push content to remotes"+		(paramRepeating paramRemote) (seek <--< optParser PushMode)
Command/ReKey.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.ReKey where  import Command@@ -23,10 +25,11 @@ import System.PosixCompat.Files (linkCount, fileMode)  cmd :: Command-cmd = command "rekey" SectionPlumbing-	"change keys used for files"-	(paramRepeating $ paramPair paramPath paramKey)-	(seek <$$> optParser)+cmd = withAnnexOptions [jsonOptions] $ +	command "rekey" SectionPlumbing+		"change keys used for files"+		(paramRepeating $ paramPair paramPath paramKey)+		(seek <$$> optParser)  data ReKeyOptions = ReKeyOptions 	{ reKeyThese :: CmdParams@@ -80,8 +83,10 @@ 	ifM (inAnnex oldkey)  		( unlessM (linkKey file oldkey newkey) $ 			giveup "failed creating link from old to new key"-		, unlessM (Annex.getRead Annex.force) $-			giveup $ fromRawFilePath file ++ " is not available (use --force to override)"+		, unlessM (Annex.getRead Annex.force) $ do+			qp <- coreQuotePath <$> Annex.getGitConfig+			giveup $ decodeBS $ quote qp $ QuotedPath file+				<> " is not available (use --force to override)" 		) 	next $ cleanup file newkey @@ -108,12 +113,12 @@ 				replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do 					let tmp' = toRawFilePath tmp 					unlessM (checkedCopyFile oldkey oldobj tmp' Nothing) $-						error "can't lock old key"+						giveup "can't lock old key" 					thawContent tmp' 		ic <- withTSDelta (liftIO . genInodeCache file) 		case v of 			Left e -> do-				warning (show e)+				warning (UnquotedString (show e)) 				return False 			Right () -> do 				r <- linkToAnnex newkey file ic
Command/RegisterUrl.hs view
@@ -63,7 +63,7 @@ 	starting "registerurl" ai si $ 		perform a o key url   where-	ai = ActionItemOther (Just url)+	ai = ActionItemOther (Just (UnquotedString url))  perform :: (Remote -> Key -> URLString -> Annex ()) -> RegisterUrlOptions -> Key -> URLString -> CommandPerform perform a o key url = do@@ -73,7 +73,7 @@ 		_ -> Remote.claimingUrl url 	case needremote of 		Just nr | nr /= r -> do-			showNote $ "The url " ++ url ++ " is claimed by remote " ++ Remote.name r+			showNote $ UnquotedString $ "The url " ++ url ++ " is claimed by remote " ++ Remote.name r 			next $ return False 		_ -> do 			a r key (setDownloader' url r)
Command/Reinit.hs view
@@ -14,7 +14,7 @@ import qualified Annex.SpecialRemote 	 cmd :: Command-cmd = dontCheck repoExists $+cmd = dontCheck repoExists $ withAnnexOptions [jsonOptions] $ 	command "reinit" SectionUtility  		"initialize repository, reusing old UUID" 		(paramUUID ++ "|" ++ paramDesc)@@ -24,9 +24,10 @@ seek = withWords (commandAction . start)  start :: [String] -> CommandStart-start ws = starting "reinit" (ActionItemOther (Just s)) (SeekInput ws) $+start ws = starting "reinit" ai (SeekInput ws) $ 	perform s   where+	ai = ActionItemOther (Just (UnquotedString s)) 	s = unwords ws  perform :: String -> CommandPerform
Command/Reinject.hs view
@@ -1,10 +1,12 @@ {- git-annex command  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Reinject where  import Command@@ -15,9 +17,10 @@ import Utility.Metered import Annex.WorkTree import qualified Git+import qualified Annex  cmd :: Command-cmd = withAnnexOptions [backendOption] $+cmd = withAnnexOptions [backendOption, jsonOptions] $ 	command "reinject" SectionUtility  		"inject content of file back into annex" 		(paramRepeating (paramPair "SRC" "DEST"))@@ -40,56 +43,64 @@ seek :: ReinjectOptions -> CommandSeek seek os 	| knownOpt os = withStrings (commandAction . startKnown) (params os)-	| otherwise = withWords (commandAction . startSrcDest) (params os)+	| otherwise = withPairs (commandAction . startSrcDest) (params os) -startSrcDest :: [FilePath] -> CommandStart-startSrcDest ps@(src:dest:[])+startSrcDest :: (SeekInput, (String, String)) -> CommandStart+startSrcDest (si, (src, dest)) 	| src == dest = stop-	| otherwise = notAnnexed src' $+	| otherwise = starting "reinject" ai si $ notAnnexed src' $ 		lookupKey (toRawFilePath dest) >>= \case-			Just k -> go k-			Nothing -> giveup $ src ++ " is not an annexed file"+			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 of "+						<> QuotedPath (toRawFilePath dest)+				)+			Nothing -> do+				qp <- coreQuotePath <$> Annex.getGitConfig+				giveup $ decodeBS $ quote qp $ QuotedPath src'+					<> " is not an annexed file"   where 	src' = toRawFilePath src-	go key = starting "reinject" ai si $-		ifM (verifyKeyContent key src')-			( perform src' key-			, giveup $ src ++ " does not have expected content of " ++ dest-			)-	ai = ActionItemOther (Just src)-	si = SeekInput ps-startSrcDest _ = giveup "specify a src file and a dest file"+	ai = ActionItemOther (Just (QuotedPath src'))  startKnown :: FilePath -> CommandStart-startKnown src = notAnnexed src' $-	starting "reinject" ai si $ do-		(key, _) <- genKey ks nullMeterUpdate =<< defaultBackend-		ifM (isKnownKey key)-			( perform src' key-			, do-				warning "Not known content; skipping"-				next $ return True-			)+startKnown src = starting "reinject" ai si $ notAnnexed src' $ do+	(key, _) <- genKey ks nullMeterUpdate =<< defaultBackend+	ifM (isKnownKey key)+		( perform src' key+		, do+			warning "Not known content; skipping"+			next $ return True+		)   where 	src' = toRawFilePath src 	ks = KeySource src' src' Nothing-	ai = ActionItemOther (Just src)+	ai = ActionItemOther (Just (QuotedPath src')) 	si = SeekInput [src] -notAnnexed :: RawFilePath -> CommandStart -> CommandStart+notAnnexed :: RawFilePath -> CommandPerform -> CommandPerform notAnnexed src a =  	ifM (fromRepo Git.repoIsLocalBare) 		( a 		, lookupKey src >>= \case-			Just _ -> giveup $ "cannot used annexed file as src: " ++ fromRawFilePath src+			Just _ -> do+				qp <- coreQuotePath <$> Annex.getGitConfig+				giveup $ decodeBS $ quote qp $ +					"cannot used annexed file as src: "+						<> QuotedPath src 			Nothing -> a 		)  perform :: RawFilePath -> Key -> CommandPerform-perform src key = ifM move-	( next $ cleanup key-	, error "failed"-	)+perform src key = do+	maybeAddJSONField "key" (serializeKey key)+	ifM move+		( next $ cleanup key+		, giveup "failed"+		)   where 	move = checkDiskSpaceToGet key False $ 		moveAnnex key (AssociatedFile Nothing) src
Command/RemoteDaemon.hs view
@@ -24,7 +24,7 @@  run :: DaemonOptions -> CommandSeek run o-	| stopDaemonOption o = error "--stop not implemented for remotedaemon"+	| stopDaemonOption o = giveup "--stop not implemented for remotedaemon" 	| foregroundDaemonOption o = liftIO runInteractive 	| otherwise = do #ifndef mingw32_HOST_OS
Command/RenameRemote.hs view
@@ -18,10 +18,11 @@ import qualified Data.Map as M  cmd :: Command-cmd = command "renameremote" SectionSetup-	"changes name of special remote"-	(paramPair paramName paramName)-	(withParams seek)+cmd = withAnnexOptions [jsonOptions] $+	command "renameremote" SectionSetup+		"changes name of special remote"+		(paramPair paramName paramName)+		(withParams seek)  seek :: CmdParams -> CommandSeek seek = withWords (commandAction . start)
Command/ResolveMerge.hs view
@@ -28,7 +28,7 @@ 	us <- fromMaybe nobranch <$> inRepo Git.Branch.current 	d <- fromRawFilePath <$> fromRepo Git.localGitDir 	let merge_head = d </> "MERGE_HEAD"-	them <- fromMaybe (error nomergehead) . extractSha+	them <- fromMaybe (giveup nomergehead) . extractSha 		<$> liftIO (S.readFile merge_head) 	ifM (resolveMerge (Just us) them False) 		( do
Command/RmUrl.hs view
@@ -12,7 +12,7 @@ import Annex.WorkTree  cmd :: Command-cmd = notBareRepo $+cmd = notBareRepo $ withAnnexOptions [jsonOptions] $ 	command "rmurl" SectionCommon  		"record file is not available at url" 		(paramRepeating (paramPair paramFile paramUrl))
Command/Schedule.hs view
@@ -11,6 +11,7 @@ import qualified Remote import Logs.Schedule import Types.ScheduledActivity+import Utility.SafeOutput  import qualified Data.Set as S @@ -31,7 +32,7 @@ 			performGet u 	parse ps@(name:expr:[]) = do 		u <- Remote.nameToUUID name-		let ai = ActionItemOther (Just name)+		let ai = ActionItemOther (Just (UnquotedString name)) 		let si = SeekInput ps 		startingUsualMessages "schedule" ai si $ 			performSet expr u@@ -40,7 +41,7 @@ performGet :: UUID -> CommandPerform performGet uuid = do 	s <- scheduleGet uuid-	liftIO $ putStrLn $ intercalate "; " $ +	liftIO $ putStrLn $ safeOutput $ intercalate "; " $  		map fromScheduledActivity $ S.toList s 	next $ return True
Command/Semitrust.hs view
@@ -12,9 +12,10 @@ import Command.Trust (trustCommand)  cmd :: Command-cmd = command "semitrust" SectionSetup -	"return repository to default trust level"-	(paramRepeating paramRepository) (withParams seek)+cmd = withAnnexOptions [jsonOptions] $+	command "semitrust" SectionSetup +		"return repository to default trust level"+		(paramRepeating paramRepository) (withParams seek)  seek :: CmdParams -> CommandSeek seek = trustCommand "semitrust" SemiTrusted
Command/SetKey.hs view
@@ -21,10 +21,11 @@  start :: [String] -> CommandStart start ps@(keyname:file:[]) = starting "setkey" ai si $-	perform (toRawFilePath file) (keyOpt keyname)+	perform file' (keyOpt keyname)   where-	ai = ActionItemOther (Just file)+	ai = ActionItemOther (Just (QuotedPath file')) 	si = SeekInput ps+	file' = toRawFilePath file start _ = giveup "specify a key and a content file"  keyOpt :: String -> Key@@ -43,7 +44,7 @@ 		else return True 	if ok 		then next $ cleanup key-		else error "mv failed!"+		else giveup "move failed!"  cleanup :: Key -> CommandCleanup cleanup key = do
Command/SetPresentKey.hs view
@@ -12,7 +12,7 @@ import Logs.Presence.Pure  cmd :: Command-cmd = noCommit $ +cmd = noCommit $ withAnnexOptions [jsonOptions] $ 	command "setpresentkey" SectionPlumbing 		"change records of where key is present" 		(paramPair paramKey (paramPair paramUUID "[1|0]"))
Command/Smudge.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Smudge where  import Command@@ -142,7 +144,7 @@ 		Right Nothing -> notpointer 		Left InvalidAppendedPointerFile -> do 			toplevelWarning False $-				"The file \"" ++ fromRawFilePath file ++ "\" looks like git-annex pointer file that has had other content appended to it"+				"The file " <> QuotedPath file <> " looks like git-annex pointer file that has had other content appended to it" 			notpointer  	notpointer = inRepo (Git.Ref.fileRef file) >>= \case@@ -191,7 +193,7 @@ 	postingest (Just k, _) = do 		logStatus k InfoPresent 		return k-	postingest _ = error "could not add file to the annex"+	postingest _ = giveup "could not add file to the annex"  	cfg = LockDownConfig 		{ lockingFile = False@@ -329,5 +331,5 @@ 					else Database.Keys.addInodeCaches k [ic] 			Nothing -> liftIO (isPointerFile f) >>= \case 				Just k' | k' == k -> toplevelWarning False $-					"unable to populate worktree file " ++ fromRawFilePath f+					"unable to populate worktree file " <> QuotedPath f 				_ -> noop
Command/Status.hs view
@@ -8,9 +8,12 @@ module Command.Status where  import Command+import qualified Annex import Git.Status import Git.FilePath +import Data.ByteString.Char8 as B8+ cmd :: Command cmd = notBareRepo $ noCommit $ noMessages $ 	withAnnexOptions [jsonOptions] $@@ -61,6 +64,8 @@ displayStatus s = do 	let c = statusChar s 	absf <- fromRepo $ fromTopFilePath (statusFile s)-	f <- liftIO $ fromRawFilePath <$> relPathCwdToFile absf-	unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $-		liftIO $ putStrLn $ [c] ++ " " ++ f+	f <- liftIO $ relPathCwdToFile absf+	qp <- coreQuotePath <$> Annex.getGitConfig+	unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", fromRawFilePath f)]) $+		liftIO $ B8.putStrLn $ quote qp $+			UnquotedString (c : " ") <> QuotedPath f
Command/Sync.hs view
@@ -11,6 +11,8 @@  module Command.Sync ( 	cmd,+	seek,+	seek', 	CurrBranch, 	mergeConfig, 	merge,@@ -23,8 +25,10 @@ 	updateBranch, 	updateBranches, 	seekExportContent,+	optParser, 	parseUnrelatedHistoriesOption, 	SyncOptions(..),+	OperationMode(..), ) where  import Command@@ -73,6 +77,7 @@ import Annex.Import import Annex.CheckIgnore import Types.FileMatcher+import Types.GitConfig import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse@@ -88,8 +93,11 @@ cmd = withAnnexOptions [jobsOption, backendOption] $ 	command "sync" SectionCommon  		"synchronize local repository with remotes"-		(paramRepeating paramRemote) (seek <--< optParser)+		(paramRepeating paramRemote) (seek <--< optParser SyncMode) +data OperationMode = SyncMode | PullMode | PushMode | AssistMode+	deriving (Eq, Show)+ data SyncOptions = SyncOptions 	{ syncWith :: CmdParams 	, onlyAnnexOption :: Bool@@ -99,13 +107,14 @@ 	, messageOption :: Maybe String 	, pullOption :: Bool 	, pushOption :: Bool-	, contentOption :: Bool-	, noContentOption :: Bool+	, contentOption :: Maybe Bool+	, noContentOption :: Maybe Bool 	, contentOfOption :: [FilePath] 	, cleanupOption :: Bool 	, keyOptions :: Maybe KeyOptions 	, resolveMergeOverride :: Bool 	, allowUnrelatedHistories :: Bool+	, operationMode :: OperationMode 	}  instance Default SyncOptions where@@ -118,17 +127,18 @@ 		, messageOption = Nothing 		, pullOption = False 		, pushOption = False-		, contentOption = False-		, noContentOption = False+		, contentOption = Just False+		, noContentOption = Just False 		, contentOfOption = [] 		, cleanupOption = False 		, keyOptions = Nothing 		, resolveMergeOverride = False 		, allowUnrelatedHistories = False+		, operationMode = SyncMode 		} -optParser :: CmdParamsDesc -> Parser SyncOptions-optParser desc = SyncOptions+optParser :: OperationMode -> CmdParamsDesc -> Parser SyncOptions+optParser mode desc = SyncOptions 	<$> (many $ argument str 		( metavar desc 		<> completeRemotes@@ -136,53 +146,75 @@ 	<*> switch  		( long "only-annex" 		<> short 'a'-		<> help "only sync git-annex branch and annexed file contents"+		<> help "do not operate on git branches" 		) 	<*> switch  		( long "not-only-annex"-		<> help "sync git branches as well as annex"-		)-	<*> switch-		( long "commit"-		<> help "commit changes to git"+		<> help "operate on git branches as well as annex" 		)-	<*> switch+	<*> case mode of+		SyncMode -> switch+			( long "commit"+			<> help "commit changes to git"+			)+		PushMode -> pure False+		PullMode -> pure False+		AssistMode -> pure True+	<*> unlessmode [SyncMode] True (switch 		( long "no-commit" 		<> help "avoid git commit" -		)-	<*> optional (strOption+		))+	<*> unlessmode [SyncMode, AssistMode] Nothing (optional (strOption 		( long "message" <> short 'm' <> metavar "MSG" 		<> help "commit message"-		))-	<*> invertableSwitch "pull" True-		( help "avoid git pulls from remotes" -		)-	<*> invertableSwitch "push" True-		( help "avoid git pushes to remotes" -		)-	<*> switch +		)))+	<*> case mode of+		SyncMode -> invertableSwitch "pull" True+			( help "avoid git pulls from remotes" +			)+		PullMode -> pure True+		PushMode -> pure False+		AssistMode -> pure True+	<*> case mode of+		SyncMode -> invertableSwitch "push" True+			( help "avoid git pushes to remotes" +			)+		PullMode -> pure False+		PushMode -> pure True+		AssistMode -> pure True+	<*> optional (flag' True  		( long "content" 		<> help "transfer annexed file contents" -		)-	<*> switch+		))+	<*> 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 		))-	<*> switch+	<*> whenmode [PullMode] False (switch 		( long "cleanup"-		<> help "remove synced/ branches from previous sync"-		)+		<> help "remove synced/ branches"+		)) 	<*> optional parseAllOption-	<*> invertableSwitch "resolvemerge" True+	<*> whenmode [PushMode] False (invertableSwitch "resolvemerge" True 		( help "do not automatically resolve merge conflicts"-		)-	<*> parseUnrelatedHistoriesOption+		))+	<*> whenmode [PushMode] False+		parseUnrelatedHistoriesOption+	<*> pure mode+  where+	whenmode m v a+		| mode `elem` m = pure v+		| otherwise = a+	unlessmode m v a+		| mode `elem` m = a+		| otherwise = pure v  parseUnrelatedHistoriesOption :: Parser Bool parseUnrelatedHistoriesOption = @@ -209,12 +241,16 @@ 		<*> pure (keyOptions v) 		<*> pure (resolveMergeOverride v) 		<*> pure (allowUnrelatedHistories v)+		<*> pure (operationMode v)  seek :: SyncOptions -> CommandSeek seek o = do+	warnSyncContentTransition o+	 	prepMerge-	startConcurrency transferStages (seek' o) 	+	startConcurrency transferStages (seek' o)+ seek' :: SyncOptions -> CommandSeek seek' o = do 	let withbranch a = a =<< getCurrentBranch@@ -241,7 +277,7 @@ 				[ [ commit o ] 				, [ withbranch (mergeLocal mc o) ] 				, map (withbranch . pullRemote o mc) gitremotes-				,  [ mergeAnnex ]+				, [ mergeAnnex ] 				] 			 			content <- shouldSyncContent o@@ -259,13 +295,16 @@ 					seekExportContent (Just o) 						(filter isExport contentremotes) -				-- Sync content with remotes, but not with-				-- export or import remotes, which handle content-				-- syncing as part of export and import.+				-- Sync content with remotes, including+				-- importing from import remotes (since+				-- importing only downloads new files not+				-- old files)+				let shouldsynccontent r+					| isExport r && not (isImport r) = False+					| otherwise = True 				syncedcontent <- withbranch $-					seekSyncContent o $ filter-						(\r -> not (isExport r || isImport r))-						contentremotes+					seekSyncContent o+						(filter shouldsynccontent contentremotes)  				-- Transferring content can take a while, 				-- and other changes can be pushed to the@@ -392,7 +431,7 @@ 	needMerge currbranch branch >>= \case 		Nothing -> stop 		Just syncbranch -> do-			let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch)+			let ai = ActionItemOther (Just $ UnquotedString $ Git.Ref.describe syncbranch) 			let si = SeekInput [] 			starting "merge" ai si $ 				next $ merge currbranch mergeconfig o Git.Branch.ManualCommit syncbranch@@ -400,10 +439,10 @@ 	Just branch -> needMerge currbranch branch >>= \case 		Nothing -> stop 		Just syncbranch -> do-			let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch)+			let ai = ActionItemOther (Just $ UnquotedString $ Git.Ref.describe syncbranch) 			let si = SeekInput [] 			starting "merge" ai si $ do-				warning $ "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 " ++ Git.fromRef syncbranch ++ " into it." 				next $ return False 	Nothing -> stop @@ -513,7 +552,7 @@ 				, Just $ Param $ Remote.name remote 				] ++ map Param bs 	wantpull = remoteAnnexPull (Remote.gitconfig remote)-	ai = ActionItemOther (Just (Remote.name remote))+	ai = ActionItemOther (Just (UnquotedString (Remote.name remote))) 	si = SeekInput []  importRemote :: Bool -> SyncOptions -> Remote -> CurrBranch -> CommandSeek@@ -533,7 +572,7 @@ 					-- mergeing it. 					mc <- mergeConfig True 					void $ mergeRemote remote currbranch mc o-				else warning $ "Cannot import from " ++ Remote.name remote ++ " when not syncing content."+				else warning $ UnquotedString $ "Cannot import from " ++ Remote.name remote ++ " when not syncing content."   where 	wantpull = remoteAnnexPull (Remote.gitconfig remote) @@ -550,16 +589,16 @@ 	| otherwise = void $ includeCommandAction $ starting "list" ai si $ 		Command.Import.listContents' remote ImportTree (CheckGitIgnore False) go   where-	go (Just importable) = importKeys remote ImportTree False True importable >>= \case-		Just importablekeys -> do-			(_imported, updatestate) <- recordImportTree remote ImportTree importablekeys+	go (Just importable) = importChanges remote ImportTree False True importable >>= \case+		ImportFinished imported -> do+			(_t, updatestate) <- recordImportTree remote ImportTree imported 			next $ do 				updatestate 				return True-		Nothing -> next $ return False+		ImportUnfinished -> next $ return False 	go Nothing = next $ return True -- unchanged from before -	ai = ActionItemOther (Just (Remote.name remote))+	ai = ActionItemOther (Just (UnquotedString (Remote.name remote))) 	si = SeekInput [] 	 	wantpull = remoteAnnexPull (Remote.gitconfig remote)@@ -604,10 +643,10 @@ 			if ok 				then postpushupdate repo 				else do-					warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]+					warning $ UnquotedString $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] 					return ok   where-	ai = ActionItemOther (Just (Remote.name remote))+	ai = ActionItemOther (Just (UnquotedString (Remote.name remote))) 	si = SeekInput [] 	gc = Remote.gitconfig remote 	needpush mainbranch@@ -794,7 +833,12 @@ 		in seekFiltered (const (pure True)) filterer $ 			seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l  -	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles $+		case operationMode o of+			SyncMode -> "sync"+			PullMode -> "pull"+			PushMode -> "push"+			AssistMode -> "assist"  	gofile bloom mvar _ f k =  		go (Right bloom) mvar (AssociatedFile (Just f)) k@@ -805,7 +849,7 @@ 	go ebloom mvar af k = do 		let ai = OnlyActionOn k (ActionItemKey k) 		startingNoMessage ai $ do-			whenM (syncFile ebloom rs af k) $+			whenM (syncFile o ebloom rs af k) $ 				void $ liftIO $ tryPutMVar mvar () 			next $ return True @@ -828,8 +872,8 @@  -  - Returns True if any file transfers were made.  -}-syncFile :: Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool-syncFile ebloom rs af k = do+syncFile :: SyncOptions -> Either (Maybe (Bloom Key)) (Key -> Annex ()) -> [Remote] -> AssociatedFile -> Key -> Annex Bool+syncFile o ebloom rs af k = do 	inhere <- inAnnex k 	locs <- map Remote.uuid <$> Remote.keyPossibilities k 	let (have, lack) = partition (\r -> Remote.uuid r `elem` locs) rs@@ -866,7 +910,8 @@ 	return (got || not (null putrs))   where 	wantget have inhere = allM id -		[ pure (not $ null have)+		[ pure (pullOption o)+		, pure (not $ null have) 		, pure (not inhere) 		, wantGet True (Just k) af 		]@@ -879,7 +924,9 @@ 			next $ return True  	wantput r+		| pushOption o == False = return False 		| Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False+		| isExport r = return False 		| isThirdPartyPopulated r = return False 		| otherwise = wantGetBy True (Just k) af (Remote.uuid r) 	handleput lack inhere@@ -912,7 +959,7 @@ seekExportContent o rs (currbranch, _) = or <$> forM rs go   where 	go r-		| not (maybe True pullOption o) = return False+		| not (maybe True pushOption o) = return False 		| not (remoteAnnexPush (Remote.gitconfig r)) = return False 		| otherwise = bracket 			(Export.openDb (Remote.uuid r))@@ -948,14 +995,14 @@ 	warncannotupdateexport r mtb exported currb = case mtb of 		Nothing -> inRepo (Git.Ref.tree currb) >>= \case 			Just currt | not (any (== currt) (exportedTreeishes exported)) ->-				showLongNote $ unwords+				showLongNote $ UnquotedString $ unwords 					[ notupdating 					, "to reflect changes to the tree, because export" 					, "tracking is not enabled. " 					, "(Set " ++ gitconfig ++ " to enable it.)" 					] 			_ -> noop-		Just b -> showLongNote $ unwords+		Just b -> showLongNote $ UnquotedString $ unwords 			[ notupdating 			, "because " ++ Git.fromRef b ++ " does not exist." 			, "(As configured by " ++ gitconfig ++ ")"@@ -1003,14 +1050,43 @@ 				Git.Ref.base $ Annex.Branch.name 			]   where-	ai = ActionItemOther (Just (Remote.name remote))+	ai = ActionItemOther (Just (UnquotedString (Remote.name remote))) 	si = SeekInput []  shouldSyncContent :: SyncOptions -> Annex Bool shouldSyncContent o-	| noContentOption o = pure False-	| contentOption o || not (null (contentOfOption o)) = pure True-	| otherwise = getGitConfigVal annexSyncContent <||> onlyAnnex o+	| fromMaybe False (noContentOption o) = pure False+	-- For git-annex pull and git-annex push and git-annex assist,+	-- annex.syncontent defaults to True unless set+	| operationMode o /= SyncMode = annexsynccontent True+	| fromMaybe False (contentOption o) || not (null (contentOfOption o)) = pure True+	-- For git-annex sync, +	-- annex.syncontent defaults to False unless set+	| otherwise = annexsynccontent False <||> onlyAnnex o+  where+	annexsynccontent d = +		getGitConfigVal' annexSyncContent >>= \case+			HasGlobalConfig (Just c) -> return c+			HasGitConfig (Just c) -> return c+			_ -> return d++-- Transition started May 2023, should wait until that has been in a Debian+-- stable release before completing the transition.+warnSyncContentTransition :: SyncOptions -> Annex ()+warnSyncContentTransition o+	| operationMode o /= SyncMode = noop+	| isJust (noContentOption o) || isJust (contentOption o) = noop+	| not (null (contentOfOption o)) = noop+	| otherwise = getGitConfigVal' annexSyncContent >>= \case+		HasGlobalConfig (Just _) -> noop+		HasGitConfig (Just _) -> noop+		_ -> showwarning+  where+	showwarning = earlyWarning $+		"git-annex sync will change default behavior to operate on"+		<> " --content in a future version of git-annex. Recommend"+		<> " you explicitly use --no-content (or -g) to prepare for"+		<> " that change. (Or you can configure annex.synccontent)"  notOnlyAnnex :: SyncOptions -> Annex Bool notOnlyAnnex o = not <$> onlyAnnex o
Command/TestRemote.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE RankNTypes, DeriveFunctor, PackageImports #-}+{-# LANGUAGE RankNTypes, DeriveFunctor, PackageImports, OverloadedStrings #-}  module Command.TestRemote where @@ -73,7 +73,7 @@ seek = commandAction . start   start :: TestRemoteOptions -> CommandStart-start o = starting "testremote" (ActionItemOther (Just (testRemote o))) si $ do+start o = starting "testremote" (ActionItemOther (Just (UnquotedString (testRemote o)))) si $ do 	fast <- Annex.getRead Annex.fast 	cache <- liftIO newRemoteVariantCache 	r <- either giveup (disableExportTree cache)@@ -84,7 +84,7 @@ 			else do 				showAction "generating test keys" 				mapM randKey (keySizes basesz fast)-		fs -> mapM (getReadonlyKey r) fs+		fs -> mapM (getReadonlyKey r . toRawFilePath) fs 	let r' = if null (testReadonlyFile o) 		then r 		else r { Remote.readonly = True }@@ -151,7 +151,7 @@  -- Variant of a remote with exporttree disabled. disableExportTree :: RemoteVariantCache -> Remote -> Annex Remote-disableExportTree cache r = maybe (error "failed disabling exportree") return +disableExportTree cache r = maybe (giveup "failed disabling exportree") return  		=<< adjustRemoteConfig cache r (M.delete exportTreeField)  -- Variant of a remote with exporttree enabled.@@ -441,15 +441,17 @@ 	_ <- moveAnnex k (AssociatedFile Nothing) (toRawFilePath f) 	return k -getReadonlyKey :: Remote -> FilePath -> Annex Key-getReadonlyKey r f = lookupKey (toRawFilePath f) >>= \case-	Nothing -> giveup $ f ++ " is not an annexed file"-	Just k -> do-		unlessM (inAnnex k) $-			giveup $ f ++ " does not have its content locally present, cannot test it"-		unlessM ((Remote.uuid r `elem`) <$> loggedLocations k) $-			giveup $ f ++ " is not stored in the remote being tested, cannot test it"-		return k+getReadonlyKey :: Remote -> RawFilePath -> Annex Key+getReadonlyKey r f = do+	qp <- coreQuotePath <$> Annex.getGitConfig+	lookupKey f >>= \case+		Nothing -> giveup $ decodeBS $ quote qp $ QuotedPath f <> " is not an annexed file"+		Just k -> do+			unlessM (inAnnex k) $+				giveup $ decodeBS $ quote qp $ QuotedPath f <> " does not have its content locally present, cannot test it"+			unlessM ((Remote.uuid r `elem`) <$> loggedLocations k) $+				giveup $ decodeBS $ quote qp $ QuotedPath f <> " is not stored in the remote being tested, cannot test it"+			return k  runBool :: Monad m => m () -> m Bool runBool a = do
Command/TransferKey.hs view
@@ -57,7 +57,7 @@ 				Remote.logStatus remote key InfoPresent 				return True 			Left e -> do-				warning (show e)+				warning (UnquotedString (show e)) 				return False  fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform@@ -67,7 +67,7 @@ 			tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case 				Right v -> return (True, v)	 				Left e -> do-					warning (show e)+					warning (UnquotedString (show e)) 					return (False, UnVerified)   where 	vc = RemoteVerify remote
Command/TransferKeys.hs view
@@ -43,7 +43,7 @@ 			upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do 				tryNonAsync (Remote.storeKey remote key file p) >>= \case 					Left e -> do-						warning (show e)+						warning (UnquotedString (show e)) 						return False 					Right () -> do 						Remote.logStatus remote key InfoPresent@@ -53,7 +53,7 @@ 				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case 						Left e -> do-							warning (show e)+							warning (UnquotedString (show e)) 							return (False, UnVerified) 						Right v -> return (True, v) 					-- Make sure we get the current@@ -83,7 +83,7 @@ 		go rest 	go [] = noop 	go [""] = noop-	go v = error $ "transferkeys protocol error: " ++ show v+	go v = giveup $ "transferkeys protocol error: " ++ show v  	readrequests = liftIO $ split fieldSep <$> hGetContents readh 	sendresult b = liftIO $ do
Command/Transferrer.hs view
@@ -64,7 +64,7 @@ 			upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do 				tryNonAsync (Remote.storeKey remote key file p) >>= \case 					Left e -> do-						warning (show e)+						warning (UnquotedString (show e)) 						return False 					Right () -> do 						Remote.logStatus remote key InfoPresent@@ -75,7 +75,7 @@ 				logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do 					r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case 						Left e -> do-							warning (show e)+							warning (UnquotedString (show e)) 							return (False, UnVerified) 						Right v -> return (True, v) 					-- Make sure we get the current
Command/Trust.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -17,8 +17,9 @@ import qualified Data.Set as S  cmd :: Command-cmd = command "trust" SectionSetup "trust a repository"-	(paramRepeating paramRepository) (withParams seek)+cmd = withAnnexOptions [jsonOptions] $+	command "trust" SectionSetup "trust a repository"+		(paramRepeating paramRepository) (withParams seek)  seek :: CmdParams -> CommandSeek seek = trustCommand "trust" Trusted@@ -30,7 +31,7 @@ 	start name = do 		u <- Remote.nameToUUID name 		let si = SeekInput [name]-		starting c (ActionItemOther (Just name)) si (perform name u)+		starting c (ActionItemUUID u (UnquotedString name)) si (perform name u) 	perform name uuid = do 		when (level >= Trusted) $ 			unlessM (Annex.getRead Annex.force) $@@ -40,7 +41,7 @@ 			groupSet uuid S.empty 		l <- lookupTrust uuid 		when (l /= level) $-			warning $ "This remote's trust level is overridden to " ++ showTrustLevel l ++ "."+			warning $ UnquotedString $ "This remote's trust level is overridden to " ++ showTrustLevel l ++ "." 		next $ return True  trustedNeedsForce :: String -> String
Command/Unannex.hs view
@@ -22,7 +22,7 @@ import System.PosixCompat.Files (linkCount)  cmd :: Command-cmd = withAnnexOptions [annexedMatchingOptions] $+cmd = withAnnexOptions [jsonOptions, annexedMatchingOptions] $ 	command "unannex" SectionUtility 		"undo accidental add command" 		paramPaths (withParams seek)@@ -30,7 +30,7 @@ seek :: CmdParams -> CommandSeek seek ps = withFilesInGitAnnex ww (seeker False) =<< workTreeItems ww ps   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "unannex"  seeker :: Bool -> AnnexedFileSeeker seeker fast = AnnexedFileSeeker
Command/Undo.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.Undo where  import Command@@ -12,6 +14,7 @@ import Git.FilePath import Git.UpdateIndex import Git.Sha+import qualified Annex import qualified Git.LsFiles as LsFiles import qualified Git.Command as Git import qualified Git.Branch@@ -19,7 +22,7 @@ import qualified Utility.RawFilePath as R  cmd :: Command-cmd = notBareRepo $+cmd = notBareRepo $ withAnnexOptions [jsonOptions] $ 	command "undo" SectionCommon  		"undo last change to a file or directory" 		paramPaths (withParams seek)@@ -29,8 +32,11 @@ 	-- Safety first; avoid any undo that would touch files that are not 	-- in the index. 	(fs, cleanup) <- inRepo $ LsFiles.notInRepo [] False (map toRawFilePath ps)-	unless (null fs) $-		giveup $ "Cannot undo changes to files that are not checked into git: " ++ unwords (map fromRawFilePath fs)+	unless (null fs) $ do+		qp <- coreQuotePath <$> Annex.getGitConfig+		giveup $ decodeBS $ quote qp $ +			"Cannot undo changes to files that are not checked into git: "+				<> quotedPaths fs 	void $ liftIO $ cleanup  	-- Committing staged changes before undo allows later@@ -45,7 +51,7 @@ start p = starting "undo" ai si $ 	perform p   where-	ai = ActionItemOther (Just p)+	ai = ActionItemOther (Just (QuotedPath (toRawFilePath p))) 	si = SeekInput [p]  perform :: FilePath -> CommandPerform
Command/Ungroup.hs view
@@ -24,8 +24,9 @@ start :: [String] -> CommandStart start (name:g:[]) = do 	u <- Remote.nameToUUID name-	starting "ungroup" (ActionItemOther (Just name)) (SeekInput [name, g]) $-		perform u (toGroup g)+	starting "ungroup" (ActionItemOther (Just (UnquotedString name))) +		(SeekInput [name, g]) $+			perform u (toGroup g) start _ = giveup "Specify a repository and a group."  perform :: UUID -> Group -> CommandPerform
Command/Uninit.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -11,6 +11,7 @@ import qualified Git import qualified Git.Command import qualified Git.Ref+import qualified Git.Branch import qualified Command.Unannex import qualified Annex.Branch import qualified Annex.Queue@@ -23,23 +24,59 @@ import qualified Utility.RawFilePath as R  import System.PosixCompat.Files (linkCount)+import Control.Concurrent.STM  cmd :: Command-cmd = addCheck check $ +cmd = withAnnexOptions [jsonOptions] $ 	command "uninit" SectionUtility 		"de-initialize git-annex and clean out repository"-		paramPaths (withParams seek)+		paramNothing (withParams seek) -check :: Annex ()-check = do-	b <- current_branch-	when (b == Just Annex.Branch.name) $ giveup $-		"cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out"-	top <- fromRepo Git.repoPath-	currdir <- liftIO R.getCurrentDirectory-	whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $-		giveup "can only run uninit from the top of the git repository"+seek :: CmdParams -> CommandSeek+seek = withNothing $ do+	ok <- liftIO $ newTVarIO False+	let checkok v a = do+		liftIO $ atomically $ writeTVar ok v+		() <- a	+		liftIO $ atomically $ readTVar ok+	let recordok = do+		liftIO $ atomically $ writeTVar ok True+		return True+	let recordnotok = liftIO $ atomically $ writeTVar ok False++	whenM (checkok False $ commandAction $ checkCanUninit recordok) $ do+		let symlinksok = checkok True $ withFilesNotInGit+			(CheckGitIgnore False)+			(WarnUnmatchWorkTreeItems "uninit")+			(checksymlinks recordnotok)+			=<< workTreeItems ww []+		whenM symlinksok $ do+			withFilesInGitAnnex ww (Command.Unannex.seeker True)+				=<< workTreeItems ww []+			whenM (checkok False $ commandAction $ removeAnnexDir recordok) $ +				commandAction completeUnitialize   where+	ww = WarnUnmatchLsFiles "uninit"+	checksymlinks recordnotok (_, f) = +		commandAction $ lookupKey f >>= \case+			Nothing -> stop+			Just k -> startCheckIncomplete recordnotok f k++checkCanUninit :: CommandCleanup -> CommandStart+checkCanUninit recordok = +	starting "uninit check" (ActionItemOther Nothing) (SeekInput []) $ do+		runchecks+		next recordok+  where+	runchecks = do+		b <- current_branch+		when (b == Just Annex.Branch.name) $ giveup $+			"cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out"+		top <- fromRepo Git.repoPath+		currdir <- liftIO R.getCurrentDirectory+		whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $+			giveup "can only run uninit from the top of the git repository"+	 	current_branch =  		ifM (inRepo Git.Ref.headExists) 			( Just . Git.Ref . encodeBS . Prelude.head . lines . decodeBS <$> revhead@@ -48,65 +85,49 @@ 	revhead = inRepo $ Git.Command.pipeReadStrict 		[Param "rev-parse", Param "--abbrev-ref", Param "HEAD"] -seek :: CmdParams -> CommandSeek-seek ps = do-	l <- workTreeItems ww ps-	withFilesNotInGit-		(CheckGitIgnore False)-		WarnUnmatchWorkTreeItems-		checksymlinks-		l-	withFilesInGitAnnex ww (Command.Unannex.seeker True) l-	finish-  where-	ww = WarnUnmatchLsFiles-	checksymlinks (_, f) = -		commandAction $ lookupKey f >>= \case-			Nothing -> stop-			Just k -> startCheckIncomplete (fromRawFilePath f) k- {- git annex symlinks that are not checked into git could be left by an  - interrupted add. -}-startCheckIncomplete :: FilePath -> Key -> CommandStart-startCheckIncomplete file _ = giveup $ unlines-	[ file ++ " points to annexed content, but is not checked into git."-	, "Perhaps this was left behind by an interrupted git annex add?"-	, "Not continuing with uninit; either delete or git annex add the file and retry."-	]+startCheckIncomplete :: Annex () -> RawFilePath -> Key -> CommandStart+startCheckIncomplete recordnotok file key =+	starting "uninit check" (mkActionItem (file, key)) (SeekInput []) $ do+		recordnotok+		giveup $ unlines err+  where+	err =+		[ fromRawFilePath file ++ " points to annexed content, but is not checked into git."+		, "Perhaps this was left behind by an interrupted git annex add?"+		, "Not continuing with uninit; either delete or git annex add the file and retry."+		] -finish :: Annex ()-finish = do+removeAnnexDir :: CommandCleanup -> CommandStart+removeAnnexDir recordok = do 	Annex.Queue.flush 	annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir 	annexobjectdir <- fromRepo gitAnnexObjectDir-	leftovers <- removeUnannexed =<< listKeys InAnnex-	prepareRemoveAnnexDir annexdir-	if null leftovers-		then liftIO $ removeDirectoryRecursive annexdir-		else giveup $ unlines-			[ "Not fully uninitialized"-			, "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir-			, "This may include deleted files, or old versions of modified files."-			, ""-			, "If you don't care about preserving the data, just delete the"-			, "directory."-			, ""-			, "Or, you can move it to another location, in case it turns out"-			, "something in there is important."-			, ""-			, "Or, you can run `git annex unused` followed by `git annex dropunused`"-			, "to remove data that is not used by any tag or branch, which might"-			, "take care of all the data."-			, ""-			, "Then run `git annex uninit` again to finish."-			]-	uninitialize-	-- avoid normal shutdown-	saveState False-	whenM (inRepo $ Git.Ref.exists Annex.Branch.fullname) $-		inRepo $ Git.Command.run-			[Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]-	liftIO exitSuccess+	starting ("uninit objects") (ActionItemOther Nothing) (SeekInput []) $ do+		leftovers <- removeUnannexed =<< listKeys InAnnex+		prepareRemoveAnnexDir annexdir+		if null leftovers+			then do+				liftIO $ removeDirectoryRecursive annexdir+				next recordok+			else giveup $ unlines+				[ "Not fully uninitialized"+				, "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir+				, "This may include deleted files, or old versions of modified files."+				, ""+				, "If you don't care about preserving the data, just delete the"+				, "directory."+				, ""+				, "Or, you can move it to another location, in case it turns out"+				, "something in there is important."+				, ""+				, "Or, you can run `git annex unused` followed by `git annex dropunused`"+				, "to remove data that is not used by any tag or branch, which might"+				, "take care of all the data."+				, ""+				, "Then run `git annex uninit` again to finish."+				]  {- Turn on write bits in all remaining files in the annex directory, in  - preparation for removal. @@ -140,3 +161,17 @@ 	enoughlinks f = catchBoolIO $ do 		s <- R.getFileStatus f 		return $ linkCount s > 1++completeUnitialize :: CommandStart+completeUnitialize =+	starting ("uninit finish") (ActionItemOther Nothing) (SeekInput []) $ do+		uninitialize+		removeAnnexBranch+		next $ return True++removeAnnexBranch :: Annex ()+removeAnnexBranch = do+	-- avoid normal shutdown commit to the branch+	saveState False+	whenM (inRepo $ Git.Ref.exists Annex.Branch.fullname) $+		inRepo $ Git.Branch.delete Annex.Branch.name
Command/Unlock.hs view
@@ -33,7 +33,7 @@ seek :: CmdParams -> CommandSeek seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "unlock" 	seeker = AnnexedFileSeeker 		{ startAction = start 		, checkContentPresent = Nothing@@ -58,7 +58,7 @@ 				case r of 					LinkAnnexOk -> return () 					LinkAnnexNoop -> return ()-					LinkAnnexFailed -> error "unlock failed"+					LinkAnnexFailed -> giveup "unlock failed" 			, liftIO $ writePointerFile (toRawFilePath tmp) key destmode 			) 		withTSDelta (liftIO . genInodeCache (toRawFilePath tmp))
Command/Untrust.hs view
@@ -12,8 +12,9 @@ import Command.Trust (trustCommand)  cmd :: Command-cmd = command "untrust" SectionSetup "do not trust a repository"-	(paramRepeating paramRepository) (withParams seek)+cmd = withAnnexOptions [jsonOptions] $+	command "untrust" SectionSetup "do not trust a repository"+		(paramRepeating paramRepository) (withParams seek)  seek :: CmdParams -> CommandSeek seek = trustCommand "untrust" UnTrusted
Command/Unused.hs view
@@ -38,11 +38,13 @@ import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T import Data.Char  cmd :: Command-cmd = command "unused" SectionMaintenance "look for unused file content"-	paramNothing (seek <$$> optParser)+cmd = withAnnexOptions [jsonOptions] $+	command "unused" SectionMaintenance "look for unused file content"+		paramNothing (seek <$$> optParser)  data UnusedOptions = UnusedOptions 	{ fromRemote :: Maybe RemoteName@@ -73,7 +75,7 @@ 		Just "." -> (".", checkUnused refspec) 		Just "here" -> (".", checkUnused refspec) 		Just n -> (n, checkRemoteUnused n refspec)-	starting "unused" (ActionItemOther (Just name)) (SeekInput []) perform+	starting "unused" (ActionItemOther (Just (UnquotedString name))) (SeekInput []) perform  checkUnused :: RefSpec -> CommandPerform checkUnused refspec = chain 0@@ -105,12 +107,16 @@ 		Just ks -> excludeReferenced refspec ks 		Nothing -> giveup "This repository is read-only." -check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int-check file msg a c = do+check :: String -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int+check fileprefix msg a c = do 	l <- a 	let unusedlist = number c l-	unless (null l) $ showLongNote $ msg unusedlist-	updateUnusedLog (toRawFilePath file) (M.fromList unusedlist)+	unless (null l) $+		showLongNote $ UnquotedString $ msg unusedlist+	maybeAddJSONField+		((if null fileprefix then "unused" else fileprefix) ++ "-list")+		(M.fromList $ map (\(n,  k) -> (T.pack (show n), serializeKey k)) unusedlist)+	updateUnusedLog (toRawFilePath fileprefix) (M.fromList unusedlist) 	return $ c + length l  number :: Int -> [a] -> [(Int, a)]@@ -249,7 +255,7 @@  - differ from those referenced in the index. -} withKeysReferencedDiffGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex () withKeysReferencedDiffGitRef a ref = do-	showAction $ "checking " ++ Git.Ref.describe ref+	showAction $ UnquotedString $ "checking " ++ Git.Ref.describe ref 	withKeysReferencedDiff a 		(inRepo $ DiffTree.diffIndex ref) 		DiffTree.srcsha@@ -321,12 +327,12 @@  {- Seek action for unused content. Finds the number in the maps, and  - calls one of 3 actions, depending on the type of unused file. -}-startUnused :: String-	-> (Key -> CommandPerform)-	-> (Key -> CommandPerform) -	-> (Key -> CommandPerform)+startUnused+	:: (Int -> Key -> CommandStart)+	-> (Int -> Key -> CommandStart) +	-> (Int -> Key -> CommandStart) 	-> UnusedMaps -> Int -> CommandStart-startUnused message unused badunused tmpunused maps n = search+startUnused unused badunused tmpunused maps n = search 	[ (unusedMap maps, unused) 	, (unusedBadMap maps, badunused) 	, (unusedTmpMap maps, tmpunused)@@ -336,7 +342,4 @@ 	search ((m, a):rest) = 		case M.lookup n m of 			Nothing -> search rest-			Just key -> starting message-				(ActionItemOther $ Just $ show n)-				(SeekInput [])-				(a key)+			Just key -> a n key
Command/Upgrade.hs view
@@ -20,6 +20,7 @@ 	repoExists $ 	-- avoid upgrading repo out from under daemon 	noDaemonRunning $+	withAnnexOptions [jsonOptions] $ 	command "upgrade" SectionMaintenance "upgrade repository" 		paramNothing (seek <$$> optParser)
Command/VAdd.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.VAdd where  import Command
Command/VCycle.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.VCycle where  import Command
Command/VPop.hs view
@@ -48,6 +48,6 @@  	num = fromMaybe 1 $ readish =<< headMaybe ps  	-	ai = ActionItemOther (Just $ show num)+	ai = ActionItemOther (Just $ UnquotedString $ show num) 	 	si = SeekInput ps
Command/Version.hs view
@@ -78,5 +78,6 @@ 	putStr BuildInfo.packageversion 	hFlush stdout -- no newline, so flush +-- Ignore failure to write so that this command can eg be piped to head. vinfo :: String -> String -> IO ()-vinfo k v = putStrLn $ k ++ ": " ++ v+vinfo k v = void $ tryIO $ putStrLn $ k ++ ": " ++ v
Command/View.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.View where  import Command@@ -118,7 +120,7 @@ 		forM_ l (removeemptydir top) 		liftIO $ void cleanup 		unlessM (liftIO $ doesDirectoryExist here) $ do-			showLongNote (cwdmissing (fromRawFilePath top))+			showLongNote $ UnquotedString $ cwdmissing (fromRawFilePath top) 	return ok   where 	removeemptydir top d = do
Command/Wanted.hs view
@@ -11,6 +11,7 @@ import qualified Remote import Logs.PreferredContent import Types.StandardGroups+import Utility.SafeOutput  import qualified Data.Map as M @@ -39,7 +40,7 @@ 	start ps@(rname:expr:[]) = do 		u <- Remote.nameToUUID rname 		let si = SeekInput ps-		let ai = ActionItemOther (Just rname)+		let ai = ActionItemOther (Just (UnquotedString rname)) 		startingUsualMessages name ai si $ 			performSet setter expr u 	start _ = giveup "Specify a repository."@@ -47,7 +48,7 @@ performGet :: Ord a => Annex (M.Map a PreferredContentExpression) -> a -> CommandPerform performGet getter a = do 	m <- getter-	liftIO $ putStrLn $ fromMaybe "" $ M.lookup a m+	liftIO $ putStrLn $ safeOutput $ fromMaybe "" $ M.lookup a m 	next $ return True  performSet :: (a -> PreferredContentExpression -> Annex ()) -> String -> a -> CommandPerform
Command/Watch.hs view
@@ -14,7 +14,7 @@ cmd :: Command cmd = notBareRepo $ 	command "watch" SectionCommon -		"watch for changes and autocommit"+		"daemon to watch for changes and autocommit" 		paramNothing (seek <$$> const (parseDaemonOptions True))  seek :: DaemonOptions -> CommandSeek
Command/WhereUsed.hs view
@@ -5,13 +5,14 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Command.WhereUsed where  import Command import Git import Git.Sha import Git.FilePath-import qualified Git.Ref import qualified Git.Command import qualified Git.DiffTree as DiffTree import qualified Annex@@ -21,6 +22,7 @@  import Data.Char import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L  cmd :: Command@@ -55,10 +57,11 @@  start :: WhereUsedOptions -> (SeekInput, Key, ActionItem) -> CommandStart start o (_, key, _) = startingCustomOutput key $ do-	fs <- filterM stillassociated +	fs <- filterM stillassociated+		=<< mapM (liftIO . relPathCwdToFile) 		=<< mapM (fromRepo . fromTopFilePath) 		=<< getAssociatedFiles key-	liftIO $ forM_ fs $ display key . fromRawFilePath+	forM_ fs $ display key . QuotedPath  	when (historicalOption o && null fs) $ 		findHistorical key@@ -71,8 +74,11 @@ 		Just k | k == key -> return True 		_ -> return False -display :: Key -> String -> IO ()-display key loc = putStrLn (serializeKey key ++ " " ++ loc)+display :: Key -> StringContainingQuotedPath -> Annex ()+display key loc = do+	qp <- coreQuotePath <$> Annex.getGitConfig+	liftIO $ S8.putStrLn $ quote qp $+		UnquotedByteString (serializeKey' key) <> " " <> loc  findHistorical :: Key -> Annex () findHistorical key = do@@ -89,15 +95,15 @@ 		, Param "--tags=*" 		-- Output the commit hash 		, Param "--pretty=%H"-		] $ \h fs repo -> do-			commitsha <- getSha "log" (pure h)+		] $ \h fs -> do+			commitsha <- liftIO $ getSha "log" (pure h) 			commitdesc <- S.takeWhile (/= fromIntegral (ord '\n'))-				<$> Git.Command.pipeReadStrict+				<$> inRepo (Git.Command.pipeReadStrict 					[ Param "describe" 					, Param "--contains" 					, Param "--all" 					, Param (fromRef commitsha)-					] repo+					]) 			if S.null commitdesc 				then return False 				else process fs $@@ -108,27 +114,28 @@ 			[ Param "--walk-reflogs" 			-- Output the reflog selector 			, Param "--pretty=%gd"-			] $ \h fs _ -> process fs $+			] $ \h fs -> process fs $ 				displayreffile (Ref h)   where 	process fs a = or <$> forM fs a  	displayreffile r f = do-		let fref = Git.Ref.branchFileRef r f-		display key (fromRef fref)+		tf <- inRepo $ toTopFilePath f+		display key (descBranchFilePath (BranchFilePath r tf)) 		return True -searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Repo -> IO Bool) -> Annex Bool-searchLog key ps a = Annex.inRepo $ \repo -> do-	(output, cleanup) <- Git.Command.pipeNullSplit ps' repo+searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Annex Bool) -> Annex Bool+searchLog key ps a = do+	(output, cleanup) <- Annex.inRepo $ Git.Command.pipeNullSplit ps' 	found <- case output of 		(h:rest) -> do 			let diff = DiffTree.parseDiffRaw rest+			repo <- Annex.gitRepo 			let fs = map (flip fromTopFilePath repo . DiffTree.file) diff-			rfs <- mapM relPathCwdToFile fs-			a (L.toStrict h) rfs repo+			rfs <- liftIO $ mapM relPathCwdToFile fs+			a (L.toStrict h) rfs 		_ -> return False-	void cleanup+	liftIO $ void cleanup 	return found   where 	ps' =
Command/Whereis.hs view
@@ -17,7 +17,6 @@ import Annex.UUID import qualified Utility.Format import qualified Command.Find-import Types.ActionItem  import qualified Data.Map as M import qualified Data.Vector as V@@ -65,7 +64,7 @@ 		Batch fmt -> batchOnly (keyOptions o) (whereisFiles o) $ 			batchAnnexed fmt seeker (startKeys o m)   where-	ww = WarnUnmatchLsFiles+	ww = WarnUnmatchLsFiles "whereis"  start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> RawFilePath -> Key -> CommandStart start o remotemap si file key = @@ -88,12 +87,14 @@ 	case formatOption o of 		Nothing -> do 			let num = length safelocations-			showNote $ show num ++ " " ++ copiesplural num+			showNote $ UnquotedString $ show num ++ " " ++ copiesplural num 			pp <- ppwhereis "whereis" safelocations urls-			unless (null safelocations) $ showLongNote pp+			unless (null safelocations) $+				showLongNote (UnquotedString pp) 			pp' <- ppwhereis "untrusted" untrustedlocations urls-			unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp'-		+			unless (null untrustedlocations) $+				showLongNote $ UnquotedString $+					untrustedheader ++ pp' 			mapM_ (showRemoteUrls remotemap) urls 		Just formatter -> liftIO $ do 			let vs = Command.Find.formatVars key@@ -143,7 +144,7 @@ 		Just w -> tryNonAsync (w key) >>= \case 			Right l -> pure l 			Left e -> do-				warning $ unwords+				warning $ UnquotedString $ unwords 					[ "unable to query remote" 					, name remote 					, "for urls:"@@ -161,6 +162,6 @@ showRemoteUrls remotemap (uu, us) 	| null us = noop 	| otherwise = case M.lookup uu remotemap of-		Just r -> showLongNote $ +		Just r -> showLongNote $ UnquotedString $ 			unlines $ map (\u -> name r ++ ": " ++ u) us  		Nothing -> noop
Creds.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Creds ( 	module Types.Creds, 	CredPairStorage(..),@@ -150,13 +152,13 @@ 			writeCacheCredPair credpair storage  			return $ Just credpair-		_ -> error "bad creds"+		_ -> giveup "bad creds"  getRemoteCredPairFor :: String -> ParsedRemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair) getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage   where 	go Nothing = do-		warning $ missingCredPairFor this storage+		warning $ UnquotedString $ missingCredPairFor this storage 		return Nothing 	go (Just credpair) = return $ Just credpair
Crypto.hs view
@@ -73,7 +73,7 @@  cipherPassphrase :: Cipher -> String cipherPassphrase (Cipher c) = drop cipherBeginning c-cipherPassphrase (MacOnlyCipher _) = error "MAC-only cipher"+cipherPassphrase (MacOnlyCipher _) = giveup "MAC-only cipher"  cipherMac :: Cipher -> String cipherMac (Cipher c) = take cipherBeginning c
Database/Benchmark.hs view
@@ -44,7 +44,7 @@ 			] 		] #else-benchmarkDbs _ = error "not built with criterion, cannot benchmark"+benchmarkDbs _ = giveup "not built with criterion, cannot benchmark" #endif  #ifdef WITH_BENCHMARK
Database/ContentIdentifier.hs view
@@ -1,6 +1,6 @@ {- Sqlite database of ContentIdentifiers imported from special remotes.  -- - Copyright 2019 Joey Hess <id@joeyh.name>+ - Copyright 2019-2023 Joey Hess <id@joeyh.name>  -:  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -19,6 +19,7 @@  module Database.ContentIdentifier ( 	ContentIdentifierHandle,+	databaseIsEmpty, 	openDb, 	closeDb, 	flushDbQueue,@@ -57,14 +58,29 @@ import qualified System.FilePath.ByteString as P import qualified Data.Text as T -data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue+data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue Bool +databaseIsEmpty :: ContentIdentifierHandle -> Bool+databaseIsEmpty (ContentIdentifierHandle _ b) = b++-- Note on indexes: ContentIndentifiersKeyRemoteCidIndex etc are really+-- uniqueness constraints, which cause sqlite to automatically add indexes.+-- So when adding indexes, have to take care to only add ones that work as+-- uniqueness constraints. (Unfortunately persistent does not support indexes+-- that are not uniqueness constraints; +-- https://github.com/yesodweb/persistent/issues/109)+-- +-- ContentIndentifiersKeyRemoteCidIndex speeds up queries like +-- getContentIdentifiers, but it is not used for+-- getContentIdentifierKeys. ContentIndentifiersCidRemoteKeyIndex was+-- addedto speed that up. share [mkPersist sqlSettings, mkMigrate "migrateContentIdentifier"] [persistLowerCase| ContentIdentifiers   remote UUID   cid ContentIdentifier   key Key   ContentIndentifiersKeyRemoteCidIndex key remote cid+  ContentIndentifiersCidRemoteKeyIndex cid remote key -- The last git-annex branch tree sha that was used to update -- ContentIdentifiers AnnexBranch@@ -81,23 +97,22 @@ openDb = do 	dbdir <- calcRepo' gitAnnexContentIdentifierDbDir 	let db = dbdir P.</> "db"-	ifM (liftIO $ not <$> R.doesPathExist db)-		( initDb db $ void $ +	isnew <- liftIO $ not <$> R.doesPathExist db+	if isnew+		then initDb db $ void $  			runMigrationSilent migrateContentIdentifier-		-- Migrate from old version of database, which had-		-- an incorrect uniqueness constraint on the-		-- ContentIdentifiers table.-		, liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $+		-- Migrate from old versions of database, which had buggy+		-- and suboptimal uniqueness constraints.+		else liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $ 			runMigrationSilent migrateContentIdentifier-		) 	h <- liftIO $ H.openDbQueue db "content_identifiers"-	return $ ContentIdentifierHandle h+	return $ ContentIdentifierHandle h isnew  closeDb :: ContentIdentifierHandle -> Annex ()-closeDb (ContentIdentifierHandle h) = liftIO $ H.closeDbQueue h+closeDb (ContentIdentifierHandle h _) = liftIO $ H.closeDbQueue h  queueDb :: ContentIdentifierHandle -> SqlPersistM () -> IO ()-queueDb (ContentIdentifierHandle h) = H.queueDb h checkcommit+queueDb (ContentIdentifierHandle h _) = H.queueDb h checkcommit   where 	-- commit queue after 1000 changes 	checkcommit sz _lastcommittime@@ -105,7 +120,7 @@ 		| otherwise = return False  flushDbQueue :: ContentIdentifierHandle -> IO ()-flushDbQueue (ContentIdentifierHandle h) = H.flushDbQueue h+flushDbQueue (ContentIdentifierHandle h _) = H.flushDbQueue h  -- Be sure to also update the git-annex branch when using this. recordContentIdentifier :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> Key -> IO ()@@ -113,7 +128,7 @@ 	void $ insertUniqueFast $ ContentIdentifiers u cid k  getContentIdentifiers :: ContentIdentifierHandle -> RemoteStateHandle -> Key -> IO [ContentIdentifier]-getContentIdentifiers (ContentIdentifierHandle h) (RemoteStateHandle u) k = +getContentIdentifiers (ContentIdentifierHandle h _) (RemoteStateHandle u) k =  	H.queryDbQueue h $ do 		l <- selectList 			[ ContentIdentifiersKey ==. k@@ -122,7 +137,7 @@ 		return $ map (contentIdentifiersCid . entityVal) l  getContentIdentifierKeys :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> IO [Key]-getContentIdentifierKeys (ContentIdentifierHandle h) (RemoteStateHandle u) cid = +getContentIdentifierKeys (ContentIdentifierHandle h _) (RemoteStateHandle u) cid =  	H.queryDbQueue h $ do 		l <- selectList 			[ ContentIdentifiersCid ==. cid@@ -132,15 +147,15 @@  recordAnnexBranchTree :: ContentIdentifierHandle -> Sha -> IO () recordAnnexBranchTree h s = queueDb h $ do-        deleteWhere ([] :: [Filter AnnexBranch])-        void $ insertUniqueFast $ AnnexBranch $ toSSha s+	deleteWhere ([] :: [Filter AnnexBranch])+	void $ insertUniqueFast $ AnnexBranch $ toSSha s  getAnnexBranchTree :: ContentIdentifierHandle -> IO Sha-getAnnexBranchTree (ContentIdentifierHandle h) = H.queryDbQueue h $ do-        l <- selectList ([] :: [Filter AnnexBranch]) []-        case l of-                (s:[]) -> return $ fromSSha $ annexBranchTree $ entityVal s-                _ -> return emptyTree+getAnnexBranchTree (ContentIdentifierHandle h _) = H.queryDbQueue h $ do+	l <- selectList ([] :: [Filter AnnexBranch]) []+	case l of+		(s:[]) -> return $ fromSSha $ annexBranchTree $ entityVal s+		_ -> return emptyTree  {- Check if the git-annex branch has been updated and the database needs  - to be updated with any new content identifiers in it. -}@@ -153,8 +168,8 @@ 		_ -> return Nothing  {- The database should be locked for write when calling this. -}-updateFromLog :: ContentIdentifierHandle -> (Sha, Sha) -> Annex ()-updateFromLog db (oldtree, currtree) = do+updateFromLog :: ContentIdentifierHandle -> (Sha, Sha) -> Annex ContentIdentifierHandle+updateFromLog db@(ContentIdentifierHandle h _) (oldtree, currtree) = do 	(l, cleanup) <- inRepo $ 		DiffTree.diffTreeRecursive oldtree currtree 	mapM_ go l@@ -162,6 +177,7 @@ 	liftIO $ do 		recordAnnexBranchTree db currtree 		flushDbQueue db+	return (ContentIdentifierHandle h False)   where 	go ti = case extLogFileKey remoteContentIdentifierExt (getTopFilePath (DiffTree.file ti)) of 		Nothing -> return ()
Database/Handle.hs view
@@ -84,7 +84,7 @@ 		Right r -> either throwIO return r 		Left BlockedIndefinitelyOnMVar -> do 			err <- takeMVar errvar-			error $ "sqlite worker thread crashed: " ++ err+			giveup $ "sqlite worker thread crashed: " ++ err  {- Writes a change to the database.  -@@ -96,32 +96,36 @@  - process at least once each 30 seconds.  -} commitDb :: DbHandle -> SqlPersistM () -> IO ()-commitDb h@(DbHandle db _ _ _) wa = +commitDb h@(DbHandle db _ _ errvar) wa =  	robustly (commitDb' h wa) maxretries emptyDatabaseInodeCache   where 	robustly a retries ic = do 		r <- a 		case r of-			Right _ -> return ()-			Left err -> do+			Right (Right _) -> return ()+			Right (Left err) -> do 				threadDelay briefdelay 				retryHelper "write to" err maxretries db retries ic $  					robustly a+			Left BlockedIndefinitelyOnMVar -> do+				err <- takeMVar errvar+				giveup $ "sqlite worker thread crashed: " ++ err 	 	briefdelay = 100000 -- 1/10th second  	maxretries = 300 :: Int -- 30 seconds of briefdelay -commitDb' :: DbHandle -> SqlPersistM () -> IO (Either SomeException ())+commitDb' :: DbHandle -> SqlPersistM () -> IO (Either BlockedIndefinitelyOnMVar (Either SomeException ())) commitDb' (DbHandle _ _ jobs _) a = do 	debug "Database.Handle" "commitDb start" 	res <- newEmptyMVar 	putMVar jobs $ ChangeJob $ 		debugLocks $ liftIO . putMVar res =<< tryNonAsync a-	r <- debugLocks $ takeMVar res+	r <- debugLocks $ takeMVarSafe res 	case r of-		Right () -> debug "Database.Handle" "commitDb done"-		Left e -> debug "Database.Handle" ("commitDb failed: " ++ show e)+		Right (Right ()) -> debug "Database.Handle" "commitDb done"+		Right (Left e) -> debug "Database.Handle" ("commitDb failed: " ++ show e)+		Left BlockedIndefinitelyOnMVar -> debug "Database.Handle" ("commitDb BlockedIndefinitelyOnMVar")  	return r
Database/Init.hs view
@@ -10,10 +10,8 @@ module Database.Init where  import Annex.Common-import qualified Annex import Annex.Perms import Utility.FileMode-import Utility.Directory.Create import qualified Utility.RawFilePath as R  import Database.Persist.Sqlite@@ -35,14 +33,8 @@ 	let tmpdbdir = dbdir <> ".tmp" 	let tmpdb = tmpdbdir P.</> "db" 	let tdb = T.pack (fromRawFilePath tmpdb)-	gc <- Annex.getGitConfig-	top <- parentDir <$> fromRepo gitAnnexDir-	let tops = case annexDbDir gc of-		Just topdbdir -> [top, parentDir (parentDir topdbdir)]-		Nothing -> [top]-	liftIO $ do-		createDirectoryUnder tops tmpdbdir-		runSqliteInfo (enableWAL tdb) migration+	createAnnexDirectory tmpdbdir+	liftIO $ runSqliteInfo (enableWAL tdb) migration 	setAnnexDirPerm tmpdbdir 	-- Work around sqlite bug that prevents it from honoring 	-- less restrictive umasks.
Git.hs view
@@ -68,7 +68,7 @@ repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir-repoLocation Repo { location = Unknown } = error "unknown repoLocation"+repoLocation Repo { location = Unknown } = giveup "unknown repoLocation"  {- Path to a repository. For non-bare, this is the worktree, for bare,   - it's the gitdir, and for URL repositories, is the path on the remote@@ -78,8 +78,8 @@ repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir-repoPath Repo { location = Unknown } = error "unknown repoPath"-repoPath Repo { location = UnparseableUrl _u } = error "unknown repoPath"+repoPath Repo { location = Unknown } = giveup "unknown repoPath"+repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath"  repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d@@ -88,7 +88,7 @@ {- Path to a local repository's .git directory. -} localGitDir :: Repo -> RawFilePath localGitDir Repo { location = Local { gitdir = d } } = d-localGitDir _ = error "unknown localGitDir"+localGitDir _ = giveup "unknown localGitDir"  {- Some code needs to vary between URL and normal repos,  - or bare and non-bare, these functions help with that. -}@@ -129,7 +129,7 @@  assertLocal :: Repo -> a -> a assertLocal repo action-	| repoIsUrl repo = error $ unwords+	| repoIsUrl repo = giveup $ unwords 		[ "acting on non-local git repo" 		, repoDescribe repo 		, "not supported"
Git/CatFile.hs view
@@ -120,7 +120,7 @@ 			content <- readObjectContent from r 			return $ Just (content, sha, objtype) 		Just DNE -> return Nothing-		Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)+		Nothing -> giveup $ "unknown response from git cat-file " ++ show (header, object)   where 	-- Slow fallback path for filenames containing newlines. 	newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case@@ -144,7 +144,7 @@ 	eatchar expected = do 		c <- hGetChar h 		when (c /= expected) $-			error $ "missing " ++ (show expected) ++ " from git cat-file"+			giveup $ "missing " ++ (show expected) ++ " from git cat-file" readObjectContent _ DNE = error "internal"  {- Gets the size and type of an object, without reading its content. -}
Git/CheckAttr.hs view
@@ -54,7 +54,7 @@ 	getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of 			["unspecified"] -> "" : getvals l xs 			[v] -> v : getvals l xs-			_ -> error $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file+			_ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file  	send to = B.hPutStr to $ file' `B.snoc` 0 	receive c from = do
Git/Config.hs view
@@ -104,19 +104,23 @@ hRead :: Repo -> ConfigStyle -> Handle -> IO Repo hRead repo st h = do 	val <- S.hGetContents h-	store val st repo+	let c = parse val st+	debug (DebugSource "Git.Config") $ "git config read: " +++		show (map (\(k, v) -> (show k, map show v)) (M.toList c))+	storeParsed c repo  {- Stores a git config into a Repo, returning the new version of the Repo.  - The git config may be multiple lines, or a single line.  - Config settings can be updated incrementally.  -} store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo-store s st repo = do-	let c = parse s st-	updateLocation $ repo-		{ config = (M.map Prelude.head c) `M.union` config repo-		, fullconfig = M.unionWith (++) c (fullconfig repo)-		}+store s st = storeParsed (parse s st)++storeParsed :: M.Map ConfigKey [ConfigValue] -> Repo -> IO Repo+storeParsed c repo = updateLocation $ repo+	{ config = (M.map Prelude.head c) `M.union` config repo+	, fullconfig = M.unionWith (++) c (fullconfig repo)+	}  {- Stores a single config setting in a Repo, returning the new version of  - the Repo. Config settings can be updated incrementally. -}
Git/ConfigTypes.hs view
@@ -1,6 +1,6 @@ {- git config types  -- - Copyright 2012, 2017 Joey Hess <id@joeyh.name>+ - Copyright 2012-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -10,14 +10,16 @@ module Git.ConfigTypes where  import Data.Char+import Numeric import qualified Data.ByteString.Char8 as S8+import System.PosixCompat.Types  import Common import Git import Git.Types import qualified Git.Config -data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int+data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared FileMode 	deriving (Eq)  getSharedRepository :: Repo -> SharedRepository@@ -31,7 +33,8 @@ 			"all" -> AllShared 			"world" -> AllShared 			"everybody" -> AllShared-			_ -> maybe UnShared UmaskShared (readish (decodeBS v))+			_ -> maybe UnShared UmaskShared +				(fmap fst $ headMaybe $ readOct $ decodeBS v) 		Just NoConfigValue -> UnShared 		Nothing -> UnShared
Git/Construct.hs view
@@ -86,7 +86,7 @@ fromAbsPath dir 	| absoluteGitPath dir = fromPath dir 	| otherwise =-		error $ "internal error, " ++ show dir ++ " is not absolute"+		giveup $ "internal error, " ++ show dir ++ " is not absolute"  {- Construct a Repo for a remote's url.  -
Git/DiffTree.hs view
@@ -29,7 +29,7 @@ import Git.Command import Git.FilePath import Git.DiffTreeItem-import qualified Git.Filename+import qualified Git.Quote import qualified Git.Ref import Utility.Attoparsec @@ -113,8 +113,8 @@ 	go [] = [] 	go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of 		A.Done _ r -> r : go rest-		A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err-	go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL s ++ "\""+		A.Fail _ _ err -> giveup $ "diff-tree parse error: " ++ err+	go (s:[]) = giveup $ "diff-tree parse error near \"" ++ decodeBL s ++ "\""  -- :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status> --@@ -133,6 +133,6 @@ 	<*> (maybe (fail "bad dstsha") return . extractSha =<< nextword) 	<* A8.char ' ' 	<*> A.takeByteString-	<*> pure (asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f)+	<*> pure (asTopFilePath $ fromInternalGitPath $ Git.Quote.unquote f)   where 	nextword = A8.takeTill (== ' ')
Git/FilePath.hs view
@@ -5,7 +5,7 @@  - top of the repository even when run in a subdirectory. Adding some  - types helps keep that straight.  -- - 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.  -}@@ -30,12 +30,12 @@  import Common import Git+import Git.Quote  import qualified System.FilePath.ByteString as P import qualified System.FilePath.Posix.ByteString import GHC.Generics import Control.DeepSeq-import qualified Data.ByteString as S  {- A RawFilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }@@ -46,11 +46,11 @@ {- A file in a branch or other treeish. -} data BranchFilePath = BranchFilePath Ref TopFilePath 	deriving (Show, Eq, Ord)-+  {- Git uses the branch:file form to refer to a BranchFilePath -}-descBranchFilePath :: BranchFilePath -> S.ByteString+descBranchFilePath :: BranchFilePath -> StringContainingQuotedPath descBranchFilePath (BranchFilePath b f) =-	fromRef' b <> ":" <> getTopFilePath f+	UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f)  {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
− Git/Filename.hs 
@@ -1,49 +0,0 @@-{- Some git commands output encoded filenames, in a rather annoyingly complex- - C-style encoding.- -- - Copyright 2010, 2011 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}--module Git.Filename where--import Common-import Utility.Format (decode_c, encode_c)-import Utility.QuickCheck--import Data.Char-import Data.Word-import qualified Data.ByteString as S---- encoded filenames will be inside double quotes-decode :: S.ByteString -> RawFilePath-decode b = case S.uncons b of-	Nothing -> b-	Just (h, t)-		| h /= q -> b-		| otherwise -> case S.unsnoc t of-			Nothing -> b-			Just (i, l)-				| l /= q -> b-				| otherwise ->-					encodeBS $ decode_c $ decodeBS i-  where-  	q :: Word8-	q = fromIntegral (ord '"')--{- Should not need to use this, except for testing decode. -}-encode :: RawFilePath -> S.ByteString-encode s = encodeBS $ "\"" ++ encode_c (decodeBS s) ++ "\""---- Encoding and then decoding roundtrips only when the string does not--- contain high unicode, because eg,  both "\12345" and "\227\128\185"--- are encoded to "\343\200\271".------ That is not a real-world problem, and using TestableFilePath--- limits what's tested to ascii, so avoids running into it.-prop_encode_decode_roundtrip :: TestableFilePath -> Bool-prop_encode_decode_roundtrip ts = -	s == fromRawFilePath (decode (encode (toRawFilePath s)))-  where-	s = fromTestableFilePath ts
Git/LsTree.hs view
@@ -23,7 +23,7 @@ import Git import Git.Command import Git.FilePath-import qualified Git.Filename+import qualified Git.Quote import Utility.Attoparsec  import Numeric@@ -137,7 +137,7 @@ 		-- sha 		<*> (Ref <$> A8.takeTill A8.isSpace) -	fileparser = asTopFilePath . Git.Filename.decode <$> A.takeByteString+	fileparser = asTopFilePath . Git.Quote.unquote <$> A.takeByteString  	sizeparser = fmap Just A8.decimal
Git/PktLine.hs view
@@ -31,6 +31,7 @@  import Utility.PartialPrelude import Utility.FileSystemEncoding+import Utility.Exception  {- This is a variable length binary string, but its size is limited to  - maxPktLineLength. Its serialization includes a 4 byte hexadecimal@@ -96,7 +97,7 @@ stringPktLine :: String -> PktLine stringPktLine s 	| length s > maxPktLineLength =-		error "textPktLine called with too-long value"+		giveup "textPktLine called with too-long value" 	| otherwise = PktLine (encodeBS s <> "\n")  {- Sends a PktLine to a Handle, and flushes it so that it will be
+ Git/Quote.hs view
@@ -0,0 +1,122 @@+{- Some git commands output quoted filenames, in a rather annoyingly complex+ - C-style encoding.+ -+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}++module Git.Quote (+	unquote,+	quote,+	noquote,+	QuotePath(..),+	StringContainingQuotedPath(..),+	quotedPaths,+	prop_quote_unquote_roundtrip,+) where++import Common+import Utility.Format (decode_c, encode_c, encode_c', isUtf8Byte)+import Utility.QuickCheck+import Utility.SafeOutput++import Data.Char+import Data.Word+import Data.String+import qualified Data.ByteString as S+import qualified Data.Semigroup as Sem+import Prelude++unquote :: S.ByteString -> RawFilePath+unquote b = case S.uncons b of+	Nothing -> b+	Just (h, t)+		| h /= q -> b+		| otherwise -> case S.unsnoc t of+			Nothing -> b+			Just (i, l)+				| l /= q -> b+				| otherwise -> decode_c i+  where+  	q :: Word8+	q = fromIntegral (ord '"')++-- always encodes and double quotes, even in cases that git does not+quoteAlways :: RawFilePath -> S.ByteString+quoteAlways s = "\"" <> encode_c needencode s <> "\""+  where+	needencode c = isUtf8Byte c || c == fromIntegral (ord '"')++-- git config core.quotePath controls whether to quote unicode characters+newtype QuotePath = QuotePath Bool++class Quoteable t where+	-- double quotes and encodes when git would+	quote :: QuotePath -> t -> S.ByteString++	noquote :: t -> S.ByteString++instance Quoteable RawFilePath where+	quote (QuotePath qp) s = case encode_c' needencode s of+		Nothing -> s+		Just s' -> "\"" <> s' <> "\""+	  where+		needencode c+			| c == fromIntegral (ord '"') = True+			| qp = isUtf8Byte c+			| otherwise = False++	noquote = id++-- Allows building up a string that contains paths, which will get quoted.+-- With OverloadedStrings, strings are passed through without quoting.+-- Eg: QuotedPath f <> ": not found"+data StringContainingQuotedPath+	= UnquotedString String +	| UnquotedByteString S.ByteString +	| QuotedPath RawFilePath+	| StringContainingQuotedPath :+: StringContainingQuotedPath+	deriving (Show, Eq)++quotedPaths :: [RawFilePath] -> StringContainingQuotedPath+quotedPaths [] = mempty+quotedPaths (p:ps) = QuotedPath p <> if null ps+	then mempty+	else " " <> quotedPaths ps++instance Quoteable StringContainingQuotedPath where+	quote _ (UnquotedString s) = safeOutput (encodeBS s)+	quote _ (UnquotedByteString s) = safeOutput s+	quote qp (QuotedPath p) = quote qp p+	quote qp (a :+: b) = quote qp a <> quote qp b++	noquote (UnquotedString s) = encodeBS s+	noquote (UnquotedByteString s) = s+	noquote (QuotedPath p) = p+	noquote (a :+: b) = noquote a <> noquote b++instance IsString StringContainingQuotedPath where+	fromString = UnquotedByteString . encodeBS++instance Sem.Semigroup StringContainingQuotedPath where+	UnquotedString a <> UnquotedString b = UnquotedString (a <> b)+	UnquotedByteString a <> UnquotedByteString b = UnquotedByteString (a <> b)+	a <> b = a :+: b++instance Monoid StringContainingQuotedPath where+	mempty = UnquotedByteString mempty++-- Encoding and then decoding roundtrips only when the string does not+-- contain high unicode, because eg, both "\12345" and "\227\128\185"+-- are encoded to "\343\200\271".+--+-- That is not a real-world problem, and using TestableFilePath+-- limits what's tested to ascii, so avoids running into it.+prop_quote_unquote_roundtrip :: TestableFilePath -> Bool+prop_quote_unquote_roundtrip ts = +	s == fromRawFilePath (unquote (quoteAlways (toRawFilePath s)))+  where+	s = fromTestableFilePath ts
Git/Repair.hs view
@@ -30,6 +30,7 @@ import Git.Fsck import Git.Index import Git.Env+import Git.FilePath import qualified Git.Config as Config import qualified Git.Construct as Construct import qualified Git.LsTree as LsTree@@ -252,7 +253,8 @@ getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do 	let topsegs = length (splitPath refdir) - 1-	let toref = Ref . encodeBS . joinPath . drop topsegs . splitPath+	let toref = Ref . toInternalGitPath . encodeBS +		. joinPath . drop topsegs . splitPath 	map toref <$> dirContentsRecursive refdir  explodePackedRefsFile :: Repo -> IO ()
Git/Sha.hs view
@@ -20,7 +20,7 @@ getSha :: String -> IO S.ByteString -> IO Sha getSha subcommand a = maybe bad return =<< extractSha <$> a   where-	bad = error $ "failed to read sha from git " ++ subcommand+	bad = giveup $ "failed to read sha from git " ++ subcommand  {- Extracts the Sha from a ByteString.   -
Git/Tree.hs view
@@ -62,7 +62,7 @@ getTree :: LsTree.LsTreeRecursive -> Ref -> Repo -> IO Tree getTree recursive r repo = do 	(l, cleanup) <- lsTreeWithObjects recursive r repo-	let !t = either (\e -> error ("ls-tree parse error:" ++ e)) id+	let !t = either (\e -> giveup ("ls-tree parse error:" ++ e)) id 		(extractTree l) 	void cleanup 	return t@@ -77,7 +77,7 @@ withMkTreeHandle repo a = bracketIO setup cleanup (a . MkTreeHandle)   where 	setup = gitCoProcessStart False ps repo-	ps = [Param "mktree", Param "--batch", Param "-z"]+	ps = [Param "mktree", Param "--missing", Param "--batch", Param "-z"] 	cleanup = CoProcess.stop  {- Records a Tree in the Repo, returning its Sha.@@ -254,7 +254,7 @@ 					Just (TreeItem f m s) ->  						let commit = TreeCommit f m s 						in go h wasmodified (commit:c) depth intree is-			_ -> error ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"")+			_ -> giveup ("unexpected object type \"" ++ decodeBS (LsTree.typeobj i) ++ "\"") 		| otherwise = return (c, wasmodified, i:is)  	adjustlist h depth ishere underhere l = do
Git/UnionMerge.hs view
@@ -78,7 +78,7 @@ 	go [] = noop 	go (info:file:rest) = mergeFile info file hashhandle ch >>= 		maybe (go rest) (\l -> streamer l >> go rest)-	go (_:[]) = error $ "parse error " ++ show differ+	go (_:[]) = giveup $ "parse error " ++ show differ  {- Given an info line from a git raw diff, and the filename, generates  - a line suitable for update-index that union merges the two sides of the
Limit.hs view
@@ -87,7 +87,7 @@  {- Adds a new syntax token. -} addSyntaxToken :: String -> Annex ()-addSyntaxToken = either error add . Utility.Matcher.syntaxToken+addSyntaxToken = either giveup add . Utility.Matcher.syntaxToken  {- Adds a new limit. -} addLimit :: Either String (MatchFiles Annex) -> Annex ()
+ Logs/AdjustedBranchUpdate.hs view
@@ -0,0 +1,84 @@+{- git-annex log file that indicates when the adjusted branch needs to be+ - updated due to changes in content availability.+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++{-# LANGUAGE OverloadedStrings #-}++module Logs.AdjustedBranchUpdate (+	recordAdjustedBranchUpdateNeeded,+	recordAdjustedBranchUpdateFinished,+	isAdjustedBranchUpdateNeeded,+) where++import Annex.Common+import Logs.File+import Utility.TimeStamp++import qualified Data.ByteString.Lazy as L+import Data.Time.Clock.POSIX++-- | Updates the log to indicate that an update is needed.+recordAdjustedBranchUpdateNeeded :: Annex ()+recordAdjustedBranchUpdateNeeded = do+	now <- liftIO getPOSIXTime+	logf <- fromRepo gitAnnexAdjustedBranchUpdateLog+	lckf <- fromRepo gitAnnexAdjustedBranchUpdateLock+	-- Replace any other log entries, because an update is needed now,+	-- so an entry that says an update finished must be in the past.+	-- And, if there were clock skew, an entry that says an update is+	-- needed in the future would be wrong information.+	modifyLogFile logf lckf (const [formatAdjustLog True now])++-- | Called after an update has finished. The time is when the update+-- started. If recordAdjustedBranchUpdateNeeded was called during the+-- update, the log is left indicating that an update is still needed.+recordAdjustedBranchUpdateFinished :: POSIXTime -> Annex ()+recordAdjustedBranchUpdateFinished starttime = do+	now <- liftIO getPOSIXTime+	logf <- fromRepo gitAnnexAdjustedBranchUpdateLog+	lckf <- fromRepo gitAnnexAdjustedBranchUpdateLock+	modifyLogFile logf lckf (go now)+  where+	go now logged+		| null $ filter (isnewer now) $ mapMaybe parseAdjustLog logged =+			[formatAdjustLog False starttime]+		| otherwise = logged+	+	-- If the logged time is in the future, there was clock skew,+	-- so disregard that log entry.+	isnewer now (_, loggedtime) = +		loggedtime >= starttime && loggedtime <= now++isAdjustedBranchUpdateNeeded :: Annex Bool+isAdjustedBranchUpdateNeeded = do+	logf <- fromRepo gitAnnexAdjustedBranchUpdateLog+	lckf <- fromRepo gitAnnexAdjustedBranchUpdateLock+	calcLogFile logf lckf Nothing go >>= return . \case+		Just b -> b+		-- No log, so assume an update is needed.+		-- This handles upgrades from before this log was written.+		Nothing -> True+  where+ 	go l p = case parseAdjustLog l of+		Nothing -> p+		Just (b, _t) -> case p of+			Nothing -> Just b+			Just b' -> Just (b' || b)++formatAdjustLog :: Bool -> POSIXTime -> L.ByteString+formatAdjustLog b t = encodeBL (show t) <> " " <> if b then "1" else "0"++parseAdjustLog :: L.ByteString -> Maybe (Bool, POSIXTime)+parseAdjustLog l = +	let (ts, bs) = separate (== ' ') (decodeBL l)+	in do+		b <- case bs of+			"1" -> Just True+			"0" -> Just False+			_ -> Nothing+		t <- parsePOSIXTime ts+		return (b, t)
+ Logs/Import.hs view
@@ -0,0 +1,37 @@+{- git-annex import logs+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Logs.Import (+	recordContentIdentifierTree,+	getContentIdentifierTree+) where++import Annex.Common+import Git.Types+import Git.Sha+import Logs.File++import qualified Data.ByteString.Lazy as L++{- Records the sha of a tree that contains hashes of ContentIdentifiers+ - that were imported from a remote. -}+recordContentIdentifierTree :: UUID -> Sha -> Annex ()+recordContentIdentifierTree u t = do+	l <- calcRepo' (gitAnnexImportLog u)+	writeLogFile l (fromRef t)++{- Gets the tree last recorded for a remote. -}+getContentIdentifierTree :: UUID -> Annex (Maybe Sha)+getContentIdentifierTree u = do+	l <- calcRepo' (gitAnnexImportLog u)+	-- This is safe because the log file is written atomically.+	calcLogFileUnsafe l Nothing update+  where+	update l Nothing = extractSha (L.toStrict l)+	-- Subsequent lines are ignored. This leaves room for future+	-- expansion of what is logged.+	update _l (Just l) = Just l
Logs/NumCopies.hs view
@@ -45,22 +45,22 @@  {- Value configured in the numcopies log. Cached for speed. -} getGlobalNumCopies :: Annex (Maybe NumCopies)-getGlobalNumCopies = maybe globalNumCopiesLoad (return . Just)+getGlobalNumCopies = maybe globalNumCopiesLoad return 	=<< Annex.getState Annex.globalnumcopies  {- Value configured in the mincopies log. Cached for speed. -} getGlobalMinCopies :: Annex (Maybe MinCopies)-getGlobalMinCopies = maybe globalMinCopiesLoad (return . Just)+getGlobalMinCopies = maybe globalMinCopiesLoad return 	=<< Annex.getState Annex.globalmincopies  globalNumCopiesLoad :: Annex (Maybe NumCopies) globalNumCopiesLoad = do 	v <- getLog numcopiesLog-	Annex.changeState $ \s -> s { Annex.globalnumcopies = v }+	Annex.changeState $ \s -> s { Annex.globalnumcopies = Just v } 	return v  globalMinCopiesLoad :: Annex (Maybe MinCopies) globalMinCopiesLoad = do 	v <- getLog mincopiesLog-	Annex.changeState $ \s -> s { Annex.globalmincopies = v }+	Annex.changeState $ \s -> s { Annex.globalmincopies = Just v } 	return v
Logs/Transfer.hs view
@@ -14,6 +14,7 @@ import Types.ActionItem import Annex.Common import qualified Git+import qualified Git.Quote import Utility.Metered import Utility.Percentage import Utility.PID@@ -31,11 +32,11 @@ import qualified Data.ByteString.Char8 as B8 import qualified System.FilePath.ByteString as P -describeTransfer :: Transfer -> TransferInfo -> String-describeTransfer t info = unwords+describeTransfer :: Git.Quote.QuotePath -> Transfer -> TransferInfo -> String+describeTransfer qp t info = unwords 	[ show $ transferDirection t 	, show $ transferUUID t-	, decodeBS $ actionItemDesc $ ActionItemAssociatedFile+	, decodeBS $ quote qp $ actionItemDesc $ ActionItemAssociatedFile 		(associatedFile info) 		(transferKey t) 	, show $ bytesComplete info
Messages.hs view
@@ -1,15 +1,13 @@ {- git-annex output messages  -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}  module Messages (-	showStart,-	showStartOther, 	showStartMessage, 	showEndMessage, 	StartMessage(..),@@ -29,6 +27,8 @@ 	showEndFail, 	showEndResult, 	endResult,+	MessageId(..),+	toplevelFileProblem, 	toplevelWarning, 	warning, 	earlyWarning,@@ -36,6 +36,8 @@ 	indent, 	JSON.JSONChunk(..), 	maybeShowJSON,+	maybeShowJSON',+	maybeAddJSONField, 	showFullJSON, 	showCustom, 	showHeader,@@ -50,11 +52,16 @@ 	MessageState, 	prompt, 	mkPrompter,+	sanitizeTopLevelExceptionMessages, ) where  import Control.Concurrent import Control.Monad.IO.Class import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import System.Exit+import qualified Control.Monad.Catch as M+import Data.String  import Common import Types@@ -62,41 +69,21 @@ import Types.ActionItem import Types.Concurrency import Types.Command (StartMessage(..), SeekInput)-import Types.Transfer (transferKey) import Messages.Internal import Messages.Concurrent import Annex.Debug import Annex.Concurrent.Utility+import Utility.SafeOutput+import Git.Quote import qualified Messages.JSON as JSON import qualified Annex -showStart :: String -> RawFilePath -> SeekInput -> Annex ()-showStart command file si = outputMessage json $-	encodeBS command <> " " <> file <> " "-  where-	json = JSON.start command (Just file) Nothing si--showStartKey :: String -> Key -> ActionItem -> SeekInput -> Annex ()-showStartKey command key ai si = outputMessage json $-	encodeBS command <> " " <> actionItemDesc ai <> " "-  where-	json = JSON.start command (actionItemFile ai) (Just key) si--showStartOther :: String -> Maybe String -> SeekInput -> Annex ()-showStartOther command mdesc si = outputMessage json $ encodeBS $-	command ++ (maybe "" (" " ++) mdesc) ++ " "-  where-	json = JSON.start command Nothing Nothing si- showStartMessage :: StartMessage -> Annex ()-showStartMessage (StartMessage command ai si) = case ai of-	ActionItemAssociatedFile _ k -> showStartKey command k ai si-	ActionItemKey k -> showStartKey command k ai si-	ActionItemBranchFilePath _ k -> showStartKey command k ai si-	ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai si-	ActionItemTreeFile file -> showStart command file si-	ActionItemOther msg -> showStartOther command msg si-	OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai' si)+showStartMessage (StartMessage command ai si) =+	outputMessage json id $+		UnquotedString command <> " " <> actionItemDesc ai <> " "+  where+	json = JSON.startActionItem command ai si showStartMessage (StartUsualMessages command ai si) = do 	outputType <$> Annex.getState Annex.output >>= \case 		QuietOutput -> Annex.setOutput NormalOutput@@ -115,13 +102,13 @@ showEndMessage (StartNoMessage _) = const noop showEndMessage (CustomOutput _) = const noop -showNote :: String -> Annex ()-showNote s = outputMessage (JSON.note s) $ encodeBS $ "(" ++ s ++ ") "+showNote :: StringContainingQuotedPath -> Annex ()+showNote s = outputMessage (JSON.note (decodeBS (noquote s))) id $ "(" <> s <> ") " -showAction :: String -> Annex ()-showAction s = showNote $ s ++ "..."+showAction :: StringContainingQuotedPath -> Annex ()+showAction s = showNote $ s <> "..." -showSideAction :: String -> Annex ()+showSideAction :: StringContainingQuotedPath -> Annex () showSideAction m = Annex.getState Annex.output >>= go   where 	go st@@ -131,7 +118,7 @@ 			Annex.changeState $ \s -> s { Annex.output = st' } 		| sideActionBlock st == InBlock = return () 		| otherwise = go'-	go' = outputMessage JSON.none $ encodeBS $ "(" ++ m ++ "...)\n"+	go' = outputMessage JSON.none id $ "(" <> m <> "...)\n" 			 showStoringStateAction :: Annex () showStoringStateAction = showSideAction "recording state in git"@@ -172,19 +159,18 @@ {- Make way for subsequent output of a command. -} showOutput :: Annex () showOutput = unlessM commandProgressDisabled $-	outputMessage JSON.none "\n"+	outputMessage JSON.none id "\n" -showLongNote :: String -> Annex ()-showLongNote s = outputMessage (JSON.note s) (encodeBS (formatLongNote s))+showLongNote :: StringContainingQuotedPath -> Annex ()+showLongNote s = outputMessage (JSON.note (decodeBS (noquote s))) formatLongNote s -formatLongNote :: String -> String-formatLongNote s = '\n' : indent s ++ "\n"+formatLongNote :: S.ByteString -> S.ByteString+formatLongNote s = "\n" <> indent s <> "\n"  -- Used by external special remote, displayed same as showLongNote -- to console, but json object containing the info is emitted immediately.-showInfo :: String -> Annex ()-showInfo s = outputMessage' outputJSON (JSON.info s) $-	encodeBS (formatLongNote s)+showInfo :: StringContainingQuotedPath -> Annex ()+showInfo s = outputMessage' outputJSON (JSON.info (decodeBS (noquote s))) formatLongNote s  showEndOk :: Annex () showEndOk = showEndResult True@@ -193,41 +179,61 @@ showEndFail = showEndResult False  showEndResult :: Bool -> Annex ()-showEndResult ok = outputMessage (JSON.end ok) $ endResult ok <> "\n"+showEndResult ok = outputMessage (JSON.end ok) id $+	UnquotedByteString (endResult ok) <> "\n"  endResult :: Bool -> S.ByteString endResult True = "ok" endResult False = "failed" -toplevelWarning :: Bool -> String -> Annex ()-toplevelWarning makeway s = warning' makeway ("git-annex: " ++ s)+toplevelMsg :: (Semigroup t, IsString t) => t -> t+toplevelMsg s = fromString "git-annex: " <> s -warning :: String -> Annex ()-warning = warning' True . indent+toplevelFileProblem :: Bool -> MessageId -> StringContainingQuotedPath -> String -> RawFilePath -> Maybe Key -> SeekInput -> Annex ()+toplevelFileProblem makeway messageid msg action file mkey si = do+	maybeShowJSON' $ JSON.start action (Just file) mkey si+	maybeShowJSON' $ JSON.messageid messageid+	warning' makeway id (toplevelMsg (QuotedPath file <> " " <> msg))+	maybeShowJSON' $ JSON.end False -earlyWarning :: String -> Annex ()-earlyWarning = warning' False+toplevelWarning :: Bool -> StringContainingQuotedPath -> Annex ()+toplevelWarning makeway s = warning' makeway id (toplevelMsg s) -warning' :: Bool -> String -> Annex ()-warning' makeway w = do+warning :: StringContainingQuotedPath -> Annex ()+warning = warning' True indent++earlyWarning :: StringContainingQuotedPath -> Annex ()+earlyWarning = warning' False id++warning' :: Bool -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()+warning' makeway consolewhitespacef msg = do 	when makeway $-		outputMessage JSON.none "\n"-	outputError (w ++ "\n")+		outputMessage JSON.none id "\n"+	outputError (\s -> consolewhitespacef s <> "\n") msg  {- Not concurrent output safe. -} warningIO :: String -> IO () warningIO w = do 	putStr "\n" 	hFlush stdout-	hPutStrLn stderr w+	hPutStrLn stderr (safeOutput w) -indent :: String -> String-indent = intercalate "\n" . map (\l -> "  " ++ l) . lines+indent :: S.ByteString -> S.ByteString+indent = S.intercalate "\n" . map ("  " <>) . S8.lines  {- Shows a JSON chunk only when in json mode. -} maybeShowJSON :: JSON.JSONChunk v -> Annex () maybeShowJSON v = void $ withMessageState $ bufferJSON (JSON.add v) +maybeShowJSON' :: JSON.JSONBuilder -> Annex ()+maybeShowJSON' v = void $ withMessageState $ bufferJSON v++{- Adds a field to the current json object. -}+maybeAddJSONField :: JSON.ToJSON' v => String -> v -> Annex ()+maybeAddJSONField f v = case JSON.toJSON' (JSON.AddJSONActionItemField f v) of+	JSON.Object o -> maybeShowJSON $ JSON.AesonObject o+	_ -> noop+ {- Shows a complete JSON value, only when in json mode. -} showFullJSON :: JSON.JSONChunk v -> Annex Bool showFullJSON v = withMessageState $ bufferJSON (JSON.complete v)@@ -235,19 +241,19 @@ {- Performs an action that outputs nonstandard/customized output, and  - in JSON mode wraps its output in JSON.start and JSON.end, so it's  - a complete JSON document.- - This is only needed when showStart and showEndOk is not used.+ - This is only needed when showStartMessage and showEndOk is not used.  -} showCustom :: String -> SeekInput -> Annex Bool -> Annex () showCustom command si a = do-	outputMessage (JSON.start command Nothing Nothing si) ""+	outputMessage (JSON.start command Nothing Nothing si) id "" 	r <- a-	outputMessage (JSON.end r) ""+	outputMessage (JSON.end r) id ""  showHeader :: S.ByteString -> Annex ()-showHeader h = outputMessage JSON.none (h <> ": ")+showHeader h = outputMessage JSON.none id (UnquotedByteString h <> ": ")  showRaw :: S.ByteString -> Annex ()-showRaw s = outputMessage JSON.none (s <> "\n")+showRaw s = outputMessage JSON.none id (UnquotedByteString s <> "\n")  setupConsole :: IO () setupConsole = do@@ -272,7 +278,7 @@ 	-- that are displayed at the same time from mixing together. 	lock <- newMVar () 	return $ \s -> withMVar lock $ \() -> do-		S.hPutStr stderr (s <> "\n")+		S.hPutStr stderr (safeOutput s <> "\n") 		hFlush stderr  {- Should commands that normally output progress messages have that@@ -328,3 +334,16 @@ 				(takeMVar l) 				(\v -> putMVar l v >> cleanup) 				(const $ run a)++{- Catch all (non-async and not ExitCode) exceptions and display, + - santizing any control characters in the exceptions.+ -+ - Exits nonzero on exception, so should only be used at topmost level.+ -}+sanitizeTopLevelExceptionMessages :: IO a -> IO a+sanitizeTopLevelExceptionMessages a = a `catches`+	((M.Handler (\ (e :: ExitCode) -> throwM e)) : nonAsyncHandler go)+  where+	go e = do+		hPutStrLn stderr $ safeOutput $ toplevelMsg (show e)+		exitWith $ ExitFailure 1
Messages/Internal.hs view
@@ -1,6 +1,6 @@ {- git-annex output messages, including concurrent output to display regions  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -13,28 +13,33 @@ import Messages.Concurrent import qualified Messages.JSON as JSON import Messages.JSON (JSONBuilder)+import Git.Quote+import Types.GitConfig  import qualified Data.ByteString as S  withMessageState :: (MessageState -> Annex a) -> Annex a withMessageState a = Annex.getState Annex.output >>= a -outputMessage :: JSONBuilder -> S.ByteString -> Annex ()+outputMessage :: JSONBuilder -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex () outputMessage = outputMessage' bufferJSON -outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> S.ByteString -> Annex ()-outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case outputType s of+outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()+outputMessage' jsonoutputter jsonbuilder consolewhitespacef msg = withMessageState $ \s -> case outputType s of 	NormalOutput 		| concurrentOutputEnabled s -> do+			qp <- coreQuotePath <$> Annex.getGitConfig 			liftIO $ clearProgressMeter s-			concurrentMessage s False (decodeBS msg) q+			concurrentMessage s False (decodeBS (consolewhitespacef (quote qp msg))) q 		| otherwise -> do+			qp <- coreQuotePath <$> Annex.getGitConfig 			liftIO $ clearProgressMeter s-			liftIO $ flushed $ S.putStr msg+			liftIO $ flushed $ S.putStr (consolewhitespacef (quote qp msg)) 	JSONOutput _ -> void $ jsonoutputter jsonbuilder s 	QuietOutput -> q 	SerializedOutput h _ -> do-		liftIO $ outputSerialized h $ OutputMessage msg+		qp <- coreQuotePath <$> Annex.getGitConfig+		liftIO $ outputSerialized h $ OutputMessage $ consolewhitespacef $ quote qp msg 		void $ jsonoutputter jsonbuilder s  -- Buffer changes to JSON until end is reached and then emit it.@@ -75,22 +80,27 @@ 			(fst <$> jsonbuilder Nothing) 		return True -outputError :: String -> Annex ()-outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of+outputError :: (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()+outputError consolewhitespacef msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of         (JSONOutput jsonoptions, Just jb) | jsonErrorMessages jsonoptions ->-		let jb' = Just (JSON.addErrorMessage (lines msg) jb)+		let jb' = Just (JSON.addErrorMessage (lines (decodeBS (noquote msg))) jb) 		in Annex.changeState $ \st -> 			st { Annex.output = s { jsonBuffer = jb' } }-	(SerializedOutput h _, _) -> -		liftIO $ outputSerialized h $ OutputError msg+	(SerializedOutput h _, _) -> do+		qp <- coreQuotePath <$> Annex.getGitConfig+		liftIO $ outputSerialized h $ OutputError $ decodeBS $+			consolewhitespacef $ quote qp msg 	_-		| concurrentOutputEnabled s -> concurrentMessage s True msg go+		| concurrentOutputEnabled s -> do+			qp <- coreQuotePath <$> Annex.getGitConfig+			concurrentMessage s True (decodeBS $ consolewhitespacef $ quote qp msg) go 		| otherwise -> go   where-	go = liftIO $ do-		hFlush stdout-		hPutStr stderr msg-		hFlush stderr+	go = do+		qp <- coreQuotePath <$> Annex.getGitConfig+		liftIO $ hFlush stdout+		liftIO $ S.hPutStr stderr (consolewhitespacef $ quote qp msg)+		liftIO $ hFlush stderr  q :: Monad m => m () q = noop@@ -105,4 +115,4 @@ waitOutputSerializedResponse :: (IO (Maybe SerializedOutputResponse)) -> SerializedOutputResponse -> IO () waitOutputSerializedResponse getr r = tryIO getr >>= \case 	Right (Just r') | r' == r -> return ()-	v -> error $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v+	v -> giveup $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v
Messages/JSON.hs view
@@ -1,6 +1,6 @@ {- git-annex command-line JSON output and input  -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -12,21 +12,23 @@ 	JSONChunk(..), 	emit, 	emit',-	encode, 	none, 	start,+	startActionItem, 	end, 	finalize, 	addErrorMessage, 	note, 	info,+	messageid, 	add, 	complete, 	progress, 	DualDisp(..), 	ObjectMap(..), 	JSONActionItem(..),-	AddJSONActionItemFields(..),+	AddJSONActionItemField(..),+	module Utility.Aeson, ) where  import Control.Applicative@@ -46,11 +48,14 @@ import Prelude  import Types.Command (SeekInput(..))+import Types.ActionItem+import Types.UUID import Key import Utility.Metered import Utility.Percentage import Utility.Aeson import Utility.FileSystemEncoding+import Types.Messages  -- A global lock to avoid concurrent threads emitting json at the same time. {-# NOINLINE emitLock #-}@@ -68,7 +73,8 @@ 	putMVar emitLock ()  -- Building up a JSON object can be done by first using start,--- then add and note any number of times, and finally complete.+-- then add and note and messageid any number of times, and finally+-- complete. type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool)  none :: JSONBuilder@@ -83,10 +89,25 @@ 		{ itemCommand = Just command 		, itemKey = key 		, itemFile = fromRawFilePath <$> file+		, itemUUID = Nothing 		, itemFields = Nothing :: Maybe Bool 		, itemSeekInput = si 		} +startActionItem :: String -> ActionItem -> SeekInput -> JSONBuilder+startActionItem command ai si _ = case j of+	Object o -> Just (o, False)+	_ -> Nothing+  where+	j = toJSON' $ JSONActionItem+		{ itemCommand = Just command+		, itemKey = actionItemKey ai+		, itemFile = fromRawFilePath <$> actionItemFile ai+		, itemUUID = actionItemUUID ai+		, itemFields = Nothing :: Maybe Bool+		, itemSeekInput = si+		}+ end :: Bool -> JSONBuilder end b (Just (o, _)) = Just (HM.insert "success" (toJSON' b) o, True) end _ Nothing = Nothing@@ -112,6 +133,12 @@ 		String (old <> "\n" <> new) 	combinelines new _old = new +messageid :: MessageId -> JSONBuilder+messageid _ Nothing = Nothing+messageid mid (Just (o, e)) = Just (HM.unionWith replaceold (HM.singleton "message-id" (toJSON' (show mid))) o, e)+  where+	replaceold new _old = new+ info :: String -> JSONBuilder info s _ = case j of 	Object o -> Just (o, True)@@ -184,6 +211,7 @@ 	{ itemCommand :: Maybe String 	, itemKey :: Maybe Key 	, itemFile :: Maybe FilePath+	, itemUUID :: Maybe UUID 	, itemFields :: Maybe a 	, itemSeekInput :: SeekInput 	}@@ -195,10 +223,15 @@ 		, case itemKey i of 			Just k -> Just $ "key" .= toJSON' k 			Nothing -> Nothing-		, Just $ "file" .= toJSON' (itemFile i)+		, case itemFile i of+			Just f -> Just $ "file" .= toJSON' f+			Nothing -> Nothing 		, case itemFields i of 			Just f -> Just $ "fields" .= toJSON' f 			Nothing -> Nothing+		, case itemUUID i of+			Just u -> Just $ "uuid" .= toJSON' u+			Nothing -> Nothing 		, Just $ "input" .= fromSeekInput (itemSeekInput i) 		] @@ -207,14 +240,17 @@ 		<$> (v .:? "command") 		<*> (maybe (return Nothing) parseJSON =<< (v .:? "key")) 		<*> (v .:? "file")+		<*> (v .:? "uuid") 		<*> (v .:? "fields")+		-- ^ fields is used for metadata, which is currently the+		-- only json that gets parsed 		<*> pure (SeekInput []) 	parseJSON _ = mempty --- This can be used to populate the "fields" after a JSONActionItem+-- This can be used to populate a field after a JSONActionItem -- has already been started.-newtype AddJSONActionItemFields a = AddJSONActionItemFields a+data AddJSONActionItemField a = AddJSONActionItemField String a 	deriving (Show) -instance ToJSON' a => ToJSON' (AddJSONActionItemFields a) where-	toJSON' (AddJSONActionItemFields a) = object [ ("fields", toJSON' a) ]+instance ToJSON' a => ToJSON' (AddJSONActionItemField a) where+	toJSON' (AddJSONActionItemField f a) = object [ (textKey (packString f), toJSON' a) ]
Messages/Progress.hs view
@@ -23,6 +23,7 @@ import qualified Messages.JSON as JSON import Messages.Concurrent import Messages.Internal+import Utility.SafeOutput  import qualified System.Console.Regions as Regions import qualified System.Console.Concurrent as Console@@ -177,7 +178,7 @@  {- Progress dots. -} showProgressDots :: Annex ()-showProgressDots = outputMessage JSON.none "."+showProgressDots = outputMessage JSON.none id "."  {- Runs a command, that may output progress to either stdout or  - stderr, as well as other messages.@@ -220,5 +221,5 @@ mkStderrEmitter = withMessageState go   where 	go s-		| concurrentOutputEnabled s = return Console.errorConcurrent-		| otherwise = return (hPutStrLn stderr)+		| concurrentOutputEnabled s = return (Console.errorConcurrent . safeOutput)+		| otherwise = return (hPutStrLn stderr . safeOutput)
Messages/Serialized.hs view
@@ -21,6 +21,7 @@ import Messages.Progress import qualified Messages.JSON as JSON import Utility.Metered (BytesProcessed, setMeterTotalSize)+import Git.Quote  import Control.Monad.IO.Class (MonadIO) @@ -51,10 +52,11 @@ 			runannex $ outputMessage' 				(\_ _ -> return False) 				id-				msg+				id+				(UnquotedByteString msg) 			loop st 		Left (OutputError msg) -> do-			runannex $ outputError msg+			runannex $ outputError id $ UnquotedString msg 			loop st		 		Left (JSONObject b) -> do 			runannex $ withMessageState $ \s -> case outputType s of
NEWS view
@@ -1,3 +1,12 @@+git-annex (10.20230626) upstream; urgency=medium++  Many commands now quote filenames that contain unusual characters the+  same way that git does, to avoid exposing control characters to the+  terminal. The core.quotePath config can be set to false to disable this+  quoting.++ -- Joey Hess <id@joeyh.name>  Mon, 26 Jun 2023 10:38:07 -0400+ git-annex (10.20220218) upstream; urgency=medium    Transition notice: Commands like `git-annex get foo*` have changed to error
P2P/Annex.hs view
@@ -225,7 +225,7 @@ 						-- known. Force content 						-- verification. 						return (rightsize, MustVerify)-			Left e -> error $ describeProtoFailure e+			Left e -> giveup $ describeProtoFailure e 	 	sinkfile f (Offset o) checkchanged sender p ti = bracket setup cleanup go 	  where
Remote.hs view
@@ -365,13 +365,13 @@ 				"Maybe add some of these git remotes (git remote add ...)" 			ppuuidsskipped <- pp "skipped" uuidsskipped 				"Also these untrusted repositories may contain the file"-			showLongNote $ case ppremotesmakeavailable ++ ppenablespecialremotes ++ ppaddgitremotes ++ ppuuidsskipped of+			showLongNote $ UnquotedString $ case ppremotesmakeavailable ++ ppenablespecialremotes ++ ppaddgitremotes ++ ppuuidsskipped of 				[] -> nolocmsg 				s -> s 		) 	ignored <- filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) remotes 	unless (null ignored) $-		showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"+		showLongNote $ UnquotedString $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"   where 	filteruuids l x = filter (`notElem` x) l @@ -383,7 +383,7 @@ showTriedRemotes :: [Remote] -> Annex () showTriedRemotes [] = noop showTriedRemotes remotes =-	showLongNote $ "Unable to access these remotes: "+	showLongNote $ UnquotedString $ "Unable to access these remotes: " 		++ listRemoteNames remotes  listRemoteNames :: [Remote] -> String
Remote/Adb.hs view
@@ -6,6 +6,7 @@  -}  {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}  module Remote.Adb (remote) where
Remote/BitTorrent.hs view
@@ -47,7 +47,7 @@ 	, enumerate = list 	, generate = gen 	, configParser = mkRemoteConfigParser []-	, setup = error "not supported"+	, setup = giveup "not supported" 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported 	, thirdPartyPopulated = False
Remote/Ddar.hs view
@@ -139,7 +139,7 @@  {- Convert remote DdarRepo to host and path on remote end -} splitRemoteDdarRepo :: DdarRepo -> (SshHost, String)-splitRemoteDdarRepo ddarrepo = (either error id $ mkSshHost host, ddarrepo')+splitRemoteDdarRepo ddarrepo = (either giveup id $ mkSshHost host, ddarrepo')   where 	(host, remainder) = span (/= ':') (ddarRepoLocation ddarrepo) 	ddarrepo' = drop 1 remainder@@ -228,7 +228,7 @@ 	directoryExists <- ddarDirectoryExists ddarrepo 	case directoryExists of 		Left e -> error e-		Right True -> either error return+		Right True -> either giveup return 			=<< inDdarManifest ddarrepo key 		Right False -> return False
Remote/External.hs view
@@ -504,7 +504,7 @@ 		mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix 		send (VALUE "") -- end of list 	handleRemoteRequest (DEBUG msg) = fastDebug "Remote.External" msg-	handleRemoteRequest (INFO msg) = showInfo msg+	handleRemoteRequest (INFO msg) = showInfo (UnquotedString msg) 	handleRemoteRequest (VERSION _) = senderror "too late to send VERSION"  	handleExceptionalMessage (ERROR err) = giveup $ "external special remote error: " ++ err@@ -583,7 +583,7 @@ 				Just msg -> maybe (protocolError True s) id (handleexceptional msg) 				Nothing -> protocolError False s 	protocolError parsed s = do-		warning $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " +++		warning $ UnquotedString $ "external special remote protocol error, unexpectedly received \"" ++ s ++ "\" " ++ 			if parsed 				then "(command not allowed at this time)" 				else "(unable to parse command)"@@ -713,7 +713,7 @@ 				] ++ exrest  	unusable msg = do-		warning msg+		warning (UnquotedString msg) 		giveup ("unable to use external special remote " ++ basecmd)  stopExternal :: External -> Annex ()
Remote/External/AsyncExtension.hs view
@@ -7,6 +7,7 @@  {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}  module Remote.External.AsyncExtension (runRelayToExternalAsync) where @@ -86,7 +87,7 @@ 	Nothing -> closeandshutdown   where 	protoerr s = do-		annexrunner $ warning $ "async external special remote protocol error: " ++ s+		annexrunner $ warning $ "async external special remote protocol error: " <> s 		closeandshutdown 	 	closeandshutdown = do
Remote/GCrypt.hs view
@@ -122,7 +122,7 @@ 				setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid 				gen' r u' pc gc rs 			_ -> do-				warning $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r+				warning $ UnquotedString $ "not using unknown gcrypt repository pointed to by remote " ++ Git.repoDescribe r 				return Nothing  gen' :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)@@ -197,7 +197,7 @@ 		let rsyncpath = if "/~/" `isPrefixOf` path 			then drop 3 path 			else path-		    sshhost = either error id (mkSshHost host)+		    sshhost = either giveup id (mkSshHost host) 		    mkopts = rsyncShell . (Param "ssh" :)  			<$> sshOptions ConsumeStdin (sshhost, Nothing) gc [] 		in (mkopts, fromSshHost sshhost ++ ":" ++ rsyncpath, AccessGitAnnexShell)@@ -239,7 +239,7 @@ 				] 			(r:_) 				| Git.repoLocation r == url -> noop-				| otherwise -> error "Another remote with the same name already exists."		+				| otherwise -> giveup "Another remote with the same name already exists."		  		pc <- either giveup return . parseRemoteConfig c' 			=<< configParser remote c'@@ -505,7 +505,7 @@ 	| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> 		liftIO (catchMaybeIO $ Git.Config.read r) 	| not fast = extract . liftM fst3 <$> getM (eitherToMaybe <$>)-		[ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ error "configlist failed")) "configlist" [] []+		[ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ giveup "configlist failed")) "configlist" [] [] 		, getConfigViaRsync r gc 		] 	| otherwise = return (Nothing, r)
Remote/Git.hs view
@@ -131,13 +131,18 @@  enableRemote :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID) enableRemote (Just u) c = do-	inRepo $ Git.Command.run-		[ Param "remote"-		, Param "add"-		, Param $ fromMaybe (giveup "no name") (SpecialRemote.lookupName c)-		, Param $ maybe (giveup "no location") fromProposedAccepted (M.lookup locationField c)-		]+	rs <- Annex.getGitRemotes+	unless (any (\r -> Git.remoteName r == Just cname) rs) $+		inRepo $ Git.Command.run+			[ Param "remote"+			, Param "add"+			, Param cname+			, Param clocation+			] 	return (c, u)+  where+	cname = fromMaybe (giveup "no name") (SpecialRemote.lookupName c)+	clocation = maybe (giveup "no location") fromProposedAccepted (M.lookup locationField c) enableRemote Nothing _ = giveup "unable to enable git remote with no specified uuid"  {- It's assumed to be cheap to read the config of non-URL remotes, so this is@@ -275,12 +280,12 @@ 		case v of 			Right (r', val, _err) -> do 				unless (isUUIDConfigured r' || S.null val || not mustincludeuuuid) $ do-					warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r-					warning $ "Instead, got: " ++ show val-					warning $ "This is unexpected; please check the network transport!"+					warning $ UnquotedString $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r+					warning $ UnquotedString $ "Instead, got: " ++ show val+					warning "This is unexpected; please check the network transport!" 				return $ Right r' 			Left l -> do-				warning $ "Unable to parse git config from " ++ configloc+				warning $ UnquotedString $ "Unable to parse git config from " ++ configloc 				return $ Left (show l)  	geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do@@ -306,7 +311,7 @@ 				return r' 			Left err -> do 				set_ignore "not usable by git-annex" False-				warning $ url ++ " " ++ err+				warning $ UnquotedString $ url ++ " " ++ err 				return r  	{- Is this remote just not available, or does@@ -323,9 +328,9 @@ 		case Git.remoteName r of 			Nothing -> noop 			Just n -> do-				warning $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore"+				warning $ UnquotedString $ "Remote " ++ n ++ " " ++ msg ++ "; setting annex-ignore" 				when longmessage $-					warning $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git annex enableremote " ++ n+					warning $ UnquotedString $ "This could be a problem with the git-annex installation on the remote. Please make sure that git-annex-shell is available in PATH when you ssh into the remote. Once you have fixed the git-annex installation, run: git annex enableremote " ++ n 		setremote setRemoteIgnore True 	 	setremote setter v = case Git.remoteName r of@@ -348,7 +353,7 @@ 		let check = do 			Annex.BranchState.disableUpdate 			catchNonAsync (autoInitialize (pure [])) $ \e ->-				warning $ "Remote " ++ Git.repoDescribe r +++				warning $ UnquotedString $ "Remote " ++ Git.repoDescribe r ++ 					": "  ++ show e 			Annex.getState Annex.repo 		s <- newLocal r@@ -359,7 +364,7 @@ 		unless hasuuid $ case Git.remoteName r of 			Nothing -> noop 			Just n -> do-				warning $ "Remote " ++ n ++ " cannot currently be accessed."+				warning $ UnquotedString $ "Remote " ++ n ++ " cannot currently be accessed." 		return r 		 	configlistfields = if autoinit@@ -632,9 +637,11 @@ 	(st, rd) <- liftIO $ Annex.new repo 	debugenabled <- Annex.getRead Annex.debugenabled 	debugselector <- Annex.getRead Annex.debugselector+	force <- Annex.getRead Annex.force 	return (st,  rd 		{ Annex.debugenabled = debugenabled 		, Annex.debugselector = debugselector+		, Annex.force = force 		})  onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a@@ -770,7 +777,7 @@ 					let ok = u' == u 					void $ liftIO $ tryPutMVar cv ok 					unless ok $-						warning $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now."+						warning $ UnquotedString $ Git.repoDescribe r ++ " is not the expected repository. The remote's annex-checkuuid configuration prevented noticing the change until now." 					return ok 				, liftIO $ readMVar cv 				)
Remote/GitLFS.hs view
@@ -253,7 +253,7 @@ 			warning "Unable to parse ssh url for git-lfs remote." 			return Nothing 		Just (Left err) -> do-			warning err+			warning (UnquotedString err) 			return Nothing 		Just (Right hostuser) -> do 			let port = Git.Url.port r@@ -275,11 +275,11 @@ 			(sshcommand, sshparams) <- sshCommand NoConsumeStdin (hostuser, port) (remoteGitConfig h) remotecmd 			liftIO (tryIO (readProcess sshcommand (toCommand sshparams))) >>= \case 				Left err -> do-					warning $ "ssh connection to git-lfs remote failed: " ++ show err+					warning $ UnquotedString $ "ssh connection to git-lfs remote failed: " ++ show err 					return Nothing 				Right resp -> case LFS.parseSshDiscoverEndpointResponse (fromString resp) of 					Nothing -> do-						warning $ "unexpected response from git-lfs remote when doing ssh endpoint discovery"+						warning "unexpected response from git-lfs remote when doing ssh endpoint discovery" 						return Nothing 					Just endpoint -> return (Just endpoint)
Remote/Helper/Chunked/Legacy.hs view
@@ -100,7 +100,7 @@ 		| otherwise = storechunks sz [] dests content 		 	onerr e = do-		annexrunner $ warning (show e)+		annexrunner $ warning (UnquotedString (show e)) 		return [] 	 	storechunks _ _ [] _ = return [] -- ran out of dests
Remote/Helper/Encryptable.hs view
@@ -193,9 +193,9 @@ 		Left _ -> True 	encsetup a = use "encryption setup" . a =<< highRandomQuality 	use m a = do-		showNote m+		showNote (UnquotedString m) 		cipher <- liftIO a-		showNote (describeCipher cipher)+		showNote (UnquotedString (describeCipher cipher)) 		return (storeCipher cipher c', EncryptionIsSetup) 	highRandomQuality = ifM (Annex.getRead Annex.fast) 		( return False@@ -331,4 +331,4 @@ fromB64bs :: String -> String fromB64bs s = either (const bad) (w82s . B.unpack) (B64.decode $ B.pack $ s2w8 s)   where-	bad = error "bad base64 encoded data"+	bad = giveup "bad base64 encoded data"
Remote/Helper/ExportImport.hs view
@@ -280,14 +280,14 @@ 			Nothing -> ifM (liftIO $ atomically $ tryPutTMVar lcklckv ()) 				( do 					db <- ContentIdentifier.openDb-					ContentIdentifier.needsUpdateFromLog db >>= \case+					db' <- ContentIdentifier.needsUpdateFromLog db >>= \case 						Just v -> do 							cidlck <- calcRepo' gitAnnexContentIdentifierLock  							withExclusiveLock cidlck $ 								ContentIdentifier.updateFromLog db v-						Nothing -> noop-					liftIO $ atomically $ putTMVar dbtv db-					return db+						Nothing -> pure db+					liftIO $ atomically $ putTMVar dbtv db'+					return db' 				-- loser waits for winner to open the db and 				-- can then also use its handle 				, liftIO $ atomically (readTMVar dbtv)
Remote/Helper/Hooks.hs view
@@ -87,7 +87,7 @@ 		unlockFile lck #ifndef mingw32_HOST_OS 		mode <- annexFileMode-		v <- noUmask mode $ tryLockExclusive (Just mode) lck+		v <- tryLockExclusive (Just mode) lck #else 		v <- liftIO $ lockExclusive lck #endif
Remote/Helper/Messages.hs view
@@ -29,4 +29,4 @@ cantCheck v = giveup $ "unable to check " ++ describe v  showLocking :: Describable a => a -> Annex ()-showLocking v = showAction $ "locking " ++ describe v+showLocking v = showAction $ UnquotedString $ "locking " ++ describe v
Remote/Helper/Ssh.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Remote.Helper.Ssh where  import Annex.Common@@ -32,7 +34,7 @@ toRepo cs r gc remotecmd = do 	let host = maybe 		(giveup "bad ssh url")-		(either error id . mkSshHost)+		(either giveup id . mkSshHost) 		(Git.Url.hostuser r) 	sshCommand cs (host, Git.Url.port r) gc remotecmd @@ -298,7 +300,7 @@ 		-- When runFullProto fails, the connection is no longer 		-- usable, so close it. 		Left e -> do-			warning $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")"+			warning $ UnquotedString $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")" 			conn' <- fst <$> liftIO (closeP2PSshConnection conn) 			return (conn', Nothing)
Remote/Hook.hs view
@@ -128,7 +128,7 @@ 			fallback <- fromConfigValue <$> getConfig hookfallback mempty 			if null fallback 				then do-					warning $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback+					warning $ UnquotedString $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback 					return Nothing 				else return $ Just fallback 		else return $ Just command@@ -153,7 +153,7 @@ 		ifM (progressCommandEnv "sh" [Param "-c", Param command] =<< liftIO (hookEnv action k f)) 			( a 			, do-				warning $ hook ++ " hook exited nonzero!"+				warning $ UnquotedString $ hook ++ " hook exited nonzero!" 				return False 			)
Remote/HttpAlso.hs view
@@ -1,10 +1,12 @@ {- HttpAlso remote (readonly).  -- - Copyright 2020-2021 Joey Hess <id@joeyh.name>+ - Copyright 2020-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE RankNTypes #-}+ module Remote.HttpAlso (remote) where  import Annex.Common@@ -18,7 +20,6 @@ import Config import Logs.Web import Creds-import Messages.Progress import Utility.Metered import Annex.Verify import qualified Annex.Url as Url@@ -30,7 +31,7 @@ import Control.Concurrent.STM  remote :: RemoteType-remote = RemoteType+remote = specialRemoteType $ RemoteType 	{ typename = "httpalso" 	, enumerate = const (findSpecialRemotes "httpalso") 	, generate = gen@@ -53,21 +54,26 @@ 	cst <- remoteCost gc c expensiveRemoteCost 	let url = getRemoteConfigValue urlField c 	ll <- liftIO newLearnedLayout-	return $ Just $ this url ll c cst+	return $ Just $ specialRemote c+		cannotModify+		(downloadKey url ll)+		cannotModify+		(checkKey url ll)+		(this url c cst)   where-	this url ll c cst = Remote+	this url c cst = Remote 		{ uuid = u 		, cost = cst 		, name = Git.repoDescribe r 		, storeKey = cannotModify-		, retrieveKeyFile = downloadKey url ll+		, retrieveKeyFile = retrieveKeyFileDummy 		, retrieveKeyFileCheap = Nothing 		-- HttpManagerRestricted is used here, so this is 		-- secure. 		, retrievalSecurityPolicy = RetrievalAllKeysSecure 		, removeKey = cannotModify 		, lockContent = Nothing-		, checkPresent = checkKey url ll+		, checkPresent = checkPresentDummy 		, checkPresentCheap = False 		, exportActions = ExportActions 			{ storeExport = cannotModify@@ -103,7 +109,7 @@  httpAlsoSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) httpAlsoSetup _ Nothing _ _ _ =-	error "Must use --sameas when initializing a httpalso remote."+	giveup "Must use --sameas when initializing a httpalso remote." httpAlsoSetup _ (Just u) _ c gc = do 	_url <- maybe (giveup "Specify url=") 		(return . fromProposedAccepted)@@ -114,24 +120,22 @@ 	gitConfigSpecialRemote u c' [("httpalso", "true")] 	return (c', u) -downloadKey :: Maybe URLString -> LearnedLayout -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification-downloadKey baseurl ll key _af dest p vc = do-	verifyKeyContentIncrementally vc key $ \iv ->-		downloadAction dest p iv key (keyUrlAction baseurl ll key)+downloadKey :: Maybe URLString -> LearnedLayout -> Retriever+downloadKey baseurl ll = fileRetriever' $ \dest key p iv ->+	downloadAction (fromRawFilePath dest) p iv (keyUrlAction baseurl ll key)  retriveExportHttpAlso :: Maybe URLString -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification retriveExportHttpAlso baseurl key loc dest p = do 	verifyKeyContentIncrementally AlwaysVerify key $ \iv ->-		downloadAction dest p iv key (exportLocationUrlAction baseurl loc)+		downloadAction dest p iv (exportLocationUrlAction baseurl loc) -downloadAction :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Key -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex ()-downloadAction dest p iv key run =+downloadAction :: FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> ((URLString -> Annex (Either String ())) -> Annex (Either String ())) -> Annex ()+downloadAction dest p iv run = 	Url.withUrlOptions $ \uo ->-		meteredFile dest (Just p) key $-			run (\url -> Url.download' p iv url dest uo)-				>>= either giveup (const (return ()))+		run (\url -> Url.download' p iv url dest uo)+			>>= either giveup (const (return ())) -checkKey :: Maybe URLString -> LearnedLayout -> Key -> Annex Bool+checkKey :: Maybe URLString -> LearnedLayout -> CheckPresent checkKey baseurl ll key = 	isRight <$> keyUrlAction baseurl ll key (checkKey' key) @@ -150,9 +154,9 @@ newLearnedLayout :: IO LearnedLayout newLearnedLayout = newTVarIO Nothing --- Learns which layout the special remote uses, so the once any--- action on an url succeeds, subsequent calls will continue to use that--- layout (or related layouts).+-- Learns which layout the special remote uses, so once any action on an+-- url succeeds, subsequent calls will continue to use that layout+-- (or related layouts). keyUrlAction 	:: Maybe URLString 	-> LearnedLayout
Remote/P2P.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Remote.P2P ( 	remote, 	chainGen@@ -38,7 +40,7 @@ 	, enumerate = const (return []) 	, generate = \_ _ _ _ _ -> return Nothing 	, configParser = mkRemoteConfigParser []-	, setup = error "P2P remotes are set up using git-annex p2p"+	, setup = giveup "P2P remotes are set up using git-annex p2p" 	, exportSupported = exportUnsupported 	, importSupported = importUnsupported 	, thirdPartyPopulated = False@@ -105,7 +107,7 @@ 	-- so close it. 	case v of 		Left e -> do-			warning $ "Lost connection to peer (" ++ describeProtoFailure e ++ ")"+			warning $ UnquotedString $ "Lost connection to peer (" ++ describeProtoFailure e ++ ")" 			liftIO $ closeConnection conn 			return (ClosedConnection, Nothing) 		Right r -> return (c, Just r)@@ -163,9 +165,9 @@ 					liftIO $ closeConnection conn 					return ClosedConnection 				Left e -> do-					warning $ "Problem communicating with peer. (" ++ describeProtoFailure e ++ ")"+					warning $ UnquotedString $ "Problem communicating with peer. (" ++ describeProtoFailure e ++ ")" 					liftIO $ closeConnection conn 					return ClosedConnection 		Left e -> do-			warning $ "Unable to connect to peer. (" ++ show e ++ ")"+			warning $ UnquotedString $ "Unable to connect to peer. (" ++ show e ++ ")" 			return ClosedConnection
Remote/Rsync.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, OverloadedStrings #-}  module Remote.Rsync ( 	remote,@@ -179,7 +179,7 @@ 		case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of 			"ssh":sshopts -> do 				let (port, sshopts') = sshReadPort sshopts-				    userhost = either error id $ mkSshHost $ +				    userhost = either giveup id $ mkSshHost $  				    	takeWhile (/= ':') url 				return $ (Param "ssh":) <$> sshOptions ConsumeStdin 					(userhost, port) gc
Remote/S3.hs view
@@ -423,13 +423,13 @@ 	Right h ->  		eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case 			Left failreason -> do-				warning failreason+				warning (UnquotedString failreason) 				giveup "cannot download content" 			Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv 	Left S3HandleNeedCreds -> 		getPublicWebUrls' (uuid r) rs info c k >>= \case 			Left failreason -> do-				warning failreason+				warning (UnquotedString failreason) 				giveup "cannot download content" 			Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $ 				giveup "failed to download content"@@ -470,13 +470,13 @@ checkKey hv r rs c info k = withS3Handle hv $ \case 	Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case 		Left failreason -> do-			warning failreason+			warning (UnquotedString failreason) 			giveup "cannot check content" 		Right loc -> checkKeyHelper info h loc 	Left S3HandleNeedCreds -> 		getPublicWebUrls' (uuid r) rs info c k >>= \case 			Left failreason -> do-				warning failreason+				warning (UnquotedString failreason) 				giveup "cannot check content" 			Right us -> do 				let check u = withUrlOptions $ @@ -774,7 +774,7 @@ 		case r of 			Right True -> noop 			_ -> do-				showAction $ "creating bucket in " ++ datacenter+				showAction $ UnquotedString $ "creating bucket in " ++ datacenter 				void $ liftIO $ runResourceT $ sendS3Handle h $  					(S3.putBucket (bucket info)) 						{ S3.pbCannedAcl = acl info@@ -865,7 +865,7 @@  giveupS3HandleProblem :: S3HandleProblem -> UUID -> Annex a giveupS3HandleProblem S3HandleNeedCreds u = do-	warning $ needS3Creds u+	warning $ UnquotedString $ needS3Creds u 	giveup "No S3 credentials configured" giveupS3HandleProblem S3HandleAnonymousOldAws _ = 	giveup "This S3 special remote is configured with signature=anonymous, but git-annex is built with too old a version of the aws library to support that."
Remote/WebDAV.hs view
@@ -321,7 +321,7 @@  	user = toDavUser u 	pass = toDavPass p-testDav _ Nothing = error "Need to configure webdav username and password."+testDav _ Nothing = giveup "Need to configure webdav username and password."  {- Tries to make all the parent directories in the WebDAV urls's path,  - right down to the root.@@ -407,7 +407,7 @@ choke f = do 	x <- f 	case x of-		Left e -> error e+		Left e -> giveup e 		Right r -> return r  data DavHandle = DavHandle DAVContext DavUser DavPass URLString@@ -491,11 +491,11 @@ 				inLocation l $ 					snd <$> getContentM   where-	onerr = error "download failed"+	onerr = giveup "download failed"  checkKeyLegacyChunked :: DavHandle -> CheckPresent checkKeyLegacyChunked dav k = liftIO $-	either error id <$> withStoredFilesLegacyChunked k dav onerr check+	either giveup id <$> withStoredFilesLegacyChunked k dav onerr check   where 	check [] = return $ Right True 	check (l:ls) = do
RemoteDaemon/Core.hs view
@@ -40,7 +40,7 @@ 	let reader = forever $ do 		l <- hGetLine readh 		case parseMessage l of-			Nothing -> error $ "protocol error: " ++ l+			Nothing -> giveup $ "protocol error: " ++ l 			Just cmd -> atomically $ writeTChan ichan cmd 	let writer = forever $ do 		msg <- atomically $ readTChan ochan
Test.hs view
@@ -30,7 +30,7 @@  import qualified Utility.ShellEscape import qualified Annex-import qualified Git.Filename+import qualified Git.Quote import qualified Git.Types import qualified Git.Ref import qualified Git.LsTree@@ -128,7 +128,7 @@ runner opts = parallelTestRunner opts tests  tests :: Int -> Bool -> Bool -> TestOptions -> [TestTree]-tests n crippledfilesystem adjustedbranchok opts = +tests numparts crippledfilesystem adjustedbranchok opts =  	properties  		: withTestMode remotetestmode testRemotes 		: concatMap mkrepotests testmodes@@ -147,11 +147,11 @@ 		| otherwise = Nothing 	mkrepotests (d, te) = map  		(\uts -> withTestMode te uts)-		(repoTests d n)+		(repoTests d numparts)  properties :: TestTree properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $-	[ testProperty "prop_encode_decode_roundtrip" Git.Filename.prop_encode_decode_roundtrip+	[ testProperty "prop_quote_unquote_roundtrip" Git.Quote.prop_quote_unquote_roundtrip 	, testProperty "prop_encode_c_decode_c_roundtrip" Utility.Format.prop_encode_c_decode_c_roundtrip 	, testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode 	, testProperty "prop_isomorphic_shellEscape" Utility.ShellEscape.prop_isomorphic_shellEscape@@ -239,7 +239,7 @@ 		innewrepo $ do 			git_annex "init" [reponame, "--quiet"] "init" 			setupremote remotename-			r <- annexeval $ either error return +			r <- annexeval $ either giveup return  				=<< Remote.byName' remotename 			cache <- Command.TestRemote.newRemoteVariantCache 			unavailr <- annexeval $ Types.Remote.mkUnavailable r@@ -282,8 +282,8 @@ 	, testCase "readonly remote" test_readonly_remote 	, testCase "ignore deleted files" test_ignore_deleted_files 	, testCase "metadata" test_metadata-	, testCase "export_import" test_export_import-	, testCase "export_import_subdir" test_export_import_subdir+	, testCase "export and import" test_export_import+	, testCase "export and import of subdir" test_export_import_subdir 	, testCase "shared clone" test_shared_clone 	, testCase "log" test_log 	, testCase "view" test_view@@ -354,6 +354,7 @@ 	, testCase "required_content" test_required_content 	, testCase "add subdirs" test_add_subdirs 	, testCase "addurl" test_addurl+	, testCase "repair" test_repair 	]   where 	mk l = testGroup groupname (initTests : map adddep l)@@ -439,7 +440,7 @@ 				git_annex "get" [annexedfile] "get failed in first repo" 			make_readonly r1 			indir r2 $ do-				git_annex "sync" ["r1", "--no-push"] "sync with readonly repo"+				git_annex "sync" ["r1", "--no-push", "--no-content"] "sync with readonly repo" 				git_annex "get" [annexedfile, "--from", "r1"] "get from readonly repo" 				git "remote" ["rm", "origin"] "remote rm" 				git_annex "drop" [annexedfile] "drop vs readonly repo"@@ -511,7 +512,7 @@ 	writeFile "text" "test\n"  	git_annex "add" ["binary", "text"] 		"git-annex add with mimeencoding in largefiles"-	git_annex "sync" []+	git_annex "sync" ["--no-content"] 		"git-annex sync" 	(isJust <$> annexeval (Annex.CatFile.catKeyFile (encodeBS "binary"))) 		@? "binary file not added to annex despite mimeencoding config"@@ -1051,13 +1052,13 @@ 	checkunused [] "after rm" 	-- commit the rm, and when on an adjusted branch, sync it back to 	-- the master branch-	git_annex "sync" ["--no-push", "--no-pull"] "git-annex sync"+	git_annex "sync" ["--no-push", "--no-pull", "--no-content"] "git-annex sync" 	checkunused [] "after commit" 	-- unused checks origin/master; once it's gone it is really unused 	git "remote" ["rm", "origin"] "git remote rm origin" 	checkunused [annexedfilekey] "after origin branches are gone" 	git "rm" ["-fq", sha1annexedfile] "git rm"-	git_annex "sync" ["--no-push", "--no-pull"] "git-annex sync"+	git_annex "sync" ["--no-push", "--no-pull", "--no-content"] "git-annex sync" 	checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile"  	-- good opportunity to test dropkey also@@ -1183,7 +1184,7 @@  test_sync :: Assertion test_sync = intmpclonerepo $ do-	git_annex "sync" [] "sync"+	git_annex "sync" ["--no-content"] "sync" 	{- Regression test for bug fixed in 	 - 039e83ed5d1a11fd562cce55b8429c840d72443e, where a present 	 - wanted file was dropped. -}@@ -1239,11 +1240,11 @@ 					git_annex "get" [annexedfile] "get" 					git "remote" ["rm", "origin"] "remote rm" 				forM_ [r3, r2, r1] $ \r -> indir r $-					git_annex "sync" [] ("sync in " ++ r)+					git_annex "sync" ["--no-content"] ("sync in " ++ r) 				forM_ [r3, r2] $ \r -> indir r $ 					git_annex "drop" ["--force", annexedfile] ("drop in " ++ r) 				indir r1 $ do-					git_annex "sync" [] "sync in r1"+					git_annex "sync" ["--no-content"] "sync in r1" 					git_annex_expectoutput "find" ["--in", "r3"] [] 					{- This was the bug. The sync 					 - mangled location log data and it@@ -1269,7 +1270,7 @@ 		{- Sync twice in r1 so it gets the conflict resolution 		 - update from r2 -} 		forM_ [r1, r2, r1] $ \r -> indir r $-			git_annex "sync" ["--force"] ("sync in " ++ rname r)+			git_annex "sync" ["--force", "--no-content"] ("sync in " ++ rname r) 		{- After the sync, it should be possible to get all 		 - files. This includes both sides of the conflict, 		 - although the filenames are not easily predictable.@@ -1289,15 +1290,15 @@ 				disconnectOrigin 				writecontent conflictor "conflictor1" 				add_annex conflictor "add conflicter"-				git_annex "sync" [] "sync in r1"+				git_annex "sync" ["--no-content"] "sync in r1" 			indir r2 $ do 				disconnectOrigin 				writecontent conflictor "conflictor2" 				add_annex conflictor "add conflicter"-				git_annex "sync" [] "sync in r2"+				git_annex "sync" ["--no-content"] "sync in r2" 			pair r1 r2 			forM_ [r1,r2,r1] $ \r -> indir r $-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2   where@@ -1322,19 +1323,19 @@ 				disconnectOrigin 				writecontent conflictor "conflictor1" 				add_annex conflictor "add conflicter"-				git_annex "sync" [] "sync in r1"+				git_annex "sync" ["--no-content"] "sync in r1" 			indir r2 $ do 				disconnectOrigin 				writecontent conflictor "conflictor2" 				add_annex conflictor "add conflicter"-				git_annex "sync" [] "sync in r2"+				git_annex "sync" ["--no-content"] "sync in r2" 				-- We might be in an adjusted branch 				-- already, when eg on a crippled 				-- filesystem. So, --force it. 				git_annex "adjust" ["--unlock", "--force"] "adjust" 			pair r1 r2 			forM_ [r1,r2,r1] $ \r -> indir r $-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2   where@@ -1363,17 +1364,17 @@ 				disconnectOrigin 				writecontent conflictor "conflictor" 				add_annex conflictor "add conflicter"-				git_annex "sync" [] "sync in r1"+				git_annex "sync" ["--no-content"] "sync in r1" 			indir r2 $ do 				disconnectOrigin 				createDirectory conflictor 				writecontent subfile "subfile" 				add_annex conflictor "add conflicter"-				git_annex "sync" [] "sync in r2"+				git_annex "sync" ["--no-content"] "sync in r2" 			pair r1 r2 			let l = if inr1 then [r1, r2] else [r2, r1] 			forM_ l $ \r -> indir r $-				git_annex "sync" [] "sync in mixed conflict"+				git_annex "sync" ["--no-content"] "sync in mixed conflict" 			checkmerge "r1" r1 			checkmerge "r2" r2 	conflictor = "conflictor"@@ -1405,12 +1406,12 @@ 				disconnectOrigin 				writecontent conflictor "conflictor" 				add_annex conflictor "add conflicter"-				git_annex "sync" [] "sync in r1"+				git_annex "sync" ["--no-content"] "sync in r1" 			indir r2 $ 				disconnectOrigin 			pair r1 r2 			indir r2 $ do-				git_annex "sync" [] "sync in r2"+				git_annex "sync" ["--no-content"] "sync in r2" 				git_annex "get" [conflictor] "get conflictor" 				git_annex "unlock" [conflictor] "unlock conflictor" 				writecontent conflictor "newconflictor"@@ -1418,7 +1419,7 @@ 				removeWhenExistsWith R.removeLink (toRawFilePath conflictor) 			let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] 			forM_ l $ \r -> indir r $-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2 	conflictor = "conflictor"@@ -1445,7 +1446,7 @@ 				disconnectOrigin 				writecontent conflictor "conflictor" 				add_annex conflictor "add conflicter"-				git_annex "sync" [] "sync in r1"+				git_annex "sync" ["--no-content"] "sync in r1" 			indir r2 $ do 				disconnectOrigin 				writecontent conflictor nonannexed_content@@ -1454,11 +1455,11 @@ 					, "exclude=" ++ ingitfile ++ " and exclude=" ++ conflictor 					] "git config annex.largefiles" 				git "add" [conflictor] "git add conflictor"-				git_annex "sync" [] "sync in r2"+				git_annex "sync" ["--no-content"] "sync in r2" 			pair r1 r2 			let l = if inr1 then [r1, r2] else [r2, r1] 			forM_ l $ \r -> indir r $-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2 	conflictor = "conflictor"@@ -1495,16 +1496,16 @@ 					disconnectOrigin 					writecontent conflictor "conflictor" 					add_annex conflictor "add conflicter"-					git_annex "sync" [] "sync in r1"+					git_annex "sync" ["--no-content"] "sync in r1" 				indir r2 $ do 					disconnectOrigin 					R.createSymbolicLink (toRawFilePath symlinktarget) (toRawFilePath "conflictor") 					git "add" [conflictor] "git add conflictor"-					git_annex "sync" [] "sync in r2"+					git_annex "sync" ["--no-content"] "sync in r2" 				pair r1 r2 				let l = if inr1 then [r1, r2] else [r2, r1] 				forM_ l $ \r -> indir r $-					git_annex "sync" [] "sync"+					git_annex "sync" ["--no-content"] "sync" 				checkmerge "r1" r1 				checkmerge "r2" r2 	conflictor = "conflictor"@@ -1543,14 +1544,14 @@ 				createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor))) 				writecontent remoteconflictor annexedcontent 				add_annex conflictor "add remoteconflicter"-				git_annex "sync" [] "sync in r1"+				git_annex "sync" ["--no-content"] "sync in r1" 			indir r2 $ do 				disconnectOrigin 				writecontent conflictor localcontent 			pair r1 r2 			-- this case is intentionally not handled 			-- since the user can recover on their own easily-			indir r2 $ git_annex_shouldfail "sync" [] "sync should not succeed"+			indir r2 $ git_annex_shouldfail "sync" ["--no-content"] "sync should not succeed" 	conflictor = "conflictor" 	localcontent = "local" 	annexedcontent = "annexed"@@ -1566,18 +1567,18 @@ 				indir r1 $ do 					writecontent conflictor "conflictor" 					git_annex "add" [conflictor] "add conflicter"-					git_annex "sync" [] "sync in r1"+					git_annex "sync" ["--no-content"] "sync in r1" 					check_is_link conflictor "r1" 				indir r2 $ do 					createDirectory conflictor 					writecontent (conflictor </> "subfile") "subfile" 					git_annex "add" [conflictor] "add conflicter"-					git_annex "sync" [] "sync in r2"+					git_annex "sync" ["--no-content"] "sync in r2" 					check_is_link (conflictor </> "subfile") "r2" 				indir r3 $ do 					writecontent conflictor "conflictor" 					git_annex "add" [conflictor] "add conflicter"-					git_annex "sync" [] "sync in r1"+					git_annex "sync" ["--no-content"] "sync in r1" 					check_is_link (conflictor </> "subfile") "r3"   where 	conflictor = "conflictor"@@ -1598,16 +1599,16 @@ 				disconnectOrigin 				writecontent conflictor "conflictor" 				git_annex "add" [conflictor] "add conflicter"-				git_annex "sync" [] "sync in r1"+				git_annex "sync" ["--no-content"] "sync in r1" 			indir r2 $ do 				disconnectOrigin 				writecontent conflictor "conflictor" 				git_annex "add" [conflictor] "add conflicter" 				git_annex "unlock" [conflictor] "unlock conflicter"-				git_annex "sync" [] "sync in r2"+				git_annex "sync" ["--no-content"] "sync in r2" 			pair r1 r2 			forM_ [r1,r2,r1] $ \r -> indir r $-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 			checkmerge "r1" r1 			checkmerge "r2" r2   where@@ -1644,9 +1645,9 @@ 		git_annex "adjust" ["--unlock", "--force"] "adjust" 		writecontent conflictor "conflictor" 		git_annex "add" [conflictor] "add conflicter"-		git_annex "sync" [] "sync"+		git_annex "sync" ["--no-content"] "sync" 	checkmerge what d = indir d $ whensupported $ do-		git_annex "sync" [] ("sync should not work in " ++ what)+		git_annex "sync" ["--no-content"] ("sync should not work in " ++ what) 		l <- getDirectoryContents "." 		conflictor `elem` l 			@? ("conflictor not present after merge in " ++ what)@@ -1667,11 +1668,11 @@ 			createDirectoryIfMissing True "a/b/c" 			writecontent "a/b/c/d" "foo" 			git_annex "add" ["a/b/c"] "add a/b/c"-			git_annex "sync" [] "sync"+			git_annex "sync" ["--no-content"] "sync" 			createDirectoryIfMissing True "a/b/x" 			writecontent "a/b/x/y" "foo" 			git_annex "add" ["a/b/x"] "add a/b/x"-			git_annex "sync" [] "sync"+			git_annex "sync" ["--no-content"] "sync" 			git "checkout" [origbranch] "git checkout" 			doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") @@ -1807,7 +1808,7 @@ 		testProcess "borg" ["create", borgdir++"::backup1", "."] Nothing (== True) (const True) "borg create"  		git_annex "initremote" (words $ "borg type=borg borgrepo="++borgdir) "initremote"-		git_annex "sync" ["borg"] "sync borg"+		git_annex "sync" ["--no-content", "borg"] "sync borg" 		git_annex_expectoutput "find" ["--in=borg"] []  		git_annex "get" [annexedfile] "get of file"@@ -1815,7 +1816,7 @@ 		git_annex_expectoutput "find" ["--in=borg"] [] 		 		testProcess "borg" ["create", borgdir++"::backup2", "."] Nothing (== True) (const True) "borg create"-		git_annex "sync" ["borg"] "sync borg after getting file"+		git_annex "sync" ["--no-content", "borg"] "sync borg after getting file" 		git_annex_expectoutput "find" ["--in=borg"] [annexedfile]  		git "remote" ["rm", "origin"] "remote rm"@@ -1932,7 +1933,7 @@ 	{- Regression test for Windows bug where symlinks were not 	 - calculated correctly for files in subdirs. -} 	unlessM (hasUnlockedFiles <$> getTestMode) $ do-		git_annex "sync" [] "sync"+		git_annex "sync" ["--no-content"] "sync" 		l <- annexeval $ Utility.FileSystemEncoding.decodeBL 			<$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo")) 		"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)@@ -2008,7 +2009,7 @@ 	-- When on an adjusted branch, this updates the master branch 	-- to match it, which is necessary since the master branch is going 	-- to be exported.-	commitchanges = git_annex "sync" ["--no-pull", "--no-push"] "sync"+	commitchanges = git_annex "sync" ["--no-pull", "--no-push", "--no-content"] "sync"  test_export_import_subdir :: Assertion test_export_import_subdir = intmpclonerepo $ do@@ -2024,7 +2025,7 @@ 	-- When on an adjusted branch, this updates the master branch 	-- to match it, which is necessary since the master branch is going 	-- to be exported.-	git_annex "sync" ["--no-pull", "--no-push"] "sync"+	git_annex "sync" ["--no-pull", "--no-push", "--no-content"] "sync"  	-- Run three times because there was a bug that took a couple 	-- of runs to lead to the wrong tree being written to the remote@@ -2066,12 +2067,12 @@ 				disconnectOrigin 				writecontent wormannexedfile $ content wormannexedfile 				git_annex "add" [wormannexedfile, "--backend=WORM"] "add"-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 			indir r2 $ do 				disconnectOrigin-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 			indir r1 $ do-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 			indir r2 $ do 				git_annex "get" [wormannexedfile] "get" 				git_annex "drop" [wormannexedfile] "drop"@@ -2079,15 +2080,20 @@ 				git_annex "drop" [wormannexedfile] "drop" 			indir r1 $ do 				git_annex "drop" ["--force", wormannexedfile] "drop"-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 				git_annex "forget" ["--force"] "forget"-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 				emptylog 			indir r2 $ do-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 				emptylog 			indir r1 $ do-				git_annex "sync" [] "sync"+				git_annex "sync" ["--no-content"] "sync" 				emptylog   where 	emptylog = git_annex_expectoutput "log" [wormannexedfile] []++test_repair :: Assertion+test_repair = intmpclonerepo $+	-- Simply running repair used to fail on Windows.+	git_annex "repair" [] "repair"
Test/Framework.hs view
@@ -23,6 +23,7 @@ import System.Environment (getArgs) import System.Console.Concurrent import System.Console.ANSI+import Data.Time.Clock import GHC.Conc import System.IO.Unsafe (unsafePerformIO) import System.PosixCompat.Files (isSymbolicLink, isRegularFile, fileMode, unionFileModes, ownerWriteMode)@@ -63,6 +64,7 @@ import qualified Utility.ThreadScheduler import qualified Utility.Tmp.Dir import qualified Utility.Metered+import qualified Utility.HumanTime import qualified Command.Uninit  -- Run a process. The output and stderr is captured, and is only@@ -799,11 +801,20 @@ 			(_, _, _, pid) <- createProcessConcurrent p 			waitForProcess pid 		nvar <- newTVarIO (1, length ts)+		starttime <- getCurrentTime 		exitcodes <- forConcurrently [1..numjobs] $ \_ ->  			worker [] nvar runone 		unless (keepFailuresOption opts) finalCleanup+		duration <- Utility.HumanTime.durationSince starttime 		case nub (filter (/= ExitSuccess) (concat exitcodes)) of-			[] -> exitSuccess+			[] -> do+				putStrLn ""+				putStrLn $ "All tests succeeded. (Ran "+					++ show (length ts) +					++ " test groups in " +					++ Utility.HumanTime.fromDuration duration+					++ ")"+				exitSuccess 			[ExitFailure 1] -> do 				putStrLn "  (Failures above could be due to a bug in git-annex, or an incompatibility" 				putStrLn "   with utilities, such as git, installed on this system.)"
Types/ActionItem.hs view
@@ -1,32 +1,36 @@ {- items that a command can act on  -- - Copyright 2016-2019 Joey Hess <id@joeyh.name>+ - Copyright 2016-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -module Types.ActionItem where+module Types.ActionItem (+	module Types.ActionItem,+	StringContainingQuotedPath(..),+) where  import Key import Types.Transfer+import Types.UUID import Git.FilePath+import Git.Quote (StringContainingQuotedPath(..)) import Utility.FileSystemEncoding -import Data.Maybe-import qualified Data.ByteString as S- data ActionItem  	= ActionItemAssociatedFile AssociatedFile Key 	| ActionItemKey Key 	| ActionItemBranchFilePath BranchFilePath Key 	| ActionItemFailedTransfer Transfer TransferInfo 	| ActionItemTreeFile RawFilePath-	| ActionItemOther (Maybe String)-	-- Use to avoid more than one thread concurrently processing the-	-- same Key.+	| ActionItemUUID UUID StringContainingQuotedPath+	-- ^ UUID with a description or name of the repository+	| ActionItemOther (Maybe StringContainingQuotedPath) 	| OnlyActionOn Key ActionItem+	-- ^ Use to avoid more than one thread concurrently processing the+	-- same Key. 	deriving (Show, Eq)  class MkActionItem t where@@ -56,16 +60,21 @@ instance MkActionItem (Transfer, TransferInfo) where 	mkActionItem = uncurry ActionItemFailedTransfer -actionItemDesc :: ActionItem -> S.ByteString-actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f+actionItemDesc :: ActionItem -> StringContainingQuotedPath+actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = +	QuotedPath f actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = -	serializeKey' k-actionItemDesc (ActionItemKey k) = serializeKey' k-actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp+	UnquotedByteString (serializeKey' k)+actionItemDesc (ActionItemKey k) =+	UnquotedByteString (serializeKey' k)+actionItemDesc (ActionItemBranchFilePath bfp _) =+	descBranchFilePath bfp actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $ 	ActionItemAssociatedFile (associatedFile i) (transferKey t)-actionItemDesc (ActionItemTreeFile f) = f-actionItemDesc (ActionItemOther s) = encodeBS (fromMaybe "" s)+actionItemDesc (ActionItemTreeFile f) = QuotedPath f+actionItemDesc (ActionItemUUID _ desc) = desc+actionItemDesc (ActionItemOther Nothing) = mempty+actionItemDesc (ActionItemOther (Just v)) = v actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai  actionItemKey :: ActionItem -> Maybe Key@@ -74,14 +83,20 @@ actionItemKey (ActionItemBranchFilePath _ k) = Just k actionItemKey (ActionItemFailedTransfer t _) = Just (transferKey t) actionItemKey (ActionItemTreeFile _) = Nothing+actionItemKey (ActionItemUUID _ _) = Nothing actionItemKey (ActionItemOther _) = Nothing actionItemKey (OnlyActionOn _ ai) = actionItemKey ai  actionItemFile :: ActionItem -> Maybe RawFilePath actionItemFile (ActionItemAssociatedFile (AssociatedFile af) _) = af actionItemFile (ActionItemTreeFile f) = Just f+actionItemFile (ActionItemUUID _ _) = Nothing actionItemFile (OnlyActionOn _ ai) = actionItemFile ai actionItemFile _ = Nothing++actionItemUUID :: ActionItem -> Maybe UUID+actionItemUUID (ActionItemUUID uuid _) = Just uuid+actionItemUUID _ = Nothing  actionItemTransferDirection :: ActionItem -> Maybe Direction actionItemTransferDirection (ActionItemFailedTransfer t _) = Just $
Types/Command.hs view
@@ -24,7 +24,7 @@ type CommandParser = Parser CommandSeek {- b. The check stage runs checks, that error out if  -    anything prevents the command from running. -}-data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () }+data CommandCheck = CommandCheck { idCheck :: CommandCheckId, runCheck :: Annex () } {- c. The seek stage is passed input from the parser, looks through  -    the repo to find things to act on (ie, new files to add), and  -    runs commandAction to handle all necessary actions. -}@@ -136,3 +136,10 @@  newtype DryRun = DryRun Bool 	deriving (Show)++data CommandCheckId +	= CheckNotBareRepo+	| RepoExists+	| NoDaemonRunning+	| GitAnnexShellOk+	deriving (Show, Ord, Eq)
Types/GitConfig.hs view
@@ -32,6 +32,7 @@ import Git.ConfigTypes import Git.Remote (isRemoteKey, remoteKeyToRemoteName) import Git.Branch (CommitMode(..))+import Git.Quote (QuotePath(..)) import Utility.DataUnits import Config.Cost import Types.UUID@@ -92,7 +93,7 @@ 	, annexHttpHeadersCommand :: Maybe String 	, annexAutoCommit :: GlobalConfigurable Bool 	, annexResolveMerge :: GlobalConfigurable Bool-	, annexSyncContent :: GlobalConfigurable Bool+	, annexSyncContent :: GlobalConfigurable (Maybe Bool) 	, annexSyncOnlyAnnex :: GlobalConfigurable Bool 	, annexDebug :: Bool 	, annexDebugFilter :: Maybe String@@ -140,6 +141,7 @@ 	, annexSupportUnlocked :: Bool 	, coreSymlinks :: Bool 	, coreSharedRepository :: SharedRepository+	, coreQuotePath :: QuotePath 	, receiveDenyCurrentBranch :: DenyCurrentBranch 	, gcryptId :: Maybe String 	, gpgCmd :: GpgCmd@@ -179,7 +181,7 @@ 		getmaybebool (annexConfig "autocommit") 	, annexResolveMerge = configurable True $  		getmaybebool (annexConfig "resolvemerge")-	, annexSyncContent = configurable False $ +	, annexSyncContent = configurablemaybe $  		getmaybebool (annexConfig "synccontent") 	, annexSyncOnlyAnnex = configurable False $  		getmaybebool (annexConfig "synconlyannex")@@ -250,6 +252,7 @@ 	, annexSupportUnlocked = getbool (annexConfig "supportunlocked") True 	, coreSymlinks = getbool "core.symlinks" True 	, coreSharedRepository = getSharedRepository r+	, coreQuotePath = QuotePath (getbool "core.quotepath" True) 	, receiveDenyCurrentBranch = getDenyCurrentBranch r 	, gcryptId = getmaybe "core.gcrypt-id" 	, gpgCmd = mkGpgCmd (getmaybe "gpg.program")@@ -284,6 +287,11 @@ 	configurable _ (Just v) = case configsource of 		FromGitConfig -> HasGitConfig v 		FromGlobalConfig -> HasGlobalConfig v+	+	configurablemaybe Nothing = DefaultConfig Nothing+	configurablemaybe (Just v) = case configsource of+		FromGitConfig -> HasGitConfig (Just v)+		FromGlobalConfig -> HasGlobalConfig (Just v)  	onemegabyte = 1000000
Types/Import.hs view
@@ -1,11 +1,11 @@ {- git-annex import types  -- - Copyright 2019-2021 Joey Hess <id@joeyh.name>+ - Copyright 2019-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric, DeriveFunctor #-}  module Types.Import where @@ -67,7 +67,7 @@ 	-- locations. So, if a remote does not support Key/Value access, 	-- it should not populate the importableHistory. 	}-	deriving (Show, Generic)+	deriving (Show, Generic, Functor)  instance NFData info => NFData (ImportableContents info) @@ -81,6 +81,7 @@ 		, importableHistoryComplete :: [ImportableContents info] 		-- ^ Chunking the history is not supported 		}+	deriving (Functor)  {- A chunk of ImportableContents, which is the entire content of a subtree  - of the main tree. Nested subtrees are not allowed. -}@@ -92,6 +93,7 @@ 	-- ^ Continuation to get the next chunk. 	-- Returns Nothing when there are no more chunks. 	}+	deriving (Functor)  newtype ImportChunkSubDir = ImportChunkSubDir { importChunkSubDir :: RawFilePath }
Types/Messages.hs view
@@ -84,3 +84,9 @@ data SerializedOutputResponse 	= ReadyPrompt 	deriving (Eq, Show)++-- | Message identifiers. Avoid changing these.+data MessageId+	= FileNotFound+	| FileBeyondSymbolicLink+	deriving (Show)
Types/Transferrer.hs view
@@ -15,6 +15,7 @@ import Utility.Metered (TotalSize(..))  import Data.Char+import qualified Data.ByteString.Lazy as L  -- Sent to start a transfer. data TransferRequest@@ -82,9 +83,9 @@  instance Proto.Sendable TransferResponse where 	formatMessage (TransferOutput (OutputMessage m)) =-		["om", Proto.serialize (encode_c (decodeBS m))]+		["om", Proto.serialize (decodeBS (encode_c isUtf8Byte m))] 	formatMessage (TransferOutput (OutputError e)) =-		["oe", Proto.serialize (encode_c e)]+		["oe", Proto.serialize (decodeBS (encode_c isUtf8Byte (encodeBS e)))] 	formatMessage (TransferOutput BeginProgressMeter) = 		["opb"] 	formatMessage (TransferOutput (UpdateProgressMeterTotalSize (TotalSize sz))) =@@ -98,7 +99,7 @@ 	formatMessage (TransferOutput EndPrompt) = 		["opre"] 	formatMessage (TransferOutput (JSONObject b)) =-		["oj", Proto.serialize (encode_c (decodeBL b))]+		["oj", Proto.serialize (decodeBS (encode_c isUtf8Byte (L.toStrict b)))] 	formatMessage (TransferResult True) = 		["t"] 	formatMessage (TransferResult False) =@@ -106,9 +107,9 @@  instance Proto.Receivable TransferResponse where 	parseCommand "om" = Proto.parse1 $-		TransferOutput . OutputMessage . encodeBS . decode_c+		TransferOutput . OutputMessage . decode_c . encodeBS 	parseCommand "oe" = Proto.parse1 $-		TransferOutput . OutputError . decode_c+		TransferOutput . OutputError . decodeBS . decode_c . encodeBS 	parseCommand "opb" = Proto.parse0 $ 		TransferOutput BeginProgressMeter 	parseCommand "ops" = Proto.parse1 $@@ -122,7 +123,7 @@ 	parseCommand "opre" = Proto.parse0 $ 		TransferOutput EndPrompt 	parseCommand "oj" = Proto.parse1 $-		TransferOutput . JSONObject . encodeBL . decode_c+		TransferOutput . JSONObject . L.fromStrict . decode_c . encodeBS 	parseCommand "t" = Proto.parse0 $ 		TransferResult True 	parseCommand "f" = Proto.parse0 $@@ -140,20 +141,22 @@ 	serialize (TransferRemoteUUID u) = 'u':fromUUID u 	-- A remote name could contain whitespace or newlines, which needs 	-- to be escaped for the protocol. Use C-style encoding.-	serialize (TransferRemoteName r) = 'r':encode_c' isSpace r+	serialize (TransferRemoteName r) = 'r':decodeBS (encode_c is_space_or_unicode (encodeBS r))+	  where+		is_space_or_unicode c = isUtf8Byte c || isSpace (chr (fromIntegral c))  	deserialize ('u':u) = Just (TransferRemoteUUID (toUUID u))-	deserialize ('r':r) = Just (TransferRemoteName (decode_c r))+	deserialize ('r':r) = Just (TransferRemoteName (decodeBS (decode_c (encodeBS r)))) 	deserialize _ = Nothing  instance Proto.Serializable TransferAssociatedFile where 	-- Comes last, so whitespace is ok. But, in case the filename 	-- contains eg a newline, escape it. Use C-style encoding. 	serialize (TransferAssociatedFile (AssociatedFile (Just f))) =-		encode_c (fromRawFilePath f)+		decodeBS (encode_c isUtf8Byte f) 	serialize (TransferAssociatedFile (AssociatedFile Nothing)) = ""  	deserialize "" = Just $ TransferAssociatedFile $ 		AssociatedFile Nothing 	deserialize s = Just $ TransferAssociatedFile $-		AssociatedFile $ Just $ toRawFilePath $ decode_c s+		AssociatedFile $ Just $ decode_c $ encodeBS s
Types/UUID.hs view
@@ -1,6 +1,6 @@ {- git-annex UUID type  -- - Copyright 2011-2019 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU AGPL version 3 or higher.  -}@@ -10,6 +10,7 @@ module Types.UUID where  import qualified Data.ByteString as B+import qualified Data.Text as T import qualified Data.Map as M import qualified Data.UUID as U import Data.Maybe@@ -20,6 +21,7 @@ import Git.Types (ConfigValue(..)) import Utility.FileSystemEncoding import Utility.QuickCheck+import Utility.Aeson import qualified Utility.SimpleProtocol as Proto  -- A UUID is either an arbitrary opaque string, or UUID info may be missing.@@ -64,6 +66,18 @@ -- be NoUUID or perhaps contain something not allowed in a canonical UUID. instance ToUUID U.UUID where 	toUUID = toUUID . U.toASCIIBytes++instance ToJSON' UUID where+	toJSON' (UUID u) = toJSON' u+	toJSON' NoUUID = toJSON' ""++instance FromJSON UUID where+	parseJSON (String t)+		| isUUID s = pure (toUUID s)+		| otherwise = mempty+	  where+		s = T.unpack t+	parseJSON _ = mempty  buildUUID :: UUID -> Builder buildUUID (UUID b) = byteString b
Upgrade/V0.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Upgrade.V0 where  import Annex.Common
Upgrade/V1.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Upgrade.V1 where  import System.Posix.Types@@ -211,7 +213,7 @@ 		Nothing -> do 			unless (null kname || null bname || 			        not (isLinkToAnnex (toRawFilePath l))) $-				warning skip+				warning (UnquotedString skip) 			return Nothing 		Just backend -> return $ Just (k, backend) 	  where
Upgrade/V2.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Upgrade.V2 where  import Annex.Common@@ -120,7 +122,7 @@ 			-- no origin exists, so just let the user 			-- know about the new branch 			void Annex.Branch.update-			showLongNote $+			showLongNote $ UnquotedString $ 				"git-annex branch created\n" ++ 				"Be sure to push this branch when pushing to remotes.\n"
Upgrade/V5.hs view
@@ -59,7 +59,7 @@ 	return UpgradeSuccess   where 	onexception e = do-		warning $ "caught exception: " ++ show e+		warning $ UnquotedString $ "caught exception: " ++ show e 		return UpgradeFailed  -- git before 2.22 would OOM running git status on a large file.
Upgrade/V6.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Upgrade.V6 where  import Annex.Common
Upgrade/V8.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Upgrade.V8 where  import Annex.Common
Upgrade/V9.hs view
@@ -5,6 +5,8 @@  - Licensed under the GNU AGPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Upgrade.V9 where  import Annex.Common@@ -29,7 +31,7 @@ 		) 	| otherwise = ifM (oldprocessesdanger <&&> (not <$> Annex.getRead Annex.force)) 		( do-			warning $ unlines unsafeupgrade+			warning $ UnquotedString $ unlines unsafeupgrade 			return UpgradeDeferred 		, performUpgrade automatic 		)
Utility/Aeson.hs view
@@ -2,7 +2,7 @@  -  - Import instead of Data.Aeson  -- - Copyright 2018-2019 Joey Hess <id@joeyh.name>+ - Copyright 2018-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -33,6 +33,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S import qualified Data.Set+import qualified Data.Map import qualified Data.Vector import Prelude @@ -99,6 +100,11 @@ -- Aeson generates the same JSON for a Set as for a list. instance ToJSON' s => ToJSON' (Data.Set.Set s) where 	toJSON' = toJSON . map toJSON' . Data.Set.toList++instance (ToJSON' v) => ToJSON' (Data.Map.Map T.Text v) where+	toJSON' m = object $ map go (Data.Map.toList m)+	  where+		go (k, v) = (textKey k, toJSON' v)  instance (ToJSON' a, ToJSON a) => ToJSON' (Maybe a) where 	toJSON' (Just a) = toJSON (Just (toJSON' a))
Utility/AuthToken.hs view
@@ -20,6 +20,7 @@  import qualified Utility.SimpleProtocol as Proto import Utility.Hash+import Utility.Exception  import Data.SecureMem import Data.Maybe@@ -79,8 +80,8 @@ 	g <- newGenIO :: IO SystemRandom 	return $ 		case genBytes 512 g of-			Left e -> error $ "failed to generate auth token: " ++ show e-			Right (s, _) -> fromMaybe (error "auth token encoding failed") $+			Left e -> giveup $ "failed to generate auth token: " ++ show e+			Right (s, _) -> fromMaybe (giveup "auth token encoding failed") $ 				toAuthToken $ T.pack $ take len $ 					show $ sha2_512 $ L.fromChunks [s]
Utility/Base64.hs view
@@ -11,6 +11,7 @@  import Utility.FileSystemEncoding import Utility.QuickCheck+import Utility.Exception  import qualified "sandi" Codec.Binary.Base64 as B64 import Data.Maybe@@ -36,12 +37,12 @@ fromB64 :: String -> String fromB64 = fromMaybe bad . fromB64Maybe   where-	bad = error "bad base64 encoded data"+	bad = giveup "bad base64 encoded data"  fromB64' :: B.ByteString -> B.ByteString fromB64' = fromMaybe bad . fromB64Maybe'   where-	bad = error "bad base64 encoded data"+	bad = giveup "bad base64 encoded data"  -- Only ascii strings are tested, because an arbitrary string may contain -- characters not encoded using the FileSystemEncoding, which would thus
Utility/Exception.hs view
@@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more)  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -20,6 +20,7 @@ 	bracketIO, 	catchNonAsync, 	tryNonAsync,+	nonAsyncHandler, 	tryWhenExists, 	catchIOErrorType, 	IOErrorType(..),@@ -28,21 +29,24 @@  import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M-import Control.Exception (IOException, AsyncException)-import Control.Exception (SomeAsyncException)+import Control.Exception (IOException, AsyncException, SomeAsyncException) import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) import GHC.IO.Exception (IOErrorType(..))  import Utility.Data+import Utility.SafeOutput  {- Like error, this throws an exception. Unlike error, if this exception  - is not caught, it won't generate a backtrace. So use this for situations  - where there's a problem that the user is expected to see in some- - circumstances. -}+ - circumstances.+ -+ - Also, control characters are filtered out of the message.+ -} giveup :: [Char] -> a-giveup = errorWithoutStackTrace+giveup = errorWithoutStackTrace . safeOutput  {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool@@ -81,11 +85,7 @@  - ThreadKilled and UserInterrupt get through.  -} catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a-catchNonAsync a onerr = a `catches`-	[ M.Handler (\ (e :: AsyncException) -> throwM e)-	, M.Handler (\ (e :: SomeAsyncException) -> throwM e)-	, M.Handler (\ (e :: SomeException) -> onerr e)-	]+catchNonAsync a onerr = a `catches` (nonAsyncHandler onerr)  tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) tryNonAsync a = go `catchNonAsync` (return . Left)@@ -93,6 +93,13 @@ 	go = do 		v <- a 		return (Right v)++nonAsyncHandler :: MonadCatch m => (SomeException -> m a) -> [M.Handler m a]+nonAsyncHandler onerr = +	[ M.Handler (\ (e :: AsyncException) -> throwM e)+	, M.Handler (\ (e :: SomeAsyncException) -> throwM e)+	, M.Handler (\ (e :: SomeException) -> onerr e)+	]  {- Catches only DoesNotExist exceptions, and lets all others through. -} tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
Utility/FileMode.hs view
@@ -1,6 +1,6 @@ {- File mode utilities.  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -103,17 +103,20 @@ isExecutable :: FileMode -> Bool isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 -{- Runs an action without that pesky umask influencing it, unless the- - passed FileMode is the standard one. -}-noUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a-#ifndef mingw32_HOST_OS-noUmask mode a-	| mode == stdFileMode = a-	| otherwise = withUmask nullFileMode a-#else-noUmask _ a = a-#endif+data ModeSetter = ModeSetter FileMode (RawFilePath -> IO ()) +{- Runs an action which should create the file, passing it the desired+ - initial file mode. Then runs the ModeSetter's action on the file, which+ - can adjust the initial mode if umask prevented the file from being+ - created with the right mode. -}+applyModeSetter :: Maybe ModeSetter -> RawFilePath -> (Maybe FileMode -> IO a) -> IO a+applyModeSetter (Just (ModeSetter mode modeaction)) file a = do+	r <- a (Just mode)+	void $ tryIO $ modeaction file+	return r+applyModeSetter Nothing _ a = +	a Nothing+ withUmask :: (MonadIO m, MonadMask m) => FileMode -> m a -> m a #ifndef mingw32_HOST_OS withUmask umask a = bracket setup cleanup go@@ -172,10 +175,10 @@ 	(\h -> hPutStr h content)  writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO ()-writeFileProtected' file writer = protectedOutput $-	withFile (fromRawFilePath file) WriteMode $ \h -> do-		void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes-		writer h+writeFileProtected' file writer = do+	h <- protectedOutput $ openFile (fromRawFilePath file) WriteMode+	void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes+	writer h  protectedOutput :: IO a -> IO a protectedOutput = withUmask 0o0077
Utility/Format.hs view
@@ -1,6 +1,6 @@ {- Formatted string handling.  -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -9,10 +9,12 @@ 	Format, 	gen, 	format,+	escapedFormat, 	formatContainsVar, 	decode_c, 	encode_c, 	encode_c',+	isUtf8Byte, 	prop_encode_c_decode_c_roundtrip ) where @@ -21,12 +23,11 @@ import Data.Maybe (fromMaybe) import Data.Word (Word8) import Data.List (isPrefixOf)-import qualified Codec.Binary.UTF8.String import qualified Data.Map as M+import qualified Data.ByteString as S  import Utility.PartialPrelude--type FormatString = String+import Utility.FileSystemEncoding  {- A format consists of a list of fragments. -} type Format = [Frag]@@ -53,7 +54,8 @@   where 	expand (Const s) = s 	expand (Var name j esc)-		| esc = justify j $ encode_c' isSpace $ getvar name+		| esc = justify j $ decodeBS $ escapedFormat $+			encodeBS $ getvar name 		| otherwise = justify j $ getvar name 	getvar name = fromMaybe "" $ M.lookup name vars 	justify UnJustified s        = s@@ -62,6 +64,13 @@ 	pad i s = take (i - length s) spaces 	spaces = repeat ' ' +escapedFormat :: S.ByteString -> S.ByteString+escapedFormat = encode_c needescape+  where+	needescape c = isUtf8Byte c ||+		isSpace (chr (fromIntegral c)) ||+		c == fromIntegral (ord '"')+ {- Generates a Format that can be used to expand variables in a  - format string, such as "${foo} ${bar;10} ${baz;-10}\n"  -@@ -69,8 +78,8 @@  -  - Also, "${escaped_foo}" will apply encode_c to the value of variable foo.  -}-gen :: FormatString -> Format-gen = filter (not . empty) . fuse [] . scan [] . decode_c+gen :: String -> Format+gen = filter (not . empty) . fuse [] . scan [] . decodeBS . decode_c . encodeBS   where 	-- The Format is built up in reverse, for efficiency, 	-- and can have many adjacent Consts. Fusing it fixes both@@ -122,33 +131,50 @@ {- Decodes a C-style encoding, where \n is a newline (etc),  - \NNN is an octal encoded character, and \xNN is a hex encoded character.  -}-decode_c :: FormatString -> String-decode_c [] = []-decode_c s = unescape ("", s)+decode_c :: S.ByteString -> S.ByteString+decode_c s+	| S.null s = S.empty+	| otherwise = unescape (S.empty, s)   where-	e = '\\'-	unescape (b, []) = b-	-- look for escapes starting with '\'-	unescape (b, v) = b ++ fst pair ++ unescape (handle $ snd pair)+	e = fromIntegral (ord '\\')+	x = fromIntegral (ord 'x')+	isescape c = c == e+	unescape (b, v)+		| S.null v = b+		| otherwise = b <> fst pair <> unescape (handle $ snd pair) 	  where-		pair = span (/= e) v-	isescape x = x == e-	handle (x:'x':n1:n2:rest)-		| isescape x && allhex = (fromhex, rest)+		pair = S.span (not . isescape) v+	handle b+		| S.length b >= 1 && isescape (S.index b 0) = handle' b+		| otherwise = (S.empty, b)+	+	handle' b+		| S.length b >= 4+			&& S.index b 1 == x+			&& allhex = (fromhex, rest) 	  where+		n1 = chr (fromIntegral (S.index b 2))+		n2 = chr (fromIntegral (S.index b 3))+	  	rest = S.drop 4 b 		allhex = isHexDigit n1 && isHexDigit n2-		fromhex = [chr $ readhex [n1, n2]]+		fromhex = encodeBS [chr $ readhex [n1, n2]] 		readhex h = Prelude.read $ "0x" ++ h :: Int-	handle (x:n1:n2:n3:rest)-		| isescape x && alloctal = (fromoctal, rest)+	handle' b+		| S.length b >= 4 && alloctal = (fromoctal, rest) 	  where+		n1 = chr (fromIntegral (S.index b 1))+		n2 = chr (fromIntegral (S.index b 2))+		n3 = chr (fromIntegral (S.index b 3))+	  	rest = S.drop 4 b 		alloctal = isOctDigit n1 && isOctDigit n2 && isOctDigit n3-		fromoctal = [chr $ readoctal [n1, n2, n3]]+		fromoctal = encodeBS [chr $ readoctal [n1, n2, n3]] 		readoctal o = Prelude.read $ "0o" ++ o :: Int-	-- \C is used for a few special characters-	handle (x:nc:rest)-		| isescape x = ([echar nc], rest)+	handle' b+		| S.length b >= 2 = +			(S.singleton (fromIntegral (ord (echar nc))), rest) 	  where+		nc = chr (fromIntegral (S.index b 1))+		rest = S.drop 2 b 		echar 'a' = '\a' 		echar 'b' = '\b' 		echar 'f' = '\f'@@ -156,39 +182,51 @@ 		echar 'r' = '\r' 		echar 't' = '\t' 		echar 'v' = '\v'-		echar a = a-	handle n = ("", n)+		echar a = a -- \\ decodes to '\', and \" to '"'+	handle' b = (S.empty, b) -{- Inverse of decode_c. -}-encode_c :: String -> FormatString-encode_c = encode_c' (const False)+{- Inverse of decode_c. Encodes ascii control characters as well as+ - bytes that match the predicate. (And also '\' itself.)+ -}+encode_c :: (Word8 -> Bool) -> S.ByteString -> S.ByteString+encode_c p s = fromMaybe s (encode_c' p s) -{- Encodes special characters, as well as any matching the predicate. -}-encode_c' :: (Char -> Bool) -> String -> FormatString-encode_c' p = concatMap echar+{- Returns Nothing when nothing needs to be escaped in the input ByteString. -}+encode_c' :: (Word8 -> Bool) -> S.ByteString -> Maybe S.ByteString+encode_c' p s+	| S.any needencode s = Just (S.concatMap echar s)+	| otherwise = Nothing   where-	e c = '\\' : [c]-	echar '\a' = e 'a'-	echar '\b' = e 'b'-	echar '\f' = e 'f'-	echar '\n' = e 'n'-	echar '\r' = e 'r'-	echar '\t' = e 't'-	echar '\v' = e 'v'-	echar '\\' = e '\\'-	echar '"'  = e '"'+	e = fromIntegral (ord '\\')+	q = fromIntegral (ord '"')+	del = 0x7F+	iscontrol c = c < 0x20++	echar 0x7 = ec 'a'+	echar 0x8 = ec 'b'+	echar 0x0C = ec 'f'+	echar 0x0A = ec 'n'+	echar 0x0D = ec 'r'+	echar 0x09 = ec 't'+	echar 0x0B = ec 'v' 	echar c-		| ord c < 0x20 = e_asc c -- low ascii-		| ord c >= 256 = e_utf c -- unicode-		| ord c > 0x7E = e_asc c -- high ascii-		| p c          = e_asc c-		| otherwise    = [c]-	-- unicode character is decomposed to individual Word8s,-	-- and each is shown in octal-	e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8])-	e_asc c = showoctal $ ord c-	showoctal i = '\\' : printf "%03o" i+		| iscontrol c = showoctal c -- other control characters+		| c == e = ec '\\' -- escape the escape character itself+		| c == del = showoctal c+		| p c = if c == q+			then ec '"' -- escape double quote+			else showoctal c+		| otherwise = S.singleton c+	+	needencode c = iscontrol c || c == e || c == del || p c +	ec c = S.pack [e, fromIntegral (ord c)]++	showoctal i = encodeBS ('\\' : printf "%03o" i)++isUtf8Byte :: Word8 -> Bool+isUtf8Byte c = c >= 0x80+ {- For quickcheck.   -  - Encoding and then decoding roundtrips only when@@ -198,6 +236,7 @@  - This property papers over the problem, by only testing ascii.  -} prop_encode_c_decode_c_roundtrip :: String -> Bool-prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s')+prop_encode_c_decode_c_roundtrip s = s' == +	decodeBS (decode_c (encode_c isUtf8Byte (encodeBS s')))   where 	s' = filter isAscii s
Utility/Gpg.hs view
@@ -248,7 +248,7 @@ 		-- If the userid contains a ":" or a few other special 		-- characters, gpg will hex-escape it. Use decode_c to 		-- undo.-		extract ((keyid, decode_c userid):c) Nothing rest+		extract ((keyid, decodeBS (decode_c (encodeBS userid))):c) Nothing rest 	extract c (Just keyid) rest@(("sec":_):_) = 		extract ((keyid, ""):c) Nothing rest 	extract c (Just keyid) (_:rest) =@@ -302,7 +302,10 @@  - It is armored, to avoid newlines, since gpg only reads ciphers up to the  - first newline. -} genRandom :: GpgCmd -> Bool -> Size -> IO String-genRandom cmd highQuality size = checksize <$> readStrict cmd params+genRandom cmd highQuality size = do+	s <- readStrict cmd params+	checksize s+	return s   where 	params =  		[ Param "--gen-random"@@ -325,9 +328,8 @@ 	expectedlength = size * 8 `div` 6  	checksize s = let len = length s in-		if len >= expectedlength-			then s-			else shortread len+		unless (len >= expectedlength) $+			shortread len  	shortread got = giveup $ unwords 		[ "Not enough bytes returned from gpg", show params
Utility/Hash.hs view
@@ -10,6 +10,7 @@ module Utility.Hash ( 	sha1, 	sha1_context,+	sha1s, 	sha2_224, 	sha2_224_context, 	sha2_256,@@ -83,6 +84,9 @@  sha1_context :: Context SHA1 sha1_context = hashInit++sha1s :: S.ByteString -> Digest SHA1+sha1s = hash  sha2_224 :: L.ByteString -> Digest SHA224 sha2_224 = hashlazy
Utility/LockFile/PidLock.hs view
@@ -83,8 +83,7 @@ trySideLock lockfile a = do 	sidelock <- sideLockFile lockfile 	mlck <- catchDefaultIO Nothing $ -		withUmask nullFileMode $-			Posix.tryLockExclusive (Just mode) sidelock+		Posix.tryLockExclusive (Just modesetter) sidelock 	-- Check the lock we just took, in case we opened a side lock file 	-- belonging to another process that will have since deleted it. 	case mlck of@@ -100,6 +99,7 @@ 	-- delete another user's lock file there, so could not 	-- delete a stale lock. 	mode = combineModes (readModes ++ writeModes)+	modesetter = ModeSetter mode (\f -> modifyFileMode f (const mode))  dropSideLock :: SideLockHandle -> IO () dropSideLock Nothing = return ()
Utility/LockFile/Posix.hs view
@@ -1,6 +1,6 @@ {- Posix lock files  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2023 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -22,6 +22,7 @@  import Utility.Exception import Utility.Applicative+import Utility.FileMode import Utility.LockFile.LockStatus  import System.IO@@ -36,31 +37,31 @@ newtype LockHandle = LockHandle Fd  -- Takes a shared lock, blocking until the lock is available.-lockShared :: Maybe FileMode -> LockFile -> IO LockHandle+lockShared :: Maybe ModeSetter -> LockFile -> IO LockHandle lockShared = lock ReadLock  -- Takes an exclusive lock, blocking until the lock is available.-lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle+lockExclusive :: Maybe ModeSetter -> LockFile -> IO LockHandle lockExclusive = lock WriteLock  -- Tries to take a shared lock, but does not block.-tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)+tryLockShared :: Maybe ModeSetter -> LockFile -> IO (Maybe LockHandle) tryLockShared = tryLock ReadLock  -- Tries to take an exclusive lock, but does not block.-tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)+tryLockExclusive :: Maybe ModeSetter -> LockFile -> IO (Maybe LockHandle) tryLockExclusive = tryLock WriteLock  -- Setting the FileMode allows creation of a new lock file. -- If it's Nothing then this only succeeds when the lock file already exists.-lock :: LockRequest -> Maybe FileMode -> LockFile -> IO LockHandle+lock :: LockRequest -> Maybe ModeSetter -> LockFile -> IO LockHandle lock lockreq mode lockfile = do 	l <- openLockFile lockreq mode lockfile 	waitToSetLock l (lockreq, AbsoluteSeek, 0, 0) 	return (LockHandle l)  -- Tries to take an lock, but does not block.-tryLock :: LockRequest -> Maybe FileMode -> LockFile -> IO (Maybe LockHandle)+tryLock :: LockRequest -> Maybe ModeSetter -> LockFile -> IO (Maybe LockHandle) tryLock lockreq mode lockfile = uninterruptibleMask_ $ do 	l <- openLockFile lockreq mode lockfile 	v <- tryIO $ setLock l (lockreq, AbsoluteSeek, 0, 0)@@ -71,9 +72,10 @@ 		Right _ -> return $ Just $ LockHandle l  -- Close on exec flag is set so child processes do not inherit the lock.-openLockFile :: LockRequest -> Maybe FileMode -> LockFile -> IO Fd+openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd openLockFile lockreq filemode lockfile = do-	l <- openFd lockfile openfor filemode defaultFileFlags+	l <- applyModeSetter filemode lockfile $ \filemode' ->+		openFd lockfile openfor filemode' defaultFileFlags 	setFdOption l CloseOnExec True 	return l   where
Utility/LockPool/Posix.hs view
@@ -24,6 +24,7 @@ import qualified Utility.LockPool.STM as P import Utility.LockPool.STM (LockFile, LockMode(..)) import Utility.LockPool.LockHandle+import Utility.FileMode  import System.IO import System.Posix@@ -32,25 +33,25 @@ import Prelude  -- Takes a shared lock, blocking until the lock is available.-lockShared :: Maybe FileMode -> LockFile -> IO LockHandle+lockShared :: Maybe ModeSetter -> LockFile -> IO LockHandle lockShared mode file = fst <$> makeLockHandle P.lockPool file 	(\p f -> P.waitTakeLock p f LockShared) 	(\f _ -> mk <$> F.lockShared mode f)  -- Takes an exclusive lock, blocking until the lock is available.-lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle+lockExclusive :: Maybe ModeSetter -> LockFile -> IO LockHandle lockExclusive mode file = fst <$> makeLockHandle P.lockPool file 	(\p f -> P.waitTakeLock p f LockExclusive) 	(\f _ -> mk <$> F.lockExclusive mode f)  -- Tries to take a shared lock, but does not block.-tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)+tryLockShared :: Maybe ModeSetter -> LockFile -> IO (Maybe LockHandle) tryLockShared mode file = fmap fst <$> tryMakeLockHandle P.lockPool file 	(\p f -> P.tryTakeLock p f LockShared) 	(\f _ -> fmap mk <$> F.tryLockShared mode f)  -- Tries to take an exclusive lock, but does not block.-tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)+tryLockExclusive :: Maybe ModeSetter -> LockFile -> IO (Maybe LockHandle) tryLockExclusive mode file = fmap fst <$> tryMakeLockHandle P.lockPool file 	(\p f -> P.tryTakeLock p f LockExclusive) 	(\f _ -> fmap mk <$> F.tryLockExclusive mode f)
Utility/Lsof.hs view
@@ -110,4 +110,4 @@  	splitnull = splitc '\0' -	parsefail = error $ "failed to parse lsof output: " ++ show s+	parsefail = giveup $ "failed to parse lsof output: " ++ show s
Utility/Metered.hs view
@@ -53,6 +53,7 @@ import Utility.HumanTime import Utility.SimpleProtocol as Proto import Utility.ThreadScheduler+import Utility.SafeOutput  import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S@@ -321,7 +322,7 @@   where 	stdouthandler l =  		unless (quietMode oh) $-			putStrLn l+			putStrLn (safeOutput l)  {- To suppress progress output, while displaying other messages,  - filter out lines that contain \r (typically used to reset to the
Utility/Process.hs view
@@ -189,11 +189,13 @@ debugProcess :: CreateProcess -> ProcessHandle -> IO () debugProcess p h = do 	pid <- getPid h-	debug "Utility.Process" $ unwords+	debug "Utility.Process" $ unwords $ 		[ describePid pid 		, action ++ ":" 		, showCmd p-		]+		] ++ case cwd p of+			Nothing -> []+			Just c -> ["in", show c]   where 	action 		| piped (std_in p) && piped (std_out p) = "chat"
+ Utility/SafeOutput.hs view
@@ -0,0 +1,36 @@+{- Safe output to the terminal of possibly attacker-controlled strings,+ - avoiding displaying control characters.+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.SafeOutput (+	safeOutput,+	safeOutputChar,+) where++import Data.Char+import qualified Data.ByteString as S++class SafeOutputtable t where+	safeOutput :: t -> t++instance SafeOutputtable String where+	safeOutput = filter safeOutputChar++instance SafeOutputtable S.ByteString where+	safeOutput = S.filter (safeOutputChar . chr . fromIntegral)++safeOutputChar :: Char -> Bool+safeOutputChar c+	| not (isControl c) = True+	| c == '\n' = True+	| c == '\t' = True+	| c == '\DEL' = False+	| ord c > 31 = True+	| otherwise = False
+ Utility/Terminal.hs view
@@ -0,0 +1,45 @@+{- Determining if output is to a terminal.+ -+ - Copyright 2023 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-tabs #-}++module Utility.Terminal (+	IsTerminal(..),+	checkIsTerminal,+) where++import System.IO+#ifdef mingw32_HOST_OS+import System.Win32.MinTTY (isMinTTYHandle)+import System.Win32.File+import System.Win32.Types+import Graphics.Win32.Misc+import Control.Exception+#endif++newtype IsTerminal = IsTerminal Bool++checkIsTerminal :: Handle -> IO IsTerminal+checkIsTerminal h = do+#ifndef mingw32_HOST_OS+	b <- hIsTerminalDevice h+	return (IsTerminal b)+#else+	b <- hIsTerminalDevice h+	if b+		then return (IsTerminal b)+		else do+			h' <- getStdHandle sTD_OUTPUT_HANDLE+				`catch` \(_ :: IOError) ->+					return nullHANDLE+			if h' == nullHANDLE+				then return (IsTerminal False)+				else do+					b' <- isMinTTYHandle h'+					return (IsTerminal b)+#endif
Utility/WebApp.hs view
@@ -87,7 +87,7 @@ 	-- getAddrInfo didn't used to work on windows; current status 	-- unknown. 	when (isJust h) $-		error "getSocket with HostName not supported on this OS"+		giveup "getSocket with HostName not supported on this OS" 	let addr = tupleToHostAddress (127,0,0,1) 	sock <- socket AF_INET Stream defaultProtocol 	preparesocket sock@@ -99,7 +99,7 @@ 	case (partition (\a -> addrFamily a == AF_INET) addrs) of 		(v4addr:_, _) -> go v4addr 		(_, v6addr:_) -> go v6addr-		_ -> error "unable to bind to a local socket"+		_ -> giveup "unable to bind to a local socket"   where 	hostname = fromMaybe localhost h 	localhost = "localhost"@@ -108,7 +108,7 @@ 	 - unknown reason on OSX. -}  	go addr = go' 100 addr 	go' :: Int -> AddrInfo -> IO Socket-	go' 0 _ = error "unable to bind to local socket"+	go' 0 _ = giveup "unable to bind to local socket" 	go' n addr = do 		r <- tryIO $ bracketOnError (open addr) close (useaddr addr) 		either (const $ go' (pred n) addr) return r@@ -129,9 +129,9 @@ webAppSessionBackend _ = do 	g <- newGenIO :: IO SystemRandom 	case genBytes 96 g of-		Left e -> error $ "failed to generate random key: " ++ show e+		Left e -> giveup $ "failed to generate random key: " ++ show e 		Right (s, _) -> case CS.initKey s of-			Left e -> error $ "failed to initialize key: " ++ show e+			Left e -> giveup $ "failed to initialize key: " ++ show e 			Right key -> use key   where 	timeout = 120 * 60 -- 120 minutes
doc/git-annex-add.mdwn view
@@ -15,18 +15,20 @@ Files that are already checked into git and are unmodified, or that git has been configured to ignore will be silently skipped. -If annex.largefiles is configured, and does not match a file, -`git annex add` will behave the same as `git add` and add the-non-large file directly to the git repository, instead of to the annex.-(By default dotfiles are assumed to not be large, and are added directly-to git, but annex.dotfiles can be configured to annex those too.)-See the git-annex manpage for documentation of these and other-configuration settings.+If annex.largefiles is configured (in git config, gitattributes, or+git-annex config), and does not match a file, `git annex add` will behave+the same as `git add` and add the non-large file directly to the git+repository, instead of to the annex. (By default dotfiles are assumed to+not be large, and are added directly to git, but annex.dotfiles can be+configured to annex those too.) See the git-annex manpage for documentation+of these and other configuration settings. -Large files are added to the annex in locked form, which prevents further-modification of their content unless unlocked by [[git-annex-unlock]](1).-(This is not the case however when a repository is in a filesystem not-supporting symlinks.)+By default, large files are added to the annex in locked form, which+prevents further modification of their content until+unlocked by [[git-annex-unlock]](1). (This is not the case however+when a repository is in a filesystem not supporting symlinks.)+The annex.addunlocked git config (and git-annex config) can be used to+change this behavior.  This command can also be used to add symbolic links, both symlinks to annexed content, and other symlinks.@@ -93,7 +95,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * `--batch`
doc/git-annex-addunused.mdwn view
@@ -15,7 +15,17 @@  # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* The [[git-annex-common-options]](1) can also be used.  # SEE ALSO
doc/git-annex-addurl.mdwn view
@@ -10,7 +10,7 @@  Downloads each url to its own file, which is added to the annex. -When `youtube-dl` is installed, it can be used to check for a video+When `yt-dlp` is installed, it can be used to check for a video embedded in  a web page at the url, and that is added to the annex instead. (However, this is disabled by default as it can be a security risk.  See the documentation of annex.security.allowed-ip-addresses@@ -45,13 +45,13 @@    * `--raw` -  Prevent special handling of urls by youtube-dl, bittorrent, and other+  Prevent special handling of urls by yt-dlp, bittorrent, and other   special remotes. This will for example, make addurl   download the .torrent file and not the contents it points to.  * `--no-raw` -  Require content pointed to by the url to be downloaded using youtube-dl+  Require content pointed to by the url to be downloaded using yt-dlp   or a special remote, rather than the raw content of the url. if that   cannot be done, the add will fail. @@ -70,7 +70,7 @@    other modifications.     git-annex will still check the filename for safety, and if the filename-   has a security problem such as path traversal or an escape sequence,+   has a security problem such as path traversal or a control character,    it will refuse to add it.  * `--pathdepth=N`@@ -134,7 +134,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * `--backend`
+ doc/git-annex-assist.mdwn view
@@ -0,0 +1,66 @@+# NAME++git-annex assist - add files and sync changes with remotes++# SYNOPSIS++git annex assist `[remote ...]`++# DESCRIPTION++This command assists you in checking files into the repository+and syncing with remotes. It's the simplest possible way to use git-annex+at the command line, since only this one command needs to be run on a+regular basis.++This command first adds any new files to the repository, and commits those+as well as any modified files. Then it does the equivilant of running+[[git-annex-pull](1) followed by [[git-annex-push]](1).++This command operates on all files in the whole working tree,+even when ran in a subdirectory. To limit it to operating on files in a+subdirectory, use the `--content-of` option.++To block some files from being added to the repository, use `.gitignore`+files.++By default, all files that are added are added to the annex, the same+as when you run `git annex add`. If you configure annex.largefiles,+files that it does not match will instead be added with `git add`.++# OPTIONS++* `--message=msg` `-m msg`++  Use this option to specify a commit message.++* `--content-of=path` `-C path`++  Only add, pull, and push files in the given path.++  This option can be repeated multiple times with different paths.++* Also all options supported by [[git-annex-pull]](1) and+  [[git-annex-push]](1) can be used.++* Also the [[git-annex-common-options]](1) can be used.++# SEE ALSO++[[git-annex]](1)++[[git-annex-add]](1)++[[git-annex-pull]](1)++[[git-annex-push]](1)++[[git-annex-sync]](1)++[[git-annex-assistant]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex-assistant.mdwn view
@@ -1,6 +1,6 @@ # NAME -git-annex assistant - automatically sync changes+git-annex assistant - daemon to add files and automatically sync changes  # SYNOPSIS @@ -9,8 +9,18 @@ # DESCRIPTION  Watches for changes to files in the current directory and its subdirectories,-and automatically syncs them to other remotes.+and automatically syncs them to other remotes. This includes adding new+files. New files published to remotes by others are also automatically+downloaded. +By default, all new files in the directory will be added to the repository.+(Including dotfiles.) To block some files from being added, use+`.gitignore` files.+  +By default, all files that are added are added to the annex, the same+as when you run `git annex add`. If you configure annex.largefiles,+files that it does not match will instead be added with `git add`.+ # OPTIONS  * `--autostart`@@ -47,6 +57,8 @@ [[git-annex]](1)  [[git-annex-watch]](1)++[[git-annex-assist]](1)  [[git-annex-schedule]](1)
doc/git-annex-config.mdwn view
@@ -10,6 +10,8 @@  git annex config --unset name +git annex config --show-origin name+ # DESCRIPTION  Set or get configuration settings stored in the git-annex branch.@@ -29,13 +31,66 @@  # SUPPORTED SETTINGS +* `annex.numcopies`++  Tells git-annex how many copies it should preserve of files, over all+  repositories. The default is 1.++  When git-annex is asked to drop a file, it first verifies that the+  number of copies can be satisfied among all the other+  repositories that have a copy of the file.+  +  In unusual situations, involving special remotes that do not support+  locking, and concurrent drops of the same content from multiple+  repositories, git-annex may violate the numcopies setting. It still+  guarantees at least 1 copy is preserved. This can be configured by+  setting annex.mincopies.++  This is the same setting that the [[git-annex-numcopies]](1) command+  configures. It can be overridden on a per-file basis+  by the annex.numcopies setting in `.gitattributes` files.++* `annex.mincopies`++  Tells git-annex how many copies it is required to preserve of files, +  over all repositories. The default is 1.++  This supplements the annex.numcopies setting. +  In unusual situations, involving special remotes that do not support+  locking, and concurrent drops of the same content from multiple+  repositories, git-annex may violate the numcopies setting.+  In these unusual situations, git-annex ensures that the number of copies+  never goes below mincopies.+  +  It is a good idea to not only rely on only setting mincopies. Set+  numcopies as well, to a larger number, and keep mincopies at the+  bare minimum you're comfortable with. Setting mincopies to a large+  number, rather than setting numcopies will in some cases prevent+  droping content in entirely safe situations.++  This is the same setting that the [[git-annex-mincopies]](1) command+  configures. It can be overridden on a per-file basis+  by the annex.mincopies setting in `.gitattributes` files.+ * `annex.largefiles`    Used to configure which files are large enough to be added to the annex.   It is an expression that matches the large files, eg   "`include=*.mp3 or largerthan(500kb)`".   See [[git-annex-matching-expression]](1) for details on the syntax.+  +  This configures the behavior of both git-annex and git when adding+  files to the repository. By default, `git-annex add` adds all files+  to the annex (except dotfiles), and `git add` adds files to git+  (unless they were added to the annex previously).+  When annex.largefiles is configured, both+  `git annex add` and `git add` will add matching large files to the+  annex, and the other files to git. +  Other git-annex commands also honor annex.largefiles, including+  `git annex import`, `git annex addurl`, `git annex importfeed`,+  `git-annex assist`, and the `git-annex assistant`.+   This sets a default, which can be overridden by annex.largefiles   attributes in `.gitattributes` files, or by `git config`. @@ -64,8 +119,9 @@  * `annex.autocommit` -  Set to false to prevent the `git-annex assistant` and `git-annex sync`-  from automatically committing changes to files in the repository.+  Set to false to prevent the `git-annex assistant`, `git-annex assist`+  and `git-annex sync` from automatically committing changes to files+  in the repository.       This sets a default, which can be overridden by annex.autocommit   in `git config`.@@ -74,23 +130,27 @@    Set to false to prevent merge conflicts in the checked out branch   being automatically resolved by the `git-annex assitant`,-  `git-annex sync`, `git-annex merge`, and the `git-annex post-receive`-  hook.+  `git-annex sync`, `git-annex pull`, ``git-annex merge`, +  and the `git-annex post-receive` hook.       This sets a default, which can be overridden by annex.resolvemerge   in `git config`.  * `annex.synccontent` -  Set to true to make git-annex sync default to syncing annexed content.+  Set to true to make `git-annex sync` default to transferring+  annexed content.   +  Set to false to prevent `git-annex pull` and `git-annex` push from+  transferring annexed content.+     This sets a default, which can be overridden by annex.synccontent   in `git config`.  * `annex.synconlyannex` -  Set to true to make git-annex sync default to only sync the git-annex-  branch and annexed content.+  Set to true to make `git-annex sync`, `git-annex pull` and `git-annex+  push` default to only operate on the git-annex branch and annexed content.      This sets a default, which can be overridden by annex.synconlyannex   in `git config`.@@ -125,6 +185,24 @@ * `--unset`    Unset a value.++* `--show-origin name`++  Explain where the value is configured, whether in the git-annex branch,+  or in a `git config` file, or `.gitattributes` file. When a value is+  configured in multiple places, displays the place and the value that+  will be used.++  Note that the parameter can be the name of one of the settings listed+  above, but also any other configuration setting supported by git-annex.+  For example, "annex.backend" cannot be set in the git-annex branch, but+  it can be set in `.gitattributes` or `git config` and this option can+  explain which setting will be used for it.++* `--for-file file`++  Can be used in combination with `--show-origin` to specify what+  filename to check for in `.gitattributes`.  * Also the [[git-annex-common-options]](1) can be used.
+ doc/git-annex-configremote.mdwn view
@@ -0,0 +1,41 @@+# NAME++git-annex configremote - changes special remote configuration++# SYNOPSIS++git annex configemote `name|uuid|desc [param=value ...]`++# DESCRIPTION++Changes the configuration of a special remote that was set up earlier+by `git-annex initremote`. The special remote does not need to be enabled+for use in the current repository, and this command will not enable it.++This command can currently only be used to change the value of the+`autoenable` parameter, eg "autoenable=false".++To change other parameters, use `git-annex enableremote`++# OPTIONS++Most options are not prefixed by a dash, and set parameters of the remote,+as shown above. ++Also, the [[git-annex-common-options]](1) can be used.++# SEE ALSO++[[git-annex]](1)++[[git-annex-initremote]](1)++[[git-annex-configremote]](1)++[[git-annex-renameremote]](1)++# AUTHOR++Joey Hess <id@joeyh.name>++Warning: Automatically converted into a man page by mdwn2man. Edit with care.
doc/git-annex-copy.mdwn view
@@ -125,7 +125,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-dead.mdwn view
@@ -4,7 +4,7 @@  # SYNOPSIS -git annex dead `[repository ...] [--key somekey]`+git annex dead `[repository ...] [--key somekey ...]`  # DESCRIPTION @@ -27,6 +27,16 @@ * `--key=somekey`    Use to specify a key that is dead.++* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-describe.mdwn view
@@ -20,7 +20,17 @@  # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-drop.mdwn view
@@ -131,7 +131,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-dropkey.mdwn view
@@ -32,7 +32,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-dropunused.mdwn view
@@ -28,6 +28,16 @@   the last repository that is storing their content. Data loss can   result from using this option. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO@@ -35,6 +45,10 @@ [[git-annex]](1)  [[git-annex-unused]](1)++[[git-annex-drop]](1)++[[git-annex-copy]](1)  # AUTHOR
doc/git-annex-enableremote.mdwn view
@@ -59,16 +59,27 @@  # OPTIONS -Most options are not prefixed by a dash, and set parameters of the remote,-as shown above. +* `--json` -Also, the [[git-annex-common-options]](1) can be used.+  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* Also, the [[git-annex-common-options]](1) can be used.+ # SEE ALSO  [[git-annex]](1)  [[git-annex-initremote]](1)++[[git-annex-configremote]](1)++[[git-annex-renameremote]](1)  # AUTHOR
doc/git-annex-examinekey.mdwn view
@@ -20,7 +20,8 @@   The value is a format string, in which '${var}' is expanded to the   value of a variable. To right-justify a variable with whitespace,   use '${var;width}' ; to left-justify a variable, use '${var;-width}';-  to escape unusual characters in a variable, use '${escaped_var}'+  to escape unusual characters (including control characters)+  in a variable, use '${escaped_var}'    To generate a path from the top of the repository to the git-annex   object for a key, use ${objectpath}. To generate the value of a@@ -32,6 +33,9 @@   provided to examinekey).    Also, '\\n' is a newline, '\\000' is a NULL, etc.+  +  The default output format is the same as `--format='${escapedkey}\\n'`+  except when outputting to a terminal, control characters will be escaped.  * `--json` @@ -41,7 +45,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * `--migrate-to-backend=backend`
doc/git-annex-expire.mdwn view
@@ -48,6 +48,16 @@   The first version of git-annex that recorded fsck activity was   5.20150405. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-export.mdwn view
@@ -52,15 +52,13 @@ not supported. See individual special remotes' documentation for details of how to enable such versioning. -The `git annex sync --content` command (and the git-annex assistant)-can also be used to export a branch to a special remote, -updating the special remote whenever the branch is changed.-To do this, you need to configure "remote.<name>.annex-tracking-branch"-to tell it what branch to track.-For example:+Commands like `git-annex push` can also be used to export a branch to a+special remote, updating the special remote whenever the branch is changed.+To do this, you need to configure "remote.<name>.annex-tracking-branch" to+tell it what branch to track. For example:  	git config remote.myremote.annex-tracking-branch master-	git annex sync --content+	git annex push myremote  You can combine using `git annex export` to send changes to a special  remote with `git annex import` to fetch changes from a special remote.@@ -89,7 +87,7 @@ * `--fast`    This sets up an export of a tree, but avoids any expensive file uploads to-  the remote. You can later run `git annex sync --content` to upload+  the remote. You can later run `git annex push` to upload   the files to the export.  * `--jobs=N` `-JN`@@ -111,7 +109,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used. @@ -162,7 +160,7 @@  [[git-annex-import]](1) -[[git-annex-sync]](1)+[[git-annex-push]](1)  [[git-annex-preferred-content]](1)
doc/git-annex-find.mdwn view
@@ -41,7 +41,8 @@   The value is a format string, in which '${var}' is expanded to the   value of a variable. To right-justify a variable with whitespace,   use '${var;width}' ; to left-justify a variable, use '${var;-width}';-  to escape unusual characters in a variable, use '${escaped_var}'+  to escape unusual characters (including control characters)+  in a variable, use '${escaped_var}'    These variables are available for use in formats: file, key, backend,   bytesize, humansize, keyname, hashdirlower, hashdirmixed, mtime (for@@ -49,7 +50,8 @@    Also, '\\n' is a newline, '\\000' is a NULL, etc. -  The default output format is the same as `--format='${file}\\n'`+  The default output format is the same as `--format='${file}\\n'`,+  except when outputting to a terminal, control characters will be escaped.  * `--json` @@ -61,7 +63,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * `--batch`
doc/git-annex-findkeys.mdwn view
@@ -36,7 +36,8 @@   The value is a format string, in which '${var}' is expanded to the   value of a variable. To right-justify a variable with whitespace,   use '${var;width}' ; to left-justify a variable, use '${var;-width}';-  to escape unusual characters in a variable, use '${escaped_var}'+  to escape unusual characters (including control characters)+  in a variable, use '${escaped_var}'    These variables are available for use in formats: key, backend,   bytesize, humansize, keyname, hashdirlower, hashdirmixed, mtime (for@@ -44,7 +45,8 @@    Also, '\\n' is a newline, '\\000' is a NULL, etc. -  The default output format is the same as `--format='${key}\\n'`+  The default output format is the same as `--format='${escapedkey}\\n'`+  except when outputting to a terminal, control characters will be escaped.  * `--json` @@ -56,7 +58,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-fix.mdwn view
@@ -24,6 +24,16 @@   The [[git-annex-matching-options]](1)   can be used to specify files to fix. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-fsck.mdwn view
@@ -108,7 +108,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * `--quiet`
doc/git-annex-get.mdwn view
@@ -135,7 +135,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-import.mdwn view
@@ -182,7 +182,7 @@  		git annex import /dir --include='*.png' -## COMMON OPTIONS+# COMMON OPTIONS  * `--jobs=N` `-JN` @@ -211,7 +211,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-importfeed.mdwn view
@@ -13,7 +13,7 @@ delete, rename, etc the resulting files and repeated runs won't duplicate them. -When `youtube-dl` is installed, it can be used to download links in the feed.+When `yt-dlp` is installed, it can be used to download links in the feed. This allows importing e.g., YouTube playlists. (However, this is disabled by default as it can be a security risk.  See the documentation of annex.security.allowed-ip-addresses@@ -54,13 +54,13 @@  * `--raw` -  Prevent special handling of urls by youtube-dl, bittorrent, and other+  Prevent special handling of urls by yt-dlp, bittorrent, and other   special remotes. This will for example, make importfeed   download a .torrent file and not the contents it points to.  * `--no-raw` -  Require content pointed to by the url to be downloaded using youtube-dl+  Require content pointed to by the url to be downloaded using yt-dlp   or a special remote, rather than the raw content of the url. if that   cannot be done, the import will fail, and the next import of the feed   will retry.@@ -102,9 +102,29 @@   url to a file that would be ignored. This makes such files be added   despite any ignores. +* `--jobs=N` `-JN`++  Runs multiple downloads parallel. For example: `-J4`  ++  Setting this to "cpus" will run one job per CPU core.+ * `--backend`    Specifies which key-value backend to use.++* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-progress`++  Include progress objects in JSON output.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-info.mdwn view
@@ -29,7 +29,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * `--bytes`
doc/git-annex-init.mdwn view
@@ -57,6 +57,16 @@    Do not enable special remotes that were configured with autoenable=true. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-initremote.mdwn view
@@ -47,6 +47,8 @@  	git annex initremote mys3 type=S3 --whatelse +  For a machine-readable list of the parameters, use this with --json.+ * `--fast`    When initializing a remote that uses encryption, a cryptographic key is@@ -80,6 +82,16 @@   branch. The special remote will only be usable from the repository where   it was created. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # COMMON CONFIGURATION PARAMETERS@@ -124,6 +136,8 @@ [[git-annex]](1)  [[git-annex-enableremote]](1)++[[git-annex-configremote]](1)  [[git-annex-renameremote]](1)
doc/git-annex-lock.mdwn view
@@ -31,7 +31,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-log.mdwn view
@@ -39,6 +39,16 @@    Generates output suitable for the `gource` visualization program. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * matching options      The [[git-annex-matching-options]](1)
doc/git-annex-merge.mdwn view
@@ -9,11 +9,11 @@ # DESCRIPTION  When run without any parameters, this performs the same merging (and merge-conflict resolution) that is done by the sync command, but without pushing-or pulling any data.+conflict resolution) that is done by the `git-annex pull` and `git-annex sync`+commands, but without uploading or downloading any data.  When a branch to merge is specified, this merges it, using the same merge-conflict resolution as the sync command. This is especially useful on+conflict resolution as the `git-annex pull` command. This is especially useful on an adjusted branch, because it applies the same adjustment to the branch before merging it. @@ -27,11 +27,23 @@   Passed on to `git merge`, to control whether or not to merge   histories that do not share a common ancestor. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also, the [[git-annex-common-options]](1) can be used.  # SEE ALSO  [[git-annex]](1)++[[git-annex-pull]](1)  [[git-annex-sync]](1)
doc/git-annex-metadata.mdwn view
@@ -122,7 +122,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * `--batch`
doc/git-annex-migrate.mdwn view
@@ -51,6 +51,16 @@    	git-annex migrate --remove-size --backend=URL somefile +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ # SEE ALSO  [[git-annex]](1)
doc/git-annex-mirror.mdwn view
@@ -80,7 +80,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-move.mdwn view
@@ -120,7 +120,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-numcopies.mdwn view
@@ -36,6 +36,7 @@  [[git-annex]](1) [[git-annex-mincopies]](1)+[[git-annex-config]](1)  # AUTHOR
doc/git-annex-preferred-content.mdwn view
@@ -40,6 +40,13 @@   files relative to the current directory, preferred content expressions   match files relative to the top of the git repository. +  A glob is something like `foo.*` or `b?r`. +  Globs can also contain character classes, +  like `foo[Bb]ar`, as well as additional POSIX character classes like+  `[[:space:]]`. Which is useful, since a glob in a preferred content+  expression cannot contain spaces. See the `glob(7)` man page for more+  about globs.+   For example, suppose you put files into `archive` directories   when you're done with them. Then you could configure your laptop to prefer   to not retain those files, like this: `exclude=*/archive/*`@@ -129,6 +136,13 @@   Matches only files that have a metadata field attached with a value that   matches the glob. The values of metadata fields are matched case   insensitively.++  A glob is something like `foo.*` or `b?r`. +  Globs can also contain character classes, +  like `foo[Bb]ar`, as well as additional POSIX character classes like+  `[[:space:]]`. Which is useful, since a glob in a preferred content+  expression cannot contain spaces. See the `glob(7)` man page for more+  about globs.    To match a tag "done", use `metadata=tag=done`
+ doc/git-annex-pull.mdwn view
@@ -0,0 +1,143 @@+# NAME++git-annex pull - pull content from remotes++# SYNOPSIS++git annex pull `[remote ...]`++# DESCRIPTION++This command pulls content from remotes. It downloads+both git repository content, and the content of annexed files.+Like `git pull`, it merges changes into the current branch.++You can use `git pull` and `git-annex get` by hand to do the same thing as+this command, but this command handles several details, including making+sure that the git-annex branch is fetched from the remote.++Some special remotes contain a tree of files that can be imported,+and this command can be used to pull from those remotes as+well as regular git remotes. See [[git-annex-import]](1) for details+about how those special remotes work. In order for this command to import+from a special remote, `remote.<name>.annex-tracking-branch` also must+be configured, and have the same value as the currently checked out branch.++When [[git-annex-adjust]](1) has been used to check out an adjusted branch,+this command will also pull changes from the parent branch.++When [[git-annex-view]](1) has been used to check out a view branch,+this command will update the view branch to reflect any changes +to the parent branch or metadata.+  +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+remote that are not preferred content of the remote.+See [[git-annex-preferred-content]](1).++# OPTIONS++* `[remote]`++  By default this command pulls from all remotes, except for remotes+  that have `remote.<name>.annex-pull` (or `remote.<name>.annex-sync`) +  set to false. ++  By specifying the names of remotes (or remote groups), you can control+  which ones to pull from.++* `--fast`++  Only pull with the remotes with the lowest annex-cost value configured.++  When a list of remotes (or remote groups) is provided, it picks from+  amoung those, otherwise it picks from amoung all remotes.++* `--only-annex` `-a`, `--not-only-annex`++  Only pull the git-annex branch and annexed content from remotes,+  not other git branches.++  The `annex.synconlyannex` configuration can be set to true to make+  this be the default behavior. To override such a setting, use+  `--not-only-annex`.++  When this is combined with --no-content, only the git-annex branch+  will be pulled.++* `--no-content, `-g`, `--content`++  Use `--no-content` or `-g` to avoid downloading (and dropping)+  the content of annexed files.++  If you often use `--no-content`, you can set the `annex.synccontent`+  configuration to false to prevent downloading content by default.+  The `--content` option overrides that configuration.++* `--content-of=path` `-C path`++  Only download (and drop) annexed files in the given path.++  This option can be repeated multiple times with different paths.++* `--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.++* `--jobs=N` `-JN`++  Enables parallel pulling 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.++  (Note that git pulls are not done in parallel because that tends to be+  less efficient.)++* `--allow-unrelated-histories`, `--no-allow-unrelated-histories`++  Passed on to `git merge`, to control whether or not to merge+  histories that do not share a common ancestor.++* `--resolvemerge`, `--no-resolvemerge`++  By default, merge conflicts are automatically handled by this command. +  When two conflicting versions of a file have been committed, both will+  be added  to the tree, under different filenames. For example, file "foo"+  would be replaced with "foo.variant-A" and "foo.variant-B". (See+  [[git-annex-resolvemerge]](1) for details.)++  Use `--no-resolvemerge` to disable this automatic merge conflict+  resolution. It can also be disabled by setting `annex.resolvemerge`+  to false.++* `--backend`++  Specifies which key-value backend to use when importing from a+  special remote. ++* Also the [[git-annex-common-options]](1) can be used.+  +# SEE ALSO++[[git-annex]](1)++[[git-annex-push]](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.
+ doc/git-annex-push.mdwn view
@@ -0,0 +1,141 @@+# NAME++git-annex push - push content to remotes++# SYNOPSIS++git annex push `[remote ...]`++# DESCRIPTION++This command pushes content to remotes. It uploads +both git repository content, and the content of annexed files.++You can use `git push` and `git-annex copy` by hand to do the same thing as+this command, but this command handles several details, including making+sure that the git-annex branch is pushed to the remote.++When using git-annex, often remotes are not bare repositories, because+it's helpful to add remotes for nearby machines that you want+to access the same annexed content. Pushing to a non-bare remote will+not normally update the remote's current branch with changes from the local+repository. (Unless the remote is configured with+receive.denyCurrentBranch=updateInstead.)++To make working with such non-bare remotes easier, this command pushes not+only local `master` to remote `master`, but also to remote `synced/master`+(and similar with other branches). When `git-annex pull` (or `git-annex+sync`) is later run on the remote, it will merge the `synced/` branches+that were pushed to it.++Some special remotes allow exporting a tree of files to them,+and this command can be used to push to those remotes as well+as regular git remotes. See [[git-annex-export]](1) for details+about how those special remotes work. In order for this command to export+to a special remote, `remote.<name>.annex-tracking-branch` also must+be configured, and have the same value as the currently checked out branch.++When [[git-annex-adjust]](1) has been used to check out an adjusted branch,+this command will propagate changes that have been made back to the +parent branch, without propagating the adjustments. ++Normally this tries to upload the content of each annexed file that is+in the working tree, to any remote that it's pushing to that does not have+a copy. To control which files are uploaded to a remote, configure the preferred+content of the remote. When a file is not the preferred content of a remote,+or of the local repository, this command will try to drop the file's content.+See [[git-annex-preferred-content]](1).++# OPTIONS++* `[remote]`++  By default, this command pushes to all remotes, except for remotes +  that have `remote.<name>.annex-push` (or `remote.<name>.annex-sync`) +  set to false or `remote.<name>.annex-readonly` set to true.++  By specifying the names of remotes (or remote groups), you can control which+  ones to push to.++* `--fast`++  Only push to the remotes with the lowest annex-cost value configured.++  When a list of remotes (or remote groups) is provided, it picks from+  amoung those, otherwise it picks from amoung all remotes.++* `--only-annex` `-a`, `--not-only-annex`++  Only pull the git-annex branch and annexed content from remotes,+  not other git branches.++  The `annex.synconlyannex` configuration can be set to true to make+  this be the default behavior. To override such a setting, use+  `--not-only-annex`.++  When this is combined with --no-content, only the git-annex branch+  will be pulled.++* `--no-content`, `-g`, `--content`++  Use `--no-content` or `-g` to avoid uploading (and dropping) the content+  of annexed files.++  If you often use `--no-content`, you can set the `annex.synccontent`+  configuration to false to prevent uploading content by default.+  The `--content` option overrides that configuration.++* `--content-of=path` `-C path`++  Only upload (or drop) annexed files in the given path.++  This option can be repeated multiple times with different paths.++* `--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.++* `--jobs=N` `-JN`++  Enables parallel pushing 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.++* `--cleanup`++  Removes the local and remote `synced/` branches, which were created+  and pushed by `git-annex push` or `git-annex sync`. This option+  prevents all other activities.++  This can come in handy when you've pushed a change to remotes and now+  want to reset your master branch back before that change. So you+  run `git reset` and force-push the master branch to remotes, only+  to find that the next `git annex merge` or `git annex pull` brings the+  changes back. Why? Because the `synced/master` branch is hanging+  around and still has the change in it. Cleaning up the `synced/` branches+  prevents that problem.++* Also the [[git-annex-common-options]](1) can be used.++# SEE ALSO++[[git-annex]](1)++[[git-annex-pull]](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.
doc/git-annex-registerurl.mdwn view
@@ -56,7 +56,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-reinit.mdwn view
@@ -25,7 +25,17 @@  # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-reinject.mdwn view
@@ -54,6 +54,16 @@   Specify the key-value backend to use when checking if a file is known   with the `--known` option. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-rekey.mdwn view
@@ -34,6 +34,16 @@   Makes the `--batch` input be delimited by nulls instead of the usual   newlines. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-renameremote.mdwn view
@@ -38,6 +38,8 @@  [[git-annex-enableremote]](1) +[[git-annex-configremote]](1)+ # AUTHOR  Joey Hess <id@joeyh.name>
doc/git-annex-rmurl.mdwn view
@@ -28,6 +28,16 @@   Makes the `--batch` input be delimited by nulls instead of the usual   newlines. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-semitrust.mdwn view
@@ -15,7 +15,17 @@  # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-setpresentkey.mdwn view
@@ -21,6 +21,16 @@   Enables batch mode, in which lines are read from stdin.   The line format is "key uuid [1|0]" +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-status.mdwn view
@@ -29,7 +29,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-sync.mdwn view
@@ -10,77 +10,32 @@  This command synchronizes the local repository with its remotes. -The sync process involves first committing any local changes to files-that have previously been added to the repository,-then fetching and merging the current branch and the `git-annex` branch-from the remote repositories, and finally pushing the changes back to-those branches on the remote repositories. You can use standard git-commands to do each of those steps by hand, or if you don't want to-worry about the details, you can use sync.--The content of annexed objects is not synced by default, but the --content-option (see below) can make that also be synchronized.--When using git-annex, often remotes are not bare repositories, because-it's helpful to add remotes for nearby machines that you want-to access the same annexed content. Syncing with a non-bare remote will-not normally update the remote's current branch with changes from the local-repository. (Unless the remote is configured with-receive.denyCurrentBranch=updateInstead.)--To make working with such non-bare remotes easier, sync pushes not only-local `master` to remote `master`, but also to remote `synced/master` (and-similar with other branches). When `git-annex sync` is later run on the-remote, it will merge the `synced/` branches that the repository has-received.--Some special remotes contain a tree of files that can be imported-and/or exported, and syncing with these remotes behaves differently.-See  [[git-annex-import]](1) and [[git-annex-export]](1) for details-about how importing and exporting work; syncing with such a remote -is essentially an import followed by an export. In many cases,-importing needs to download content from the remote, and so sync will-only import when the --content option is used. (And exporting only-ever happens when --content is used.) The remote's -`remote.<name>.annex-tracking-branch` also must be configured, and-have the same value as the currently checked out branch.+This command first commits any local changes to files that have+previously been added to the repository. Then it does the equivilant of+[[git-annex-pull]](1) followed by [[git-annex-push]](1). -When [[git-annex-adjust]](1) has been used to check out an adjusted branch,-running sync will propagate changes that have been made back to the -parent branch, without propagating the adjustments. When-[[git-annex-view]](1) has been used to check out a view branch,-running sync will update the view branch to reflect any changes -to the parent branch or metadata.+However, unlike those commands, this command does not transfer annexed+content by default. That will change in a future version of git-annex,  # OPTIONS -* `[remote]`--  By default, all remotes are synced, 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 sync with.--* `--fast`--  Only sync with the remotes with the lowest annex-cost value configured.+* `--content`, `--no-content`, `-g` -  When a list of remotes (or remote groups) is provided, it picks from-  amoung those, otherwise it picks from amoung all remotes.+  The --content option causes the content of annexed files+  to also be pulled and pushed. -* `--only-annex` `-a`, `--not-only-annex`+  The --no-content and -g options cause the content of annexed files to+  not be pulled and pushed. -  Only sync the git-annex branch and annexed content with remotes,-  not other git branches.+  The `annex.synccontent` configuration can be set to true to make+  `--content` be enabled by default. -  This avoids pulling and pushing other branches, and it avoids committing-  any local changes. It's up to you to use regular git commands to do that.+* `--content-of=path` `-C path` -  The `annex.synconlyannex` configuration can be set to true to make-  this be the default behavior of `git-annex sync`. To override such-  a setting, use `--not-only-annex`.+  This option causes the content of annexed files in the given+  path to also be pulled and pushed. -  When this is combined with --no-content, only the git-annex branch-  will be synced.+  This option can be repeated multiple times with different paths.  * `--commit`, `--no-commit` @@ -88,110 +43,26 @@      Use --no-commit to avoid committing local changes. -* `--message=msg`+* `--message=msg` `-m msg`    Use this option to specify a commit message.  * `--pull`, `--no-pull` -  By default, syncing pulls from remotes and imports from some special-  remotes. Use --no-pull to disable all pulling.+  Use this option to disable pulling. -  When `remote.<name>.annex-pull` or `remote.<name>.annex-sync`-  are set to false, pulling is disabled for those remotes, and using-  `--pull` will not enable it.+  When `remote.<name>.annex-sync` is set to false, pulling is disabled+  for that remote, and using `--pull` will not enable it.  * `--push`, `--no-push`  -  By default, syncing pushes changes to remotes and exports to some -  special remotes. Use --no-push to disable all pushing.+  Use this option to disable pushing.   -  When `remote.<name>.annex-push` or `remote.<name>.annex-sync` are-  set to false, or `remote.<name>.annex-readonly` is set to true,-  pushing is disabled for those remotes, and using `--push` will not enable-  it.--* `--content`, `--no-content`--  Normally, syncing does not transfer the contents of annexed files.-  The --content option causes the content of annexed files-  to also be uploaded and downloaded as necessary, to sync the content-  between the repository and its remotes.--  The `annex.synccontent` configuration can be set to true to make content-  be synced by default.--  Normally this tries to get each annexed file that is in the working tree-  and whose content the local repository does not yet have, from any remote-  that it's syncing with that has a copy, and then copies each file to-  every remote that it is syncing with. This behavior can be overridden by-  configuring the preferred content of repositories. See-  [[git-annex-preferred-content]](1).--* `--content-of=path` `-C path`--  While --content operates on all annexed files,-  --content-of allows limiting the transferred files to ones in a given-  location.--  This option can be repeated multiple times with different paths.--* `--all` `-A`--  This option, when combined with `--content`, makes all available versions-  of all files be synced, 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.--* `--jobs=N` `-JN`--  Enables parallel syncing 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.--  When there are multiple git remotes, pushes will be made to them in-  parallel. Pulls are not done in parallel because that tends to be-  less efficient. When --content is synced, the files are processed-  in parallel as well.--* `--allow-unrelated-histories`, `--no-allow-unrelated-histories`--  Passed on to `git merge`, to control whether or not to merge-  histories that do not share a common ancestor.--* `--resolvemerge`, `--no-resolvemerge`--  By default, merge conflicts are automatically handled by sync. When two-  conflicting versions of a file have been committed, both will be added -  to the tree, under different filenames. For example, file "foo" -  would be replaced with "foo.variant-A" and "foo.variant-B". (See-  [[git-annex-resolvemerge]](1) for details.)--  Use `--no-resolvemerge` to disable this automatic merge conflict-  resolution. It can also be disabled by setting `annex.resolvemerge`-  to false.--* `--backend`--  Specifies which key-value backend to use when adding files, -  or when importing from a special remote. --* `--cleanup`--  Removes the local and remote `synced/` branches, which were created-  and pushed by `git-annex sync`. This option prevents all other syncing-  activities.+  When `remote.<name>.annex-sync` is set to false, pushing is disabled for+  that remote, and using `--push` will not enable it. -  This can come in handy when you've synced a change to remotes and now-  want to reset your master branch back before that change. So you-  run `git reset` and force-push the master branch to remotes, only-  to find that the next `git annex merge` or `git annex sync` brings the-  changes back. Why? Because the `synced/master` branch is hanging-  around and still has the change in it. Cleaning up the `synced/` branches-  prevents that problem.+* Also all options supported by [[git-annex-pull]](1) and+  [[git-annex-push]](1) can be used.  * Also the [[git-annex-common-options]](1) can be used. @@ -199,7 +70,11 @@  [[git-annex]](1) -[[git-annex-preferred-content]](1)+[[git-annex-pull]](1)++[[git-annex-push]](1)++[[git-annex-assist]](1)  # AUTHOR
doc/git-annex-trust.mdwn view
@@ -23,7 +23,17 @@  # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-unannex.mdwn view
@@ -28,6 +28,16 @@   But use --fast mode with caution, because editing the file will   change the content in the annex. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * file matching options    The [[git-annex-matching-options]](1)
doc/git-annex-undo.mdwn view
@@ -24,7 +24,17 @@  # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* The [[git-annex-common-options]](1) can also be used.  # SEE ALSO
doc/git-annex-uninit.mdwn view
@@ -14,7 +14,17 @@  # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-unlock.mdwn view
@@ -58,7 +58,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-unregisterurl.mdwn view
@@ -47,7 +47,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * Also the [[git-annex-common-options]](1) can be used.
doc/git-annex-untrust.mdwn view
@@ -16,7 +16,17 @@  # OPTIONS -* The [[git-annex-common-options]](1) can be used.+* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.++* Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-unused.mdwn view
@@ -45,6 +45,16 @@   The git configuration annex.used-refspec can be used to configure   this in a more permanent fashion. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # REFSPEC FORMAT
doc/git-annex-upgrade.mdwn view
@@ -31,6 +31,16 @@   Only do whatever automatic upgrade can be done, don't necessarily   upgrade to the latest version. This is used internally by git-annex. +* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the JSON instead.+ * Also the [[git-annex-common-options]](1) can be used.  # SEE ALSO
doc/git-annex-watch.mdwn view
@@ -1,6 +1,6 @@ # NAME -git-annex watch - watch for changes+git-annex watch - daemon to watch for changes  # SYNOPSIS @@ -14,7 +14,7 @@ background, you no longer need to manually run git commands when manipulating your files.   -By default, all files in the directory will be added to the repository.+By default, all new files in the directory will be added to the repository. (Including dotfiles.) To block some files from being added, use `.gitignore` files.
doc/git-annex-whereis.mdwn view
@@ -76,7 +76,7 @@ * `--json-error-messages`    Messages that would normally be output to standard error are included in-  the json instead.+  the JSON instead.  * `--format=value` @@ -85,7 +85,8 @@   The value is a format string, in which '${var}' is expanded to the   value of a variable. To right-justify a variable with whitespace,   use '${var;width}' ; to left-justify a variable, use '${var;-width}';-  to escape unusual characters in a variable, use '${escaped_var}'+  to escape unusual characters (including control characters)+  in a variable, use '${escaped_var}'    These variables are available for use in formats: file, key, uuid,   url, backend, bytesize, humansize, keyname, hashdirlower, hashdirmixed,
doc/git-annex.mdwn view
@@ -114,12 +114,30 @@      See [[git-annex-lock]](1) for details. +* `pull [remote ...]`++  Pull content from remotes.+  +  See [[git-annex-pull]](1) for details.++* `push [remote ...]`++  Push content to remotes.+  +  See [[git-annex-push]](1) for details.+ * `sync [remote ...]`    Synchronize local repository with remotes.      See [[git-annex-sync]](1) for details. +* `assist [remote ...]`++  Add files and sync changes with remotes.+  +  See [[git-annex-assist]](1) for details.+ * `mirror [path ...] [--to=remote|--from=remote]`    Mirror content of files to/from another repository.@@ -170,13 +188,13 @@  * `watch` -  Watch for changes and autocommit.+  Daemon to watch for changes and autocommit.      See [[git-annex-watch]](1) for details.  * `assistant` -  Automatically sync folders between devices.+  Daemon to automatically sync changes.    See [[git-annex-assistant]](1) for details. @@ -222,6 +240,13 @@      See [[git-annex-enableremote]](1) for details. +* `configremote name [param=value ...]`++  Changes configuration of an existing special remote.+  +  See [[git-annex-configremote]](1) for details.++ * `renameremote`    Renames a special remote.@@ -699,7 +724,8 @@    Resolves a conflicted merge, by adding both conflicting versions of the   file to the tree, using variants of their filename. This is done-  automatically when using `git annex sync` or `git annex merge`.+  automatically when using `git annex sync` or `git-annex pull`+  or `git annex merge`.    See [[git-annex-resolvemerge]](1) for details. @@ -884,8 +910,8 @@   annex, and the other files to git.    Other git-annex commands also honor annex.largefiles, including-  `git annex import`, `git annex addurl`, `git annex importfeed`-  and the assistant.+  `git annex import`, `git annex addurl`, `git annex importfeed`,+  `git-annex assist`, and the `git-annex assistant`.  * `annex.dotfiles` @@ -1130,7 +1156,10 @@   Set this to `true` to make unlocked files be a hard link to their content   in the annex, rather than a second copy. This can save considerable   disk space, but when a modification is made to a file, you will lose the-  local (and possibly only) copy of the old version. So, enable with care.+  local (and possibly only) copy of the old version. Any other, locked+  files in the repository that pointed to that content will get broken+  as well (`git-annex fsck` will detect and clean up after that). +  So, enable this with care.    After setting (or unsetting) this, you should run `git annex fix` to   fix up the annexed files in the work tree to be hard links (or copies).@@ -1156,8 +1185,8 @@ * `annex.resolvemerge`    Set to false to prevent merge conflicts in the checked out branch-  being automatically resolved by the git-annex assitant,-  git-annex sync, git-annex merge,+  being automatically resolved by the `git-annex assitant`,+  `git-annex assist`, `git-annex sync`, `git-annex pull`, `git-annex merge`,   and the git-annex post-receive hook.    To configure the behavior in all clones of the repository,@@ -1165,15 +1194,20 @@  * `annex.synccontent` -  Set to true to make git-annex sync default to syncing annexed content.+  Set to true to make `git-annex sync` default to transferring+  annexed content. +  Set to false to prevent `git-annex assist`, `git-annex pull` and+  `git-annex push` from transferring annexed content.+   To configure the behavior in all clones of the repository,   this can be set in [[git-annex-config]](1).  * `annex.synconlyannex` -  Set to true to make git-annex sync default to only sincing the git-annex-  branch and annexed content.+  Set to true to make `git-annex assist`, `git-annex sync`, +  `git-annex pull`, and `git-annex push` default to only operating+  on the git-annex branch and annexed content.    To configure the behavior in all clones of the repository,   this can be set in [[git-annex-config]](1).@@ -1345,7 +1379,7 @@ * `remote.<name>.annex-ignore`    If set to `true`, prevents git-annex-  from storing file contents on this remote by default.+  from storing annexed file contents on this remote by default.   (You can still request it be used by the `--from` and `--to` options.)    This is, for example, useful if the remote is located somewhere@@ -1353,8 +1387,9 @@   Or, it could be used if the network connection between two   repositories is too slow to be used normally. -  This does not prevent git-annex sync (or the git-annex assistant) from-  syncing the git repository to the remote.+  This does not prevent `git-annex sync`, `git-annex pull`, `git-annex push`,+  `git-annex assist` or the `git-annex assistant` from operating on the+  git repository.  * `remote.<name>.annex-ignore-command` @@ -1364,9 +1399,9 @@  * `remote.<name>.annex-sync` -  If set to `false`, prevents git-annex sync (and the git-annex assistant)-  from syncing with this remote by default. However, `git annex sync <name>`-  can still be used to sync with the remote.+  If set to `false`, prevents `git-annex sync` (and `git-annex pull`, +  `git-annex push`, `git-annex assist`, and the `git-annex assistant`)+  from operating on this remote by default.  * `remote.<name>.annex-sync-command` @@ -1376,19 +1411,22 @@  * `remote.<name>.annex-pull` -  If set to `false`, prevents git-annex sync (and the git-annex assistant-  etc) from ever pulling (or fetching) from the remote.+  If set to `false`, prevents `git-annex pull`, `git-annex sync`,+  `git-annex assist` and the `git-annex assistant` from ever pulling+  (or fetching) from the remote.  * `remote.<name>.annex-push` -  If set to `false`, prevents git-annex sync (and the git-annex assistant-  etc) from ever pushing to the remote.+  If set to `false`, prevents `git-annex push`, `git-annex sync`,+  `git-annex assist` and the `git-annex assistant` from ever pushing+  to the remote.  * `remote.<name>.annex-readonly`    If set to `true`, prevents git-annex from making changes to a remote.-  This both prevents git-annex sync from pushing changes, and prevents-  storing or removing files from read-only remote.+  This prevents `git-annex sync` and `git-annex assist` from pushing+  changes to a git repository. And it prevents storing or removing+  files from read-only remote.  * `remote.<name>.annex-verify`, `annex.verify` @@ -1410,9 +1448,11 @@   When set to eg, "master:subdir", the special remote tracks only   the subdirectory of that branch. -  `git-annex sync --content` will import changes from the remote and -  merge them into the annex-tracking-branch. They also export changes-  made to the branch to the remote.+  Setting this enables some other command to work with these special+  remotes: `git-annex pull` will import changes from the remote and merge them into+  the annex-tracking-branch. And `git-annex push` will export changes to+  the remote. Higher-level commands `git-annex sync --content`+  and `git-annex assist` both import and export.  * `remote.<name>.annex-export-tracking` @@ -1737,19 +1777,19 @@  * `annex.youtube-dl-options` -  Options to pass to youtube-dl (or yt-dlp) when using it to find the url-  to download for a video.+  Options to pass to yt-dlp (or deprecated youtube-dl) when using it to+  find the url to download for a video. -  Some options may break git-annex's integration with youtube-dl. For+  Some options may break git-annex's integration with yt-dlp. For   example, the --output option could cause it to store files somewhere-  git-annex won't find them. Avoid setting here or in the youtube-dl config-  file any options that cause youtube-dl to download more than one file,+  git-annex won't find them. Avoid setting here or in the yt-dlp config+  file any options that cause it to download more than one file,   or to store the file anywhere other than the current working directory.  * `annex.youtube-dl-command` -  Command to run for youtube-dl. Default is to use "youtube-dl" or -  if that is not available in the PATH, to use "yt-dlp".+  Default is to use "yt-dlp" or if that is not available in the PATH, +  to use "youtube-dl".  * `annex.aria-torrent-options` @@ -1800,8 +1840,8 @@   causing it to be downloaded into your repository and transferred to   other remotes, exposing its content. -  Note that, since the interfaces of curl and youtube-dl do not allow-  these IP address restrictions to be enforced, curl and youtube-dl will+  Note that, since the interfaces of curl and yt-dlp do not allow+  these IP address restrictions to be enforced, curl and yt-dlp will   never be used unless annex.security.allowed-ip-addresses=all.      To allow accessing local or private IP addresses on only specific ports,@@ -1904,8 +1944,9 @@  * `annex.autocommit` -  Set to false to prevent the git-annex assistant and git-annex sync-  from automatically committing changes to files in the repository.+  Set to false to prevent the `git-annex assistant`, `git-annex assist`, +  and `git-annex sync` from automatically committing changes to files in+  the repository.    To configure the behavior in all clones of the repository,   this can be set in [[git-annex-config]](1).
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20230407+Version: 10.20230626 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -45,11 +45,13 @@   doc/git-annex-addunused.mdwn   doc/git-annex-addurl.mdwn   doc/git-annex-adjust.mdwn+  doc/git-annex-assist.mdwn   doc/git-annex-assistant.mdwn   doc/git-annex-backends.mdwn   doc/git-annex-calckey.mdwn   doc/git-annex-checkpresentkey.mdwn   doc/git-annex-config.mdwn+  doc/git-annex-configremote.mdwn   doc/git-annex-contentlocation.mdwn   doc/git-annex-copy.mdwn   doc/git-annex-dead.mdwn@@ -102,6 +104,8 @@   doc/git-annex-pre-commit.mdwn   doc/git-annex-preferred-content.mdwn   doc/git-annex-proxy.mdwn+  doc/git-annex-pull.mdwn+  doc/git-annex-push.mdwn   doc/git-annex-readpresentkey.mdwn   doc/git-annex-registerurl.mdwn   doc/git-annex-reinit.mdwn@@ -307,7 +311,7 @@   Build-Depends:    base (>= 4.11.1.0 && < 5.0),    network-uri (>= 2.6),-   optparse-applicative (>= 0.14.1),+   optparse-applicative (>= 0.14.2),    containers (>= 0.5.8),    exceptions (>= 0.6),    stm (>= 2.3),@@ -706,11 +710,13 @@     Command.AddUnused     Command.AddUrl     Command.Adjust+    Command.Assist     Command.Benchmark     Command.CalcKey     Command.CheckPresentKey     Command.Config     Command.ConfigList+    Command.ConfigRemote     Command.ContentLocation     Command.Copy     Command.Dead@@ -768,6 +774,8 @@     Command.PostReceive     Command.PreCommit     Command.Proxy+    Command.Pull+    Command.Push     Command.ReKey     Command.ReadPresentKey     Command.RecvKey@@ -856,7 +864,6 @@     Git.Env     Git.FileMode     Git.FilePath-    Git.Filename     Git.FilterProcess     Git.Fsck     Git.GCrypt@@ -871,6 +878,7 @@     Git.Objects     Git.PktLine     Git.Queue+    Git.Quote     Git.Ref     Git.RefLog     Git.Remote@@ -890,6 +898,7 @@     Limit.Wanted     Logs     Logs.Activity+    Logs.AdjustedBranchUpdate     Logs.Chunk     Logs.Chunk.Pure     Logs.Config@@ -902,6 +911,7 @@     Logs.File     Logs.FsckResults     Logs.Group+    Logs.Import     Logs.Line     Logs.Location     Logs.MapLog@@ -1133,6 +1143,7 @@     Utility.ResourcePool     Utility.Rsync     Utility.SafeCommand+    Utility.SafeOutput     Utility.Scheduled     Utility.Scheduled.QuickCheck     Utility.Shell@@ -1143,6 +1154,7 @@     Utility.SshHost     Utility.Su     Utility.SystemDirectory+    Utility.Terminal     Utility.TimeStamp     Utility.TList     Utility.Tense
git-annex.hs view
@@ -16,6 +16,7 @@ import qualified CmdLine.GitRemoteTorAnnex import qualified Test import qualified Benchmark+import Messages import Utility.FileSystemEncoding  #ifdef mingw32_HOST_OS@@ -24,7 +25,7 @@ #endif  main :: IO ()-main = withSocketsDo $ do+main = sanitizeTopLevelExceptionMessages $ withSocketsDo $ do 	useFileSystemEncoding 	ps <- getArgs #ifdef mingw32_HOST_OS