a325524454
Added a --json-exceptions option, which makes some exceptions be output in json. The distinction is that --json-error-messages is for messages relating to a particular ActionItem, while --json-exceptions is for messages that are not, eg ones for a file that does not exist. It's unfortunate that we need two switches with such a fine distinction between them, but I'm worried about maintaining backwards compatability in the json output, to avoid breaking anything that parses it, and this was the way to make sure I didn't. toplevelWarning is generally used for the latter kind of message. And the other calls to toplevelWarning could be converted to showException. The only possible gotcha is that if toplevelWarning is ever called after starting acting on a file, it will add to the --json-error-messages of the json displayed for that file and converting to showException would be a behavior change. That seems unlikely, but I didn't convery everything to avoid needing to satisfy myself it was not a concern. Sponsored-by: Dartmouth College's Datalad project
114 lines
3.3 KiB
Haskell
114 lines
3.3 KiB
Haskell
{- serialized output
|
|
-
|
|
- Copyright 2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module Messages.Serialized (
|
|
relaySerializedOutput,
|
|
outputSerialized,
|
|
waitOutputSerializedResponse,
|
|
) where
|
|
|
|
import Common
|
|
import Annex
|
|
import Types.Messages
|
|
import Messages
|
|
import Messages.Internal
|
|
import Messages.Progress
|
|
import qualified Messages.JSON as JSON
|
|
import Utility.Metered (BytesProcessed, setMeterTotalSize)
|
|
import Git.Quote
|
|
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
|
|
-- | Relay serialized output from a child process to the console.
|
|
relaySerializedOutput
|
|
:: (Monad m, MonadIO m, MonadMask m)
|
|
=> m (Either SerializedOutput r)
|
|
-- ^ Get next serialized output, or final value to return.
|
|
-> (SerializedOutputResponse -> m ())
|
|
-- ^ Send response to child process.
|
|
-> (Maybe BytesProcessed -> m ())
|
|
-- ^ When a progress meter is running, it is updated with
|
|
-- progress meter values sent by the process.
|
|
-- When a progress meter is stopped, Nothing is sent.
|
|
-> (forall a. Annex a -> m a)
|
|
-- ^ Run an annex action in the monad. Will not be used with
|
|
-- actions that block for a long time.
|
|
-> m r
|
|
relaySerializedOutput getso sendsor meterreport runannex = go Nothing
|
|
where
|
|
go st = loop st >>= \case
|
|
Right r -> return r
|
|
Left st' -> go st'
|
|
|
|
loop st = getso >>= \case
|
|
Right r -> return (Right r)
|
|
Left (OutputMessage msg) -> do
|
|
runannex $ outputMessage'
|
|
(\_ _ -> return False)
|
|
id
|
|
id
|
|
(UnquotedByteString msg)
|
|
loop st
|
|
Left (OutputError msg) -> do
|
|
runannex $ outputError id $ UnquotedString msg
|
|
loop st
|
|
Left (OutputException eid mfile msg) -> do
|
|
runannex $ outputException eid mfile $ UnquotedString msg
|
|
loop st
|
|
Left (JSONObject b) -> do
|
|
runannex $ withMessageState $ \s -> case outputType s of
|
|
JSONOutput _ -> liftIO $ flushed $ JSON.emit' b
|
|
SerializedOutput h _ -> liftIO $
|
|
outputSerialized h $ JSONObject b
|
|
_ -> q
|
|
loop st
|
|
Left BeginProgressMeter -> do
|
|
ost <- runannex (Annex.getState Annex.output)
|
|
let setclear = const noop
|
|
-- Display a progress meter while running, until
|
|
-- the meter ends or a final value is returned.
|
|
metered' ost setclear Nothing Nothing Nothing (runannex showOutput)
|
|
(\meter meterupdate -> loop (Just (meter, meterupdate)))
|
|
>>= \case
|
|
Right r -> return (Right r)
|
|
-- Continue processing serialized
|
|
-- output after the progress meter
|
|
-- is done.
|
|
Left _st' -> loop Nothing
|
|
Left EndProgressMeter -> do
|
|
meterreport Nothing
|
|
return (Left st)
|
|
Left (UpdateProgressMeter n) -> do
|
|
case st of
|
|
Just (_, meterupdate) -> do
|
|
meterreport (Just n)
|
|
liftIO $ meterupdate n
|
|
Nothing -> noop
|
|
loop st
|
|
Left (UpdateProgressMeterTotalSize sz) -> do
|
|
case st of
|
|
Just (meter, _) -> liftIO $
|
|
setMeterTotalSize meter sz
|
|
Nothing -> noop
|
|
loop st
|
|
Left BeginPrompt -> do
|
|
prompter <- runannex mkPrompter
|
|
v <- prompter $ do
|
|
sendsor ReadyPrompt
|
|
-- Continue processing serialized output
|
|
-- until EndPrompt or a final value is
|
|
-- returned. (EndPrompt is all that
|
|
-- ought to be sent while in a prompt
|
|
-- really, but if something else did get
|
|
-- sent, display it just in case.)
|
|
loop st
|
|
case v of
|
|
Right r -> return (Right r)
|
|
Left st' -> loop st'
|
|
Left EndPrompt -> return (Left st)
|