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.
This commit is contained in:
parent
94b323a8e8
commit
095cdc7e83
6 changed files with 44 additions and 22 deletions
|
@ -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 $
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue