fix problem with last commit and assistant

liftAnnex blocks all others calls, so avoid using it with a long-duration
call to readResponse.

Assistant/TransferSlots.hs

@@ -155,7 +155,7 @@ genTransfer t info = case transferRemote info of
 	 - usual cleanup. However, first check if something else is
 	 - running the transfer, to avoid removing active transfers.
 	 -}
-	go remote transferrer = ifM (liftAnnex $ performTransfer transferrer t info)
+	go remote transferrer = ifM (performTransfer transferrer t info)
 		( do
 			case associatedFile info of
 				AssociatedFile Nothing -> noop

Assistant/TransferrerPool.hs

@@ -55,10 +55,17 @@ checkTransferrerPoolItem program batchmaker i = case i of
 
 {- Requests that a Transferrer perform a Transfer, and waits for it to
  - finish. -}
-performTransfer :: Transferrer -> Transfer -> TransferInfo -> Annex Bool
+performTransfer :: Transferrer -> Transfer -> TransferInfo -> Assistant Bool
 performTransfer transferrer t info = catchBoolIO $ do
 	(liftIO $ T.sendRequest t info (transferrerWrite transferrer))
-	T.readResponse (transferrerRead transferrer)
+	readresponse
+  where
+	readresponse = 
+		liftIO (T.readResponse (transferrerRead transferrer)) >>= \case
+			Right r -> return r
+			Left so -> do
+				liftAnnex $ emitSerializedOutput so
+				readresponse
 
 {- Starts a new git-annex transferkeys process, setting up handles
  - that will be used to communicate with it. -}

Command/TransferKeys.hs

@@ -19,7 +19,6 @@ import qualified Database.Keys
 import Annex.BranchState
 import Types.Messages
 import Types.Key
-import Messages.Internal
 
 import Text.Read (readMaybe)
 
@@ -102,6 +101,7 @@ runRequests readh writeh a = go Nothing Nothing
 		hPutStrLn writeh $ show $ TransferResult b
 		hFlush writeh
 
+-- FIXME this is bad when used with inAnnex
 sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
 sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest
 	(transferDirection t)
@@ -111,16 +111,14 @@ sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest
 
 -- | Read a response from this command.
 --
--- Each TransferOutput line that is read before the final TransferResult
+-- Before the final response, this will return whatever SerializedOutput
--- will be output.
+-- should be displayed as the transfer is performed.
-readResponse :: Handle -> Annex Bool
+readResponse :: Handle -> IO (Either SerializedOutput Bool)
 readResponse h = do
 	l <- liftIO $ hGetLine h
 	case readMaybe l of
-		Just (TransferOutput so) -> do
+		Just (TransferOutput so) -> return (Left so)
-			emitSerializedOutput so
+		Just (TransferResult r) -> return (Right r)
-			readResponse h
-		Just (TransferResult r) -> return r
 		Nothing -> protocolError l
 
 protocolError :: String -> a

Messages.hs

@@ -50,6 +50,7 @@ module Messages (
 	withMessageState,
 	prompt,
 	mkPrompter,
+	emitSerializedOutput,
 ) where
 
 import System.Log.Logger