That seems to be the last thing needed for message serialization.
Although it's only used in the assistant currently, so hard to tell if I
forgot something.
At this point, it should be possible to start using transferkeys
when performing transfers, which will allow killing a transferkeys
process if a transfer times out or stalls. But that's for another day.
This commit was sponsored by Ethan Aubin.
performTransfer transferrer t info = catchBoolIO $ do
(liftIO $ T.sendRequest t info (transferrerWrite transferrer))
relaySerializedOutput
- (liftIO (T.readResponse (transferrerRead transferrer)))
+ (liftIO $ T.readResponse (transferrerRead transferrer))
+ (liftIO . T.sendSerializedOutputResponse (transferrerWrite transferrer))
liftAnnex
{- Starts a new git-annex transferkeys process, setting up handles
start = do
enableInteractiveBranchAccess
(readh, writeh) <- liftIO dupIoHandles
- Annex.setOutput $ SerializedOutput $
- hPutStrLn writeh . show . TransferOutput
+ Annex.setOutput $ SerializedOutput
+ (hPutStrLn writeh . show . TransferOutput)
+ (readMaybe <$> hGetLine readh)
runRequests readh writeh runner
stop
where
hPutStrLn writeh $ show $ TransferResult b
hFlush writeh
--- FIXME this is bad when used with inAnnex
+-- | Send a request to this command to perform a transfer.
sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest
(transferDirection t)
(keyData (transferKey t))
(associatedFile tinfo)
+sendSerializedOutputResponse :: Handle -> SerializedOutputResponse -> IO ()
+sendSerializedOutputResponse h sor = hPutStrLn h $ show sor
+
-- | Read a response from this command.
--
-- Before the final response, this will return whatever SerializedOutput
NormalOutput -> concurrentOutputEnabled s
QuietOutput -> True
JSONOutput _ -> True
- SerializedOutput _ -> True
+ SerializedOutput _ _ -> True
jsonOutputEnabled :: Annex Bool
jsonOutputEnabled = withMessageState $ \s -> return $
where
goconcurrent = withMessageState $ \s -> do
let l = promptLock s
+ let (run, cleanup) = case outputType s of
+ SerializedOutput h hr ->
+ ( \a -> do
+ liftIO $ outputSerialized h StartPrompt
+ liftIO $ waitOutputSerializedResponse hr ReadyPrompt
+ a
+ , liftIO $ outputSerialized h EndPrompt
+ )
+ _ ->
+ ( hideRegionsWhile s
+ , noop
+ )
return $ \a ->
debugLocks $ bracketIO
(takeMVar l)
- (putMVar l)
- (const $ hideRegionsWhile s a)
+ (\v -> putMVar l v >> cleanup)
+ (const $ run a)
| otherwise -> liftIO $ flushed $ S.putStr msg
JSONOutput _ -> void $ jsonoutputter jsonbuilder s
QuietOutput -> q
- SerializedOutput h -> do
+ SerializedOutput h _ -> do
liftIO $ outputSerialized h $ OutputMessage msg
void $ jsonoutputter jsonbuilder s
bufferJSON :: JSONBuilder -> MessageState -> Annex Bool
bufferJSON jsonbuilder s = case outputType s of
JSONOutput _ -> go (flushed . JSON.emit)
- SerializedOutput h -> go (outputSerialized h . JSONObject . JSON.encode)
+ SerializedOutput h _ -> go (outputSerialized h . JSONObject . JSON.encode)
_ -> return False
where
go emitter
outputJSON :: JSONBuilder -> MessageState -> Annex Bool
outputJSON jsonbuilder s = case outputType s of
JSONOutput _ -> go (flushed . JSON.emit)
- SerializedOutput h -> go (outputSerialized h . JSONObject . JSON.encode)
+ SerializedOutput h _ -> go (outputSerialized h . JSONObject . JSON.encode)
_ -> return False
where
go emitter = do
let jb' = Just (JSON.addErrorMessage (lines msg) jb)
in Annex.changeState $ \st ->
st { Annex.output = s { jsonBuffer = jb' } }
- (SerializedOutput h, _) ->
+ (SerializedOutput h _, _) ->
liftIO $ outputSerialized h $ OutputError msg
_
| concurrentOutputEnabled s -> concurrentMessage s True msg go
outputSerialized :: (SerializedOutput -> IO ()) -> SerializedOutput -> IO ()
outputSerialized = id
+
+-- | Wait for the specified response.
+waitOutputSerializedResponse :: (IO (Maybe SerializedOutputResponse)) -> SerializedOutputResponse -> IO ()
+waitOutputSerializedResponse getr r = tryIO getr >>= \case
+ Right (Just r') | r' == r -> return ()
+ v -> error $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v
updateMeter meter
a meter (combinemeter m)
| otherwise = nometer
- go (MessageState { outputType = SerializedOutput h }) = do
+ go (MessageState { outputType = SerializedOutput h _ }) = do
liftIO $ outputSerialized h $ StartProgressMeter msize
meter <- liftIO $ mkMeter msize $ \_ _ _old new ->
outputSerialized h $ UpdateProgressMeter $
{-# LANGUAGE RankNTypes #-}
-module Messages.Serialized (outputSerialized, relaySerializedOutput) where
+module Messages.Serialized (
+ relaySerializedOutput,
+ outputSerialized,
+ waitOutputSerializedResponse,
+) where
import Common
import Annex
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 ())
-> (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 runannex = go Nothing
+relaySerializedOutput getso sendsor runannex = go Nothing
where
go st = loop st >>= \case
Right r -> return r
Left (JSONObject b) -> do
runannex $ withMessageState $ \s -> case outputType s of
JSONOutput _ -> liftIO $ flushed $ JSON.emit' b
- SerializedOutput h -> liftIO $
+ SerializedOutput h _ -> liftIO $
outputSerialized h $ JSONObject b
_ -> q
loop st
Just meterupdate -> liftIO $ meterupdate n
Nothing -> noop
loop st
+ Left StartPrompt -> 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)
= NormalOutput
| QuietOutput
| JSONOutput JSONOptions
- | SerializedOutput (SerializedOutput -> IO ())
+ | SerializedOutput
+ (SerializedOutput -> IO ())
+ (IO (Maybe SerializedOutputResponse))
data JSONOptions = JSONOptions
{ jsonProgress :: Bool
| StartProgressMeter (Maybe FileSize)
| UpdateProgressMeter BytesProcessed
| EndProgressMeter
+ | StartPrompt
+ | EndPrompt
| JSONObject L.ByteString
-- ^ This is always sent, it's up to the consumer to decide if it
-- wants to display JSON, or human-readable messages.
deriving (Show, Read)
+
+data SerializedOutputResponse
+ = ReadyPrompt
+ deriving (Eq, Show, Read)
outputs to stderr directly no matter the output type currently.
It would need to be changed to support the new output type.
(And probably should for concurrent output mode too actually!)
+
+ > It's true, this is not concurrent output safe. However, that's already
+ > the case, and output to stderr doesn't affect the piping of serialized
+ > messages on stdout. So, punted on this.
+
* So does warningIO, though it's only used in a couple of remotes
and rarely. It would be good to find a way to eliminate it.
+ > Eliminated except for one call in a non-relevant code path.
+
* Messages.prompt. Which is used by remotes, and would need to
communicate over the pipe to the parent git-annex bidirectionally.
Eg, send a message saying the parent needs to prepare for prompt,
prompting is done. (Note that the parent would need to detect if the child
process crashed to avoid being locked waiting for the prompt.)
-* Messages.Internal.outputMessage is used by several things, and
- includes some special parameters used in json mode. Since the parent
- git-annex might itself have json mode enabled, those parameters will need
- to be included in the serialization. But those parameters are currently
- actually functions that manipulate the json object that will be outputted
- later. So cannot be serialized. Uuuuh.
-
- Maybe the thing to do is, pass along the --json options to transferkeys,
- and have a message type for json objects, which it uses to send them
- to git-annex, which can then output them. outputMessage can handle the
- new output type by sending the message through the pipe, and also
- building any json object, and sending it through the pipe once it's done.
+ > Done.
-> Started work on this in the message-serialization branch. --[[Joey]]
+[[done]]
projects / git-annex.git / commitdiff