2015-11-04 20:19:00 +00:00
|
|
|
{- git-annex output messages, including concurrent output to display regions
|
2015-04-03 20:48:30 +00:00
|
|
|
-
|
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
2023-04-10 18:47:32 +00:00
|
|
|
- Copyright 2010-2023 Joey Hess <id@joeyh.name>
|
2015-04-03 20:48:30 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2015-04-03 20:48:30 +00:00
|
|
|
-}
|
|
|
|
|
|
|
|
module Messages.Internal where
|
|
|
|
|
|
|
|
import Common
|
2015-11-04 18:52:07 +00:00
|
|
|
import Annex
|
2015-04-03 20:48:30 +00:00
|
|
|
import Types.Messages
|
2015-11-05 21:22:45 +00:00
|
|
|
import Messages.Concurrent
|
2018-02-19 18:59:30 +00:00
|
|
|
import qualified Messages.JSON as JSON
|
|
|
|
import Messages.JSON (JSONBuilder)
|
2023-04-12 21:18:29 +00:00
|
|
|
import Git.Quote
|
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
2023-04-10 18:47:32 +00:00
|
|
|
import Types.GitConfig
|
2016-09-09 19:49:44 +00:00
|
|
|
|
2019-11-26 19:27:22 +00:00
|
|
|
import qualified Data.ByteString as S
|
|
|
|
|
2016-09-09 16:57:42 +00:00
|
|
|
withMessageState :: (MessageState -> Annex a) -> Annex a
|
|
|
|
withMessageState a = Annex.getState Annex.output >>= a
|
2015-11-04 18:52:07 +00:00
|
|
|
|
2023-04-10 21:03:41 +00:00
|
|
|
outputMessage :: JSONBuilder -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
2018-02-06 17:03:55 +00:00
|
|
|
outputMessage = outputMessage' bufferJSON
|
|
|
|
|
2023-04-10 21:03:41 +00:00
|
|
|
outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
|
|
|
outputMessage' jsonoutputter jsonbuilder consolewhitespacef msg = withMessageState $ \s -> case outputType s of
|
2016-09-09 16:57:42 +00:00
|
|
|
NormalOutput
|
2021-06-16 00:43:00 +00:00
|
|
|
| concurrentOutputEnabled s -> do
|
2023-04-10 21:03:41 +00:00
|
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
2021-06-16 00:43:00 +00:00
|
|
|
liftIO $ clearProgressMeter s
|
2023-04-10 21:03:41 +00:00
|
|
|
concurrentMessage s False (decodeBS (consolewhitespacef (quote qp msg))) q
|
2021-06-16 00:43:00 +00:00
|
|
|
| otherwise -> do
|
2023-04-10 21:03:41 +00:00
|
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
2021-06-16 00:43:00 +00:00
|
|
|
liftIO $ clearProgressMeter s
|
2023-04-10 21:03:41 +00:00
|
|
|
liftIO $ flushed $ S.putStr (consolewhitespacef (quote qp msg))
|
2018-02-06 17:03:55 +00:00
|
|
|
JSONOutput _ -> void $ jsonoutputter jsonbuilder s
|
2016-09-09 18:21:06 +00:00
|
|
|
QuietOutput -> q
|
2020-12-04 18:54:09 +00:00
|
|
|
SerializedOutput h _ -> do
|
2023-04-10 21:03:41 +00:00
|
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
|
|
liftIO $ outputSerialized h $ OutputMessage $ consolewhitespacef $ quote qp msg
|
2020-12-03 18:47:04 +00:00
|
|
|
void $ jsonoutputter jsonbuilder s
|
2016-09-09 18:21:06 +00:00
|
|
|
|
2016-09-09 22:13:55 +00:00
|
|
|
-- Buffer changes to JSON until end is reached and then emit it.
|
2018-02-06 17:03:55 +00:00
|
|
|
bufferJSON :: JSONBuilder -> MessageState -> Annex Bool
|
|
|
|
bufferJSON jsonbuilder s = case outputType s of
|
2020-12-03 18:47:04 +00:00
|
|
|
JSONOutput _ -> go (flushed . JSON.emit)
|
2020-12-04 18:54:09 +00:00
|
|
|
SerializedOutput h _ -> go (outputSerialized h . JSONObject . JSON.encode)
|
2020-12-03 18:47:04 +00:00
|
|
|
_ -> return False
|
|
|
|
where
|
|
|
|
go emitter
|
|
|
|
| endjson = do
|
2016-09-09 22:13:55 +00:00
|
|
|
Annex.changeState $ \st ->
|
|
|
|
st { Annex.output = s { jsonBuffer = Nothing } }
|
2020-12-03 18:47:04 +00:00
|
|
|
maybe noop (liftIO . emitter . JSON.finalize) json
|
2016-09-09 18:21:06 +00:00
|
|
|
return True
|
2020-12-03 18:47:04 +00:00
|
|
|
| otherwise = do
|
2016-09-09 22:13:55 +00:00
|
|
|
Annex.changeState $ \st ->
|
|
|
|
st { Annex.output = s { jsonBuffer = json } }
|
2016-09-09 18:21:06 +00:00
|
|
|
return True
|
2020-12-03 18:47:04 +00:00
|
|
|
|
2016-09-09 22:13:55 +00:00
|
|
|
(json, endjson) = case jsonbuilder i of
|
|
|
|
Nothing -> (jsonBuffer s, False)
|
|
|
|
(Just (j, e)) -> (Just j, e)
|
2020-12-03 18:47:04 +00:00
|
|
|
|
2016-09-09 22:13:55 +00:00
|
|
|
i = case jsonBuffer s of
|
|
|
|
Nothing -> Nothing
|
|
|
|
Just b -> Just (b, False)
|
2016-09-09 19:06:54 +00:00
|
|
|
|
2018-02-06 17:03:55 +00:00
|
|
|
-- Immediately output JSON.
|
|
|
|
outputJSON :: JSONBuilder -> MessageState -> Annex Bool
|
|
|
|
outputJSON jsonbuilder s = case outputType s of
|
2020-12-03 18:47:04 +00:00
|
|
|
JSONOutput _ -> go (flushed . JSON.emit)
|
2020-12-04 18:54:09 +00:00
|
|
|
SerializedOutput h _ -> go (outputSerialized h . JSONObject . JSON.encode)
|
2020-12-03 18:47:04 +00:00
|
|
|
_ -> return False
|
|
|
|
where
|
|
|
|
go emitter = do
|
|
|
|
maybe noop (liftIO . emitter)
|
2018-02-06 17:03:55 +00:00
|
|
|
(fst <$> jsonbuilder Nothing)
|
|
|
|
return True
|
|
|
|
|
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
2023-04-10 18:47:32 +00:00
|
|
|
outputError :: (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
|
|
|
|
outputError consolewhitespacef msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of
|
2018-02-19 19:28:38 +00:00
|
|
|
(JSONOutput jsonoptions, Just jb) | jsonErrorMessages jsonoptions ->
|
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
2023-04-10 18:47:32 +00:00
|
|
|
let jb' = Just (JSON.addErrorMessage (lines (decodeBS (noquote msg))) jb)
|
2018-02-19 19:28:38 +00:00
|
|
|
in Annex.changeState $ \st ->
|
2018-02-19 19:39:52 +00:00
|
|
|
st { Annex.output = s { jsonBuffer = jb' } }
|
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
2023-04-10 18:47:32 +00:00
|
|
|
(SerializedOutput h _, _) -> do
|
|
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
|
|
liftIO $ outputSerialized h $ OutputError $ decodeBS $
|
|
|
|
consolewhitespacef $ quote qp msg
|
2023-04-25 21:02:25 +00:00
|
|
|
_ -> outputError' consolewhitespacef msg s
|
|
|
|
|
|
|
|
outputError' :: (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> MessageState -> Annex ()
|
|
|
|
outputError' consolewhitespacef msg s
|
|
|
|
| concurrentOutputEnabled s = do
|
|
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
|
|
concurrentMessage s True (decodeBS $ consolewhitespacef $ quote qp msg) go
|
|
|
|
| otherwise = go
|
2015-11-04 17:45:34 +00:00
|
|
|
where
|
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
2023-04-10 18:47:32 +00:00
|
|
|
go = do
|
|
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
|
|
liftIO $ hFlush stdout
|
|
|
|
liftIO $ S.hPutStr stderr (consolewhitespacef $ quote qp msg)
|
|
|
|
liftIO $ hFlush stderr
|
2015-11-04 17:45:34 +00:00
|
|
|
|
2023-04-25 21:02:25 +00:00
|
|
|
outputException :: String -> Maybe RawFilePath -> StringContainingQuotedPath -> Annex ()
|
|
|
|
outputException eid mfile msg = withMessageState $ \s -> case outputType s of
|
|
|
|
(JSONOutput jsonoptions) | jsonExceptions jsonoptions ->
|
|
|
|
liftIO $ flushed $ JSON.emit $
|
|
|
|
JSON.exceptionObject eid (decodeBS (noquote msg)) mfile
|
|
|
|
(SerializedOutput h _) -> do
|
|
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
|
|
liftIO $ outputSerialized h $ OutputException eid mfile $ decodeBS $
|
|
|
|
quote qp msg
|
|
|
|
_ -> outputError' id msg s
|
|
|
|
|
2015-04-03 20:48:30 +00:00
|
|
|
q :: Monad m => m ()
|
|
|
|
q = noop
|
|
|
|
|
|
|
|
flushed :: IO () -> IO ()
|
|
|
|
flushed a = a >> hFlush stdout
|
2020-12-03 17:01:28 +00:00
|
|
|
|
new protocol for transferkeys, with message serialization
Necessarily threw out the old protocol, so if an old git-annex assistant
is running, and starts a transferkeys from the new git-annex, it would
fail. But, that seems unlikely; the assistant starts up transferkeys
processes and then keeps them running. Still, may need to test that
scenario.
The new protocol is simple read/show and looks like this:
TransferRequest Download (Right "origin") (Key {keyName = "f8f8766a836fb6120abf4d5328ce8761404e437529e997aaa0363bdd4fecd7bb", keyVariety = SHA2Key (HashSize 256) (HasExt True), keySize = Just 30, keyMtime = Nothing, keyChunkSize = Nothing, keyChunkNum = Nothing}) (AssociatedFile (Just "foo"))
TransferOutput (ProgressMeter (Just 30) (MeterState {meterBytesProcessed = BytesProcessed 0, meterTimeStamp = 1.6070268727892535e9}) (MeterState {meterBytesProcessed = BytesProcessed 30, meterTimeStamp = 1.6070268728043e9}))
TransferOutput (OutputMessage "(checksum...) ")
TransferResult True
Granted, this is not optimally fast, but it seems good enough, and is
probably nearly as fast as the old protocol anyhow.
emitSerializedOutput for ProgressMeter is not yet implemented. It needs
to somehow start or update a progress meter. There may need to be a new
message that allocates a progress meter, and then have ProgressMeter
update it.
This commit was sponsored by Ethan Aubin
2020-12-03 20:21:20 +00:00
|
|
|
outputSerialized :: (SerializedOutput -> IO ()) -> SerializedOutput -> IO ()
|
|
|
|
outputSerialized = id
|
2020-12-04 18:54:09 +00:00
|
|
|
|
|
|
|
-- | Wait for the specified response.
|
|
|
|
waitOutputSerializedResponse :: (IO (Maybe SerializedOutputResponse)) -> SerializedOutputResponse -> IO ()
|
|
|
|
waitOutputSerializedResponse getr r = tryIO getr >>= \case
|
|
|
|
Right (Just r') | r' == r -> return ()
|
2023-04-10 17:38:14 +00:00
|
|
|
v -> giveup $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v
|