From 438d5be1f77e7c9d7ebe8af56db284ab9329ee01 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 4 Dec 2020 14:54:09 -0400 Subject: [PATCH] support prompt in message serialization 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. --- Assistant/TransferrerPool.hs | 3 ++- Command/TransferKeys.hs | 10 ++++--- Messages.hs | 18 ++++++++++--- Messages/Internal.hs | 14 +++++++--- Messages/Progress.hs | 2 +- Messages/Serialized.hs | 27 ++++++++++++++++--- Types/Messages.hs | 10 ++++++- .../serialize_Messages_for_transferkeys.mdwn | 22 +++++++-------- 8 files changed, 77 insertions(+), 29 deletions(-) diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs index 8566fea2cb..e29a4bf839 100644 --- a/Assistant/TransferrerPool.hs +++ b/Assistant/TransferrerPool.hs @@ -60,7 +60,8 @@ performTransfer :: Transferrer -> Transfer -> TransferInfo -> Assistant Bool 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 diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index f5ccbe9492..be7b4be01d 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -41,8 +41,9 @@ start :: CommandStart 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 @@ -101,7 +102,7 @@ runRequests readh writeh a = go Nothing Nothing 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) @@ -109,6 +110,9 @@ sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest (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 diff --git a/Messages.hs b/Messages.hs index 87911376e8..2dcd2a3250 100644 --- a/Messages.hs +++ b/Messages.hs @@ -288,7 +288,7 @@ commandProgressDisabled = withMessageState $ \s -> return $ NormalOutput -> concurrentOutputEnabled s QuietOutput -> True JSONOutput _ -> True - SerializedOutput _ -> True + SerializedOutput _ _ -> True jsonOutputEnabled :: Annex Bool jsonOutputEnabled = withMessageState $ \s -> return $ @@ -314,8 +314,20 @@ mkPrompter = getConcurrency >>= \case 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) diff --git a/Messages/Internal.hs b/Messages/Internal.hs index b48df97373..138f7df2bd 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -29,7 +29,7 @@ outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case out | 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 @@ -37,7 +37,7 @@ outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case out 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 @@ -63,7 +63,7 @@ bufferJSON jsonbuilder s = case outputType s of 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 @@ -77,7 +77,7 @@ outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of 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 @@ -96,3 +96,9 @@ flushed a = a >> hFlush stdout 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 diff --git a/Messages/Progress.hs b/Messages/Progress.hs index c5bf0710c3..8fd056e901 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -113,7 +113,7 @@ metered' st othermeter msize showoutput a = go st 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 $ diff --git a/Messages/Serialized.hs b/Messages/Serialized.hs index 6f14604bca..b58d131ace 100644 --- a/Messages/Serialized.hs +++ b/Messages/Serialized.hs @@ -7,7 +7,11 @@ {-# LANGUAGE RankNTypes #-} -module Messages.Serialized (outputSerialized, relaySerializedOutput) where +module Messages.Serialized ( + relaySerializedOutput, + outputSerialized, + waitOutputSerializedResponse, +) where import Common import Annex @@ -19,15 +23,17 @@ import qualified Messages.JSON as JSON 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 @@ -47,7 +53,7 @@ relaySerializedOutput getso runannex = go Nothing 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 @@ -69,3 +75,18 @@ relaySerializedOutput getso runannex = go Nothing 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) diff --git a/Types/Messages.hs b/Types/Messages.hs index b1e5d4e8f0..80fc176c45 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -20,7 +20,9 @@ data OutputType = NormalOutput | QuietOutput | JSONOutput JSONOptions - | SerializedOutput (SerializedOutput -> IO ()) + | SerializedOutput + (SerializedOutput -> IO ()) + (IO (Maybe SerializedOutputResponse)) data JSONOptions = JSONOptions { jsonProgress :: Bool @@ -70,7 +72,13 @@ data SerializedOutput | 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) diff --git a/doc/todo/serialize_Messages_for_transferkeys.mdwn b/doc/todo/serialize_Messages_for_transferkeys.mdwn index e9f7205734..18a1aafcaa 100644 --- a/doc/todo/serialize_Messages_for_transferkeys.mdwn +++ b/doc/todo/serialize_Messages_for_transferkeys.mdwn @@ -25,9 +25,16 @@ A few notes on implementing that: 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, @@ -35,17 +42,6 @@ A few notes on implementing that: 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]] -- 2.30.2