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

Remote/Adb.hs

@@ -6,6 +6,7 @@
  -}
 
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Remote.Adb (remote) where
 

Remote/External.hs

@@ -583,7 +583,7 @@ receiveMessage st external handleresponse handlerequest handleexceptional =
 				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 @@ startExternal' external = do
 				] ++ exrest
 
 	unusable msg = do
-		warning msg
+		warning (UnquotedString msg)
 		giveup ("unable to use external special remote " ++ basecmd)
 
 stopExternal :: External -> Annex ()

Remote/External/AsyncExtension.hs

@@ -7,6 +7,7 @@
 
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Remote.External.AsyncExtension (runRelayToExternalAsync) where
 
@@ -86,7 +87,7 @@ receiveloop external st jidmap sendq sendthread annexrunner = externalReceive st
 	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

@@ -122,7 +122,7 @@ gen baser u rc gc rs = do
 				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)

Remote/Git.hs

@@ -275,12 +275,12 @@ tryGitConfigRead autoinit r hasuuid
 		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 +306,7 @@ tryGitConfigRead autoinit r hasuuid
 				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 +323,9 @@ tryGitConfigRead autoinit r hasuuid
 		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 +348,7 @@ tryGitConfigRead autoinit r hasuuid
 		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 +359,7 @@ tryGitConfigRead autoinit r hasuuid
 		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
@@ -770,7 +770,7 @@ mkState r u gc = do
 					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

@@ -253,7 +253,7 @@ discoverLFSEndpoint tro h
 			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 @@ discoverLFSEndpoint tro h
 			(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

@@ -100,7 +100,7 @@ storeChunked annexrunner chunksize dests storer content =
 		| 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/Ssh.hs

@@ -298,7 +298,7 @@ runProtoConn a conn@(P2P.OpenConnection (runst, c, _)) = do
 		-- 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

@@ -128,7 +128,7 @@ lookupHook hookname action = do
 			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 @@ runHook' hook action k f a = maybe (return False) run =<< lookupHook hook action
 		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/P2P.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Remote.P2P (
 	remote,
 	chainGen
@@ -105,7 +107,7 @@ runProtoConn a c@(OpenConnection (runst, conn)) = do
 	-- 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 @@ openConnection u addr = do
 					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/S3.hs

@@ -423,13 +423,13 @@ retrieve hv r rs c info = fileRetriever' $ \f k p iv -> 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 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 :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig ->
 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 $ 
@@ -865,7 +865,7 @@ data S3HandleProblem
 
 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."