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

@@ -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

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

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)

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

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 $

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)

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)

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.
+  > Done.
 
-  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.
-
-> Started work on this in the message-serialization branch. --[[Joey]]
+[[done]]