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
This commit is contained in:
Joey Hess 2023-04-10 14:47:32 -04:00
parent 007e302637
commit 3290a09a70
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
75 changed files with 259 additions and 229 deletions

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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