18e00500ce
Added annex.bwlimit and remote.name.annex-bwlimit config that works for git remotes and many but not all special remotes. This nearly works, at least for a git remote on the same disk. With it set to 100kb/1s, the meter displays an actual bandwidth of 128 kb/s, with occasional spikes to 160 kb/s. So it needs to delay just a bit longer... I'm unsure why. However, at the beginning a lot of data flows before it determines the right bandwidth limit. A granularity of less than 1s would probably improve that. And, I don't know yet if it makes sense to have it be 100ks/1s rather than 100kb/s. Is there a situation where the user would want a larger granularity? Does granulatity need to be configurable at all? I only used that format for the config really in order to reuse an existing parser. This can't support for external special remotes, or for ones that themselves shell out to an external command. (Well, it could, but it would involve pausing and resuming the child process tree, which seems very hard to implement and very strange besides.) There could also be some built-in special remotes that it still doesn't work for, due to them not having a progress meter whose displays blocks the bandwidth using thread. But I don't think there are actually any that run a separate thread for downloads than the thread that displays the progress meter. Sponsored-by: Graham Spencer on Patreon
109 lines
3.1 KiB
Haskell
109 lines
3.1 KiB
Haskell
{- serialized output
|
|
-
|
|
- Copyright 2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module Messages.Serialized (
|
|
relaySerializedOutput,
|
|
outputSerialized,
|
|
waitOutputSerializedResponse,
|
|
) where
|
|
|
|
import Common
|
|
import Annex
|
|
import Types.Messages
|
|
import Messages
|
|
import Messages.Internal
|
|
import Messages.Progress
|
|
import qualified Messages.JSON as JSON
|
|
import Utility.Metered (BytesProcessed, setMeterTotalSize)
|
|
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
|
|
-- | Relay serialized output from a child process to the console.
|
|
relaySerializedOutput
|
|
:: (Monad m, MonadIO m, MonadMask m)
|
|
=> m (Either SerializedOutput r)
|
|
-- ^ Get next serialized output, or final value to return.
|
|
-> (SerializedOutputResponse -> m ())
|
|
-- ^ Send response to child process.
|
|
-> (Maybe BytesProcessed -> m ())
|
|
-- ^ When a progress meter is running, it is updated with
|
|
-- progress meter values sent by the process.
|
|
-- When a progress meter is stopped, Nothing is sent.
|
|
-> (forall a. Annex a -> m a)
|
|
-- ^ Run an annex action in the monad. Will not be used with
|
|
-- actions that block for a long time.
|
|
-> m r
|
|
relaySerializedOutput getso sendsor meterreport runannex = go Nothing
|
|
where
|
|
go st = loop st >>= \case
|
|
Right r -> return r
|
|
Left st' -> go st'
|
|
|
|
loop st = getso >>= \case
|
|
Right r -> return (Right r)
|
|
Left (OutputMessage msg) -> do
|
|
runannex $ outputMessage'
|
|
(\_ _ -> return False)
|
|
id
|
|
msg
|
|
loop st
|
|
Left (OutputError msg) -> do
|
|
runannex $ outputError msg
|
|
loop st
|
|
Left (JSONObject b) -> do
|
|
runannex $ withMessageState $ \s -> case outputType s of
|
|
JSONOutput _ -> liftIO $ flushed $ JSON.emit' b
|
|
SerializedOutput h _ -> liftIO $
|
|
outputSerialized h $ JSONObject b
|
|
_ -> q
|
|
loop st
|
|
Left BeginProgressMeter -> do
|
|
ost <- runannex (Annex.getState Annex.output)
|
|
let setclear = const noop
|
|
-- Display a progress meter while running, until
|
|
-- the meter ends or a final value is returned.
|
|
metered' ost setclear Nothing Nothing Nothing (runannex showOutput)
|
|
(\meter meterupdate -> loop (Just (meter, meterupdate)))
|
|
>>= \case
|
|
Right r -> return (Right r)
|
|
-- Continue processing serialized
|
|
-- output after the progress meter
|
|
-- is done.
|
|
Left _st' -> loop Nothing
|
|
Left EndProgressMeter -> do
|
|
meterreport Nothing
|
|
return (Left st)
|
|
Left (UpdateProgressMeter n) -> do
|
|
case st of
|
|
Just (_, meterupdate) -> do
|
|
meterreport (Just n)
|
|
liftIO $ meterupdate n
|
|
Nothing -> noop
|
|
loop st
|
|
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
|
|
-- Continue processing serialized output
|
|
-- until EndPrompt or a final value is
|
|
-- returned. (EndPrompt is all that
|
|
-- ought to be sent while in a prompt
|
|
-- really, but if something else did get
|
|
-- sent, display it just in case.)
|
|
loop st
|
|
case v of
|
|
Right r -> return (Right r)
|
|
Left st' -> loop st'
|
|
Left EndPrompt -> return (Left st)
|