cad147cbbf
Necessarily threw out the old protocol, so if an old git-annex assistant
is running, and starts a transferkeys from the new git-annex, it would
fail. But, that seems unlikely; the assistant starts up transferkeys
processes and then keeps them running. Still, may need to test that
scenario.
The new protocol is simple read/show and looks like this:
TransferRequest Download (Right "origin") (Key {keyName = "f8f8766a836fb6120abf4d5328ce8761404e437529e997aaa0363bdd4fecd7bb", keyVariety = SHA2Key (HashSize 256) (HasExt True), keySize = Just 30, keyMtime = Nothing, keyChunkSize = Nothing, keyChunkNum = Nothing}) (AssociatedFile (Just "foo"))
TransferOutput (ProgressMeter (Just 30) (MeterState {meterBytesProcessed = BytesProcessed 0, meterTimeStamp = 1.6070268727892535e9}) (MeterState {meterBytesProcessed = BytesProcessed 30, meterTimeStamp = 1.6070268728043e9}))
TransferOutput (OutputMessage "(checksum...) ")
TransferResult True
Granted, this is not optimally fast, but it seems good enough, and is
probably nearly as fast as the old protocol anyhow.
emitSerializedOutput for ProgressMeter is not yet implemented. It needs
to somehow start or update a progress meter. There may need to be a new
message that allocates a progress meter, and then have ProgressMeter
update it.
This commit was sponsored by Ethan Aubin
113 lines
3.5 KiB
Haskell
113 lines
3.5 KiB
Haskell
{- git-annex output messages, including concurrent output to display regions
|
|
-
|
|
- Copyright 2010-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Messages.Internal where
|
|
|
|
import Common
|
|
import Annex
|
|
import Types.Messages
|
|
import Messages.Concurrent
|
|
import qualified Messages.JSON as JSON
|
|
import Messages.JSON (JSONBuilder)
|
|
|
|
import qualified Data.ByteString as S
|
|
|
|
withMessageState :: (MessageState -> Annex a) -> Annex a
|
|
withMessageState a = Annex.getState Annex.output >>= a
|
|
|
|
outputMessage :: JSONBuilder -> S.ByteString -> Annex ()
|
|
outputMessage = outputMessage' bufferJSON
|
|
|
|
outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> S.ByteString -> Annex ()
|
|
outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case outputType s of
|
|
NormalOutput
|
|
| concurrentOutputEnabled s -> concurrentMessage s False (decodeBS msg) q
|
|
| otherwise -> liftIO $ flushed $ S.putStr msg
|
|
JSONOutput _ -> void $ jsonoutputter jsonbuilder s
|
|
QuietOutput -> q
|
|
SerializedOutput h -> do
|
|
liftIO $ outputSerialized h $ OutputMessage msg
|
|
void $ jsonoutputter jsonbuilder s
|
|
|
|
-- Buffer changes to JSON until end is reached and then emit it.
|
|
bufferJSON :: JSONBuilder -> MessageState -> Annex Bool
|
|
bufferJSON jsonbuilder s = case outputType s of
|
|
JSONOutput _ -> go (flushed . JSON.emit)
|
|
SerializedOutput h -> go (outputSerialized h . JSONObject . JSON.encode)
|
|
_ -> return False
|
|
where
|
|
go emitter
|
|
| endjson = do
|
|
Annex.changeState $ \st ->
|
|
st { Annex.output = s { jsonBuffer = Nothing } }
|
|
maybe noop (liftIO . emitter . JSON.finalize) json
|
|
return True
|
|
| otherwise = do
|
|
Annex.changeState $ \st ->
|
|
st { Annex.output = s { jsonBuffer = json } }
|
|
return True
|
|
|
|
(json, endjson) = case jsonbuilder i of
|
|
Nothing -> (jsonBuffer s, False)
|
|
(Just (j, e)) -> (Just j, e)
|
|
|
|
i = case jsonBuffer s of
|
|
Nothing -> Nothing
|
|
Just b -> Just (b, False)
|
|
|
|
-- Immediately output JSON.
|
|
outputJSON :: JSONBuilder -> MessageState -> Annex Bool
|
|
outputJSON jsonbuilder s = case outputType s of
|
|
JSONOutput _ -> go (flushed . JSON.emit)
|
|
SerializedOutput h -> go (outputSerialized h . JSONObject . JSON.encode)
|
|
_ -> return False
|
|
where
|
|
go emitter = do
|
|
maybe noop (liftIO . emitter)
|
|
(fst <$> jsonbuilder Nothing)
|
|
return True
|
|
|
|
outputError :: String -> Annex ()
|
|
outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of
|
|
(JSONOutput jsonoptions, Just jb) | jsonErrorMessages jsonoptions ->
|
|
let jb' = Just (JSON.addErrorMessage (lines msg) jb)
|
|
in Annex.changeState $ \st ->
|
|
st { Annex.output = s { jsonBuffer = jb' } }
|
|
(SerializedOutput h, _) ->
|
|
liftIO $ outputSerialized h $ OutputError msg
|
|
_
|
|
| concurrentOutputEnabled s -> concurrentMessage s True msg go
|
|
| otherwise -> go
|
|
where
|
|
go = liftIO $ do
|
|
hFlush stdout
|
|
hPutStr stderr msg
|
|
hFlush stderr
|
|
|
|
q :: Monad m => m ()
|
|
q = noop
|
|
|
|
flushed :: IO () -> IO ()
|
|
flushed a = a >> hFlush stdout
|
|
|
|
outputSerialized :: (SerializedOutput -> IO ()) -> SerializedOutput -> IO ()
|
|
outputSerialized = id
|
|
|
|
emitSerializedOutput :: SerializedOutput -> Annex ()
|
|
emitSerializedOutput (OutputMessage msg) =
|
|
outputMessage' nojsonoutputter nojsonbuilder msg
|
|
where
|
|
nojsonoutputter _ _ = return False
|
|
nojsonbuilder = id
|
|
emitSerializedOutput (OutputError msg) = outputError msg
|
|
emitSerializedOutput (ProgressMeter sz old new) = undefined -- TODO
|
|
emitSerializedOutput (JSONObject b) =
|
|
withMessageState $ \s -> case outputType s of
|
|
JSONOutput _ -> liftIO $ flushed $ JSON.emit' b
|
|
SerializedOutput h -> liftIO $
|
|
outputSerialized h $ JSONObject b
|
|
_ -> q
|