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.

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

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 $

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

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

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 $

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