extend transferrer protocol to send progress bar total size updates

New protocol is not back-compat with old one, but it's never been
released so that's ok.

diff --git a/Messages.hs b/Messages.hs
index 2dcd2a325074f2d19a16bfa84e1a3653776d18a5..7ad270bf9900604c1292035393a74792e7785ee6 100644 (file)
--- a/Messages.hs
+++ b/Messages.hs
@@ -317,7 +317,7 @@ mkPrompter = getConcurrency >>= \case
                let (run, cleanup) = case outputType s of
                        SerializedOutput h hr ->
                                ( \a -> do
-                                       liftIO $ outputSerialized h StartPrompt
+                                       liftIO $ outputSerialized h BeginPrompt
                                        liftIO $ waitOutputSerializedResponse hr ReadyPrompt
                                        a
                                , liftIO $ outputSerialized h EndPrompt

diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index a315a39220168b4b38848f89905b56d660a7e3a1..48cc4912d312959d65815a8ff35205b812e95db5 100644 (file)
--- a/Messages/Progress.hs
+++ b/Messages/Progress.hs
@@ -25,6 +25,7 @@ import Messages.Internal
 import qualified System.Console.Regions as Regions
 import qualified System.Console.Concurrent as Console
 import Control.Monad.IO.Class (MonadIO)
+import Data.IORef
 
 {- Class of things from which a size can be gotten to display a progress
  - meter. -}
@@ -115,8 +116,16 @@ metered' st othermeter msize showoutput a = go st
                        a meter (combinemeter m)
                | otherwise = nometer
        go (MessageState { outputType = SerializedOutput h _ }) = do
-               liftIO $ outputSerialized h $ StartProgressMeter msize
-               meter <- liftIO $ mkMeter msize $ \_ _ _old new ->
+               liftIO $ outputSerialized h $ BeginProgressMeter msize
+               szv <- liftIO $ newIORef msize
+               meter <- liftIO $ mkMeter msize $ \_ msize' _old new -> do
+                       case msize' of
+                               Just sz | msize' /= msize -> do
+                                       psz <- readIORef szv
+                                       when (msize' /= psz) $ do
+                                               writeIORef szv msize'
+                                               outputSerialized h $ UpdateProgressMeterTotalSize sz
+                               _ -> noop
                        outputSerialized h $ UpdateProgressMeter $
                                meterBytesProcessed new
                m <- liftIO $ rateLimitMeterUpdate minratelimit meter $

diff --git a/Messages/Serialized.hs b/Messages/Serialized.hs
index 3dcc26edc0c043497b3d6a1a61661e74074e9713..cd62e104488bdba3bd5d19badddc3947b282d6b1 100644 (file)
--- a/Messages/Serialized.hs
+++ b/Messages/Serialized.hs
@@ -20,7 +20,7 @@ import Messages
 import Messages.Internal
 import Messages.Progress
 import qualified Messages.JSON as JSON
-import Utility.Metered (BytesProcessed)
+import Utility.Metered (BytesProcessed, setMeterTotalSize)
 
 import Control.Monad.IO.Class (MonadIO)
 
@@ -63,12 +63,12 @@ relaySerializedOutput getso sendsor meterreport runannex = go Nothing
                                        outputSerialized h $ JSONObject b
                                _ -> q
                        loop st
-               Left (StartProgressMeter sz) -> do
+               Left (BeginProgressMeter sz) -> do
                        ost <- runannex (Annex.getState Annex.output)
                        -- Display a progress meter while running, until
                        -- the meter ends or a final value is returned.
                        metered' ost Nothing sz (runannex showOutput) 
-                               (\_meter meterupdate -> loop (Just meterupdate))
+                               (\meter meterupdate -> loop (Just (meter, meterupdate)))
                                >>= \case
                                        Right r -> return (Right r)
                                        -- Continue processing serialized
@@ -80,12 +80,18 @@ relaySerializedOutput getso sendsor meterreport runannex = go Nothing
                        return (Left st)
                Left (UpdateProgressMeter n) -> do
                        case st of
-                               Just meterupdate -> do
+                               Just (_, meterupdate) -> do
                                        meterreport (Just n)
                                        liftIO $ meterupdate n
                                Nothing -> noop
                        loop st
-               Left StartPrompt -> do
+               Left (UpdateProgressMeterTotalSize sz) -> do
+                       case st of
+                               Just (meter, _) -> liftIO $
+                                       setMeterTotalSize meter sz
+                               Nothing -> noop
+                       loop st
+               Left BeginPrompt -> do
                        prompter <- runannex mkPrompter
                        v <- prompter $ do
                                sendsor ReadyPrompt

diff --git a/Types/Messages.hs b/Types/Messages.hs
index d2493d4177260dfb0b6c18fd00542272597e9b96..ffb85ac3d0805e4eaeb7c99f99e4d578350ffbda 100644 (file)
--- a/Types/Messages.hs
+++ b/Types/Messages.hs
@@ -68,10 +68,11 @@ newMessageState = do
 data SerializedOutput
        = OutputMessage S.ByteString
        | OutputError String
-       | StartProgressMeter (Maybe TotalSize)
+       | BeginProgressMeter (Maybe TotalSize)
        | UpdateProgressMeter BytesProcessed
+       | UpdateProgressMeterTotalSize TotalSize
        | EndProgressMeter
-       | StartPrompt
+       | BeginPrompt
        | EndPrompt
        | JSONObject L.ByteString
        -- ^ This is always sent, it's up to the consumer to decide if it

diff --git a/Types/Transferrer.hs b/Types/Transferrer.hs
index afeda7c5ebaee8e76788eb453c4d1ab60bd11336..7dbcfb23be8cd7dac09c19a250b1dea3ac89e9c3 100644 (file)
--- a/Types/Transferrer.hs
+++ b/Types/Transferrer.hs
@@ -85,16 +85,18 @@ instance Proto.Sendable TransferResponse where
                ["om", Proto.serialize (encode_c (decodeBS m))]
        formatMessage (TransferOutput (OutputError e)) =
                ["oe", Proto.serialize (encode_c e)]
-       formatMessage (TransferOutput (StartProgressMeter (Just (TotalSize n)))) =
-               ["ops", Proto.serialize n]
-       formatMessage (TransferOutput (StartProgressMeter Nothing)) =
-               ["opsx"]
+       formatMessage (TransferOutput (BeginProgressMeter (Just (TotalSize n)))) =
+               ["opb", Proto.serialize n]
+       formatMessage (TransferOutput (BeginProgressMeter Nothing)) =
+               ["opbx"]
        formatMessage (TransferOutput (UpdateProgressMeter n)) =
                ["op", Proto.serialize n]
+       formatMessage (TransferOutput (UpdateProgressMeterTotalSize (TotalSize sz))) =
+               ["ops", Proto.serialize sz]
        formatMessage (TransferOutput EndProgressMeter) =
                ["ope"]
-       formatMessage (TransferOutput StartPrompt) =
-               ["oprs"]
+       formatMessage (TransferOutput BeginPrompt) =
+               ["oprb"]
        formatMessage (TransferOutput EndPrompt) =
                ["opre"]
        formatMessage (TransferOutput (JSONObject b)) =
@@ -109,16 +111,18 @@ instance Proto.Receivable TransferResponse where
                TransferOutput . OutputMessage . encodeBS . decode_c
        parseCommand "oe" = Proto.parse1 $
                TransferOutput . OutputError . decode_c
-       parseCommand "ops" = Proto.parse1 $
-               TransferOutput . StartProgressMeter . Just . TotalSize
-       parseCommand "opsx" = Proto.parse0 $
-               TransferOutput (StartProgressMeter Nothing)
+       parseCommand "opb" = Proto.parse1 $
+               TransferOutput . BeginProgressMeter . Just . TotalSize
+       parseCommand "opbx" = Proto.parse0 $
+               TransferOutput (BeginProgressMeter Nothing)
        parseCommand "op" = Proto.parse1 $
                TransferOutput . UpdateProgressMeter
+       parseCommand "ops" = Proto.parse1 $
+               TransferOutput . UpdateProgressMeterTotalSize . TotalSize
        parseCommand "ope" = Proto.parse0 $
                TransferOutput EndProgressMeter
-       parseCommand "oprs" = Proto.parse0 $
-               TransferOutput StartPrompt
+       parseCommand "oprb" = Proto.parse0 $
+               TransferOutput BeginPrompt
        parseCommand "opre" = Proto.parse0 $
                TransferOutput EndPrompt
        parseCommand "oj" = Proto.parse1 $

diff --git a/doc/todo/stalldetection_progress_bar_lacks_ETA.mdwn b/doc/todo/stalldetection_progress_bar_lacks_ETA.mdwn
index 566495613d5160fd5edfc3cc278854477fb49965..a40d7fe1cf1de39aa2f38201d04ae577394ab9aa 100644 (file)
--- a/doc/todo/stalldetection_progress_bar_lacks_ETA.mdwn
+++ b/doc/todo/stalldetection_progress_bar_lacks_ETA.mdwn
@@ -3,3 +3,5 @@ communicates results in a progress display w/o ETA sometimes.
 In particular, it seems to happen downloading from ssh, when the key does
 not have a size. Normally, the size is learned during download and used in
 the progress bar, but somehow this does not happen. --[[Joey]]
+
+> [[fixed|done]] --[[Joey]]