filter out control characters in warning messages

Converted warning and similar to use StringContainingQuotedPath. Most
warnings are static strings, some do refer to filepaths that need to be
quoted, and others don't need quoting.

Note that, since quote filters out control characters of even
UnquotedString, this makes all warnings safe, even when an attacker
sneaks in a control character in some other way.

When json is being output, no quoting is done, since json gets its own
quoting.

This does, as a side effect, make warning messages in json output not
be indented. The indentation is only needed to offset warning messages
underneath the display of the file they apply to, so that's ok.

Sponsored-by: Brett Eisenberg on Patreon

Annex/Action.hs

@@ -37,14 +37,14 @@ action :: Annex () -> Annex Bool
 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

@@ -209,7 +209,7 @@ enterAdjustedBranch adj = inRepo Git.Branch.current >>= \case
 		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."
@@ -343,7 +343,7 @@ adjustedBranchRefreshFull adj origbranch = do
 	restagePointerFiles =<< Annex.gitRepo
 	let adjbranch = originalToAdjusted origbranch adj
 	unlessM (updateAdjustedBranch adj adjbranch origbranch) $
-		warning $ unwords [ "Updating adjusted branch failed." ]
+		warning "Updating adjusted branch failed."
 
 adjustToCrippledFileSystem :: Annex ()
 adjustToCrippledFileSystem = do
@@ -497,7 +497,7 @@ propigateAdjustedCommits' origbranch adj _commitsprevented =
 			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 +505,8 @@ propigateAdjustedCommits' origbranch adj _commitsprevented =
 						)
 			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/BloomFilter.hs

@@ -27,7 +27,8 @@ bloomBitsHashes = do
 	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/Common.hs

@@ -10,6 +10,7 @@ import Annex as X (gitRepo, inRepo, fromRepo, calcRepo, calcRepo')
 import Annex.Locations as X
 import Annex.Debug as X (fastDebug, debug)
 import Messages as X
+import Git.Filename as X
 #ifndef mingw32_HOST_OS
 import System.Posix.IO as X hiding (createPipe)
 #endif

Annex/Content.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Annex.Content (
 	inAnnex,
@@ -447,7 +448,7 @@ checkSecureHashes' :: Key -> Annex Bool
 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 +761,10 @@ downloadUrl listfailedurls k p iv urls file uo =
 	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

@@ -126,7 +126,8 @@ checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getRea
 				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

@@ -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

@@ -15,6 +15,7 @@ import Types
 import Types.Key
 import qualified Git
 import qualified Types.Remote as Remote
+import Git.Filename
 import Messages
 
 import Data.Maybe
@@ -63,7 +64,7 @@ warnExportImportConflict r = do
 		(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/Hook.hs

@@ -66,7 +66,8 @@ hookUnWrite h = unlessM (inRepo $ Git.hookUnWrite h) $
 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 @@ runAnnexHook hook = do
   where
 	run = unlessM (inRepo $ Git.runHook hook) $ do
 		h <- fromRepo $ Git.hookFile hook
-		warning $ h ++ " failed"
+		warning $ UnquotedString $ h ++ " failed"

Annex/Import.hs

@@ -510,7 +510,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
 					showNote "old version"
 				tryNonAsync (importordownload cidmap db i largematcher) >>= \case
 					Left e -> next $ do
-						warning (show e)
+						warning (UnquotedString (show e))
 						liftIO $ atomically $
 							putTMVar job Nothing
 						return False
@@ -535,7 +535,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
 						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
@@ -578,7 +578,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
 			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
@@ -634,7 +634,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
 				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
@@ -662,7 +662,7 @@ importKeys remote importtreeconfig importcontent thirdpartypopulated importablec
 			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 $

Annex/Ingest.hs

@@ -48,7 +48,6 @@ import Utility.CopyFile
 import Utility.Touch
 import Utility.Metered
 import Git.FilePath
-import Git.Filename
 import Annex.InodeSentinal
 import Annex.AdjustedBranch
 import Annex.FileMatcher
@@ -88,7 +87,7 @@ data LockDownConfig = LockDownConfig
  -}
 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
 
@@ -227,7 +226,7 @@ ingest' preferredbackend meterupdate (Just (LockedDown cfg source)) mk restage =
 		return (Just k, mcache)
 
 	failure msg = do
-		warning $ fromRawFilePath (keyFilename source) ++ " " ++ msg
+		warning $ QuotedPath (keyFilename source) <> " " <> UnquotedString msg
 		cleanCruft source
 		return (Nothing, Nothing)
 
@@ -299,7 +298,7 @@ restoreFile file key e = do
 		-- 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
 
@@ -412,11 +411,10 @@ addingExistingLink :: RawFilePath -> Key -> Annex a -> Annex a
 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

@@ -79,7 +79,7 @@ checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case
 	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 @@ probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do
 		(Just (freezeContent' UnShared))
 		(Just (thawContent' UnShared))
 		=<< hasFreezeHook
-	mapM_ warning warnings
+	mapM_ (warning . UnquotedString) warnings
 	return r
 
 probeCrippledFileSystem'

Annex/Link.hs

@@ -186,7 +186,7 @@ newtype Restage = Restage Bool
 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 @@ restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do
 		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/LockPool/PosixOrPid.hs

@@ -32,6 +32,7 @@ import Utility.LockPool.STM (LockFile, LockMode(..))
 import Utility.LockFile.LockStatus
 import Config (pidLockFile)
 import Messages (warning)
+import Git.Filename
 
 import System.Posix
 
@@ -74,7 +75,7 @@ pidLock m f lockmode posixlock = debugLocks $ go =<< pidLockFile
 	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 m f lockmode posixlock = debugLocks $ liftIO . go =<< pidLockFile

Annex/MetaData.hs

@@ -56,7 +56,7 @@ genMetaData key file mmtime = do
 					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/SpecialRemote.hs

@@ -99,7 +99,7 @@ autoEnable = do
 				showSideAction $ "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/Ssh.hs

@@ -120,8 +120,8 @@ sshCachingInfo (host, port) = go =<< sshCacheDir'
 	
 	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"

Annex/Transfer.hs

@@ -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,
@@ -200,7 +200,7 @@ runTransfer' ignorelock t eventualbackend afile stalldetection retrydecider tran
 				| observeBool v -> return v
 				| otherwise -> checkretry
 			Left e -> do
-				warning (show e)
+				warning (UnquotedString (show e))
 				checkretry
 	  where
 		checkretry = do
@@ -289,7 +289,7 @@ preCheckSecureHashes k meventualbackend a = case meventualbackend of
 			)
 		)
 	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

Annex/Url.hs

@@ -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 :: U.URLString -> Maybe Integer -> U.UrlOptions -> Annex Bool
 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 @@ download' meterupdate iv url file uo =
 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

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Annex.Verify (
 	shouldVerify,
@@ -152,7 +153,7 @@ verifyKeySize k f = case fromKey keySize k of
 	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

@@ -148,7 +148,7 @@ youtubeDlTo key url dest p = do
 				return (Just True)
 			Right Nothing -> return (Just False)
 			Left msg -> do
-				warning msg
+				warning (UnquotedString msg)
 				return Nothing
 	return (fromMaybe False res)