fix problem with last commit and assistant

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

diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 12abd10b5d17ac450c2a22e5747c447db1ed7d0b..59066ee69cae7fd02c4e87891d367d9814c9464b 100644 (file)
--- a/Assistant/TransferSlots.hs
+++ b/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

diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs
index 0e3ee71734a2f6c7b444d4509dba8da641f26445..da66a2dc208f1ca9d92c250235b3f06ce389fd90 100644 (file)
--- a/Assistant/TransferrerPool.hs
+++ b/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. -}

diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs
index 36db8ce18b9a70614c6665493bd4d75ca33a22ad..f5ccbe9492cc82776b64cd3054d95d7e4e8ae607 100644 (file)
--- a/Command/TransferKeys.hs
+++ b/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
--- will be output.
-readResponse :: Handle -> Annex Bool
+-- Before the final response, this will return whatever SerializedOutput
+-- should be displayed as the transfer is performed.
+readResponse :: Handle -> IO (Either SerializedOutput Bool)
 readResponse h = do
        l <- liftIO $ hGetLine h
        case readMaybe l of
-               Just (TransferOutput so) -> do
-                       emitSerializedOutput so
-                       readResponse h
-               Just (TransferResult r) -> return r
+               Just (TransferOutput so) -> return (Left so)
+               Just (TransferResult r) -> return (Right r)
                Nothing -> protocolError l
 
 protocolError :: String -> a

diff --git a/Messages.hs b/Messages.hs
index 87911376e8e00765a3061cdfac53f19863409d87..f68b5f3da0fc3d42215454cf6c24070b6494ca2a 100644 (file)
--- a/Messages.hs
+++ b/Messages.hs
@@ -50,6 +50,7 @@ module Messages (
        withMessageState,
        prompt,
        mkPrompter,
+       emitSerializedOutput,
 ) where
 
 import System.Log.Logger