91ba0cc7fd
This reverts commit a325524454.
Turns out this was predicated on an incorrect belief that json output
didn't already sometimes lack the "key" field. Since json output already
can when `giveup` was used, it seems unncessary to add a whole new
option for this.
111 lines
3.2 KiB
Haskell
111 lines
3.2 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 (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)
|