filter out control characters and quote filenames

Searched for uses of putStr and hPutStr and changed appropriate ones to filter
out control characters and quote filenames.

This notably does not make find and findkeys quote filenames in their default
output. Because they should only do that when stdout is non a pipe.

A few commands like calckey and lookupkey seem too low-level to make sense to filter
output, so skipped those.

Also when relaying output from other commands that is not progress output,
have git-annex filter out control characters.

Sponsored-by: k0ld on Patreon

CHANGELOG

@@ -1,9 +1,12 @@
 git-annex (10.20230408) UNRELEASED; urgency=medium
 
-  * Many commands now display filenames that contain unusual characters the
+  * Many commands now quotes 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 information coming from the repository or other
+    possible untrusted sources are filtered out of the display of many
+    commands.
   * addurl --preserve-filename now rejects filenames that contain other
     control characters, besides the escape sequences it already rejected.
 

Command/CheckPresentKey.hs

@@ -10,6 +10,7 @@ module Command.CheckPresentKey where
 import Command
 import qualified Remote
 import Remote.List
+import Utility.SafeOutput
 
 cmd :: Command
 cmd = noCommit $ noMessages $
@@ -68,7 +69,7 @@ exitResult :: Result -> Annex a
 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

@@ -14,6 +14,7 @@ import Logs.Config
 import Config
 import Types.GitConfig (globalConfigs)
 import Git.Types (fromConfigValue)
+import Utility.SafeOutput
 
 import qualified Data.ByteString.Char8 as S8
 
@@ -75,7 +76,7 @@ seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction
 seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $
 	startingCustomOutput ai $ do
 		getGlobalConfig ck >>= \case
-			Just (ConfigValue v) -> liftIO $ S8.putStrLn v
+			Just (ConfigValue v) -> liftIO $ S8.putStrLn $ safeOutput v
 			Just NoConfigValue -> return ()
 			Nothing -> return ()
 		next $ return True

Command/Group.hs

@@ -11,6 +11,7 @@ import Command
 import qualified Remote
 import Logs.Group
 import Types.Group
+import Utility.SafeOutput
 
 import qualified Data.Set as S
 
@@ -32,7 +33,7 @@ start ps@(name:g:[]) = do
 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/List.hs

@@ -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] $
@@ -75,12 +80,14 @@ getList o
 			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 @@ lheader remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length
 	trust UnTrusted = " (untrusted)"
 	trust _ = ""
 
-format :: [(TrustLevel, Present)] -> RawFilePath -> String
+format :: [(TrustLevel, Present)] -> RawFilePath -> StringContainingQuotedPath
-format remotes file = thereMap ++ " " ++ fromRawFilePath file
+format remotes file = UnquotedString (thereMap) <> " " <> QuotedPath file
   where 
 	thereMap = concatMap there remotes
 	there (UnTrusted, True) = "x"

Command/Log.hs

@@ -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 qualified Data.Map as M
 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
@@ -166,15 +169,17 @@ mkOutputter m zone o file
 	lookupdescription u = maybe (fromUUID u) (fromUUIDDesc) (M.lookup u m)
 
 normalOutput :: (UUID -> String) -> FilePath -> (POSIXTime -> String) -> Outputter
-normalOutput lookupdescription file formattime logchange ts us =
+normalOutput lookupdescription file formattime logchange ts us = do
-	liftIO $ mapM_ (putStrLn . format) us
+	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, "|", 
+	format u = UnquotedString addel <> " " <> UnquotedString time <> " " 
-		fromUUID u ++ " -- " ++ lookupdescription u ]
+		<> QuotedPath (toRawFilePath file) <> " | " <> UnquotedByteString (fromUUID u)
+		<> " -- " <> UnquotedString (lookupdescription u)
 
 gourceOutput :: (UUID -> String) -> FilePath -> Outputter
 gourceOutput lookupdescription file logchange ts us =

Command/MetaData.hs

@@ -15,6 +15,7 @@ import Annex.WorkTree
 import Messages.JSON (JSONActionItem(..), AddJSONActionItemFields(..))
 import Types.Messages
 import Utility.Aeson
+import Utility.SafeOutput
 import Limit
 
 import qualified Data.Set as S
@@ -109,7 +110,7 @@ startKeys c o (si, k, ai) = case getSet o of
 	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

Command/P2P.hs

@@ -24,6 +24,7 @@ import Utility.AuthToken
 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 @@ genAddresses addrs = do
 	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
 

Command/Schedule.hs

@@ -11,6 +11,7 @@ import Command
 import qualified Remote
 import Logs.Schedule
 import Types.ScheduledActivity
+import Utility.SafeOutput
 
 import qualified Data.Set as S
 
@@ -40,7 +41,7 @@ start = parse
 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/Status.hs

@@ -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 (Renamed _ _) = noop
 displayStatus s = do
 	let c = statusChar s
 	absf <- fromRepo $ fromTopFilePath (statusFile s)
-	f <- liftIO $ fromRawFilePath <$> relPathCwdToFile absf
+	f <- liftIO $ relPathCwdToFile absf
-	unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $
+	qp <- coreQuotePath <$> Annex.getGitConfig
-		liftIO $ putStrLn $ [c] ++ " " ++ f
+	unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", fromRawFilePath f)]) $
+		liftIO $ B8.putStrLn $ quote qp $
+			UnquotedString (c : " ") <> QuotedPath f

Command/Wanted.hs

@@ -11,6 +11,7 @@ import Command
 import qualified Remote
 import Logs.PreferredContent
 import Types.StandardGroups
+import Utility.SafeOutput
 
 import qualified Data.Map as M
 
@@ -47,7 +48,7 @@ cmd' name desc getter setter = noMessages $
 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/WhereUsed.hs

@@ -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 Database.Keys
 
 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
@@ -58,7 +60,7 @@ start o (_, key, _) = startingCustomOutput key $ do
 	fs <- filterM stillassociated 
 		=<< 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 +73,11 @@ start o (_, key, _) = startingCustomOutput key $ do
 		Just k | k == key -> return True
 		_ -> return False
 
-display :: Key -> String -> IO ()
+display :: Key -> StringContainingQuotedPath -> Annex ()
-display key loc = putStrLn (serializeKey key ++ " " ++ loc)
+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 +94,15 @@ findHistorical key = do
 		, Param "--tags=*"
 		-- Output the commit hash
 		, Param "--pretty=%H"
-		] $ \h fs repo -> do
+		] $ \h fs -> do
-			commitsha <- getSha "log" (pure h)
+			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 +113,28 @@ findHistorical key = do
 			[ 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
+		let tf = asTopFilePath f
-		display key (fromRef fref)
+		display key (descBranchFilePath (BranchFilePath r tf))
 		return True
 
-searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Repo -> IO Bool) -> Annex Bool
+searchLog :: Key -> [CommandParam] -> (S.ByteString -> [RawFilePath] -> Annex Bool) -> Annex Bool
-searchLog key ps a = Annex.inRepo $ \repo -> do
+searchLog key ps a = do
-	(output, cleanup) <- Git.Command.pipeNullSplit ps' repo
+	(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
+			rfs <- liftIO $ mapM relPathCwdToFile fs
-			a (L.toStrict h) rfs repo
+			a (L.toStrict h) rfs
 		_ -> return False
-	void cleanup
+	liftIO $ void cleanup
 	return found
   where
 	ps' = 

Command/Whereis.hs

@@ -17,6 +17,7 @@ import Remote.Web (getWebUrls)
 import Annex.UUID
 import qualified Utility.Format
 import qualified Command.Find
+import Utility.SafeOutput
 
 import qualified Data.Map as M
 import qualified Data.Vector as V

Messages/Progress.hs

@@ -23,6 +23,7 @@ import Utility.InodeCache
 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
@@ -220,5 +221,5 @@ mkStderrEmitter :: Annex (String -> IO ())
 mkStderrEmitter = withMessageState go
   where
 	go s
-		| concurrentOutputEnabled s = return Console.errorConcurrent
+		| concurrentOutputEnabled s = return (Console.errorConcurrent . safeOutput)
-		| otherwise = return (hPutStrLn stderr)
+		| otherwise = return (hPutStrLn stderr . safeOutput)

Utility/Metered.hs

@@ -53,6 +53,7 @@ import Utility.DataUnits
 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 @@ demeterCommandEnv oh cmd params environ = do
   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