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:
parent
007e302637
commit
3290a09a70
75 changed files with 259 additions and 229 deletions
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Remote.Adb (remote) where
|
||||
|
||||
|
|
|
@ -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 ()
|
||||
|
|
3
Remote/External/AsyncExtension.hs
vendored
3
Remote/External/AsyncExtension.hs
vendored
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
10
Remote/S3.hs
10
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."
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue