new protocol for transferkeys, with message serialization

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
This commit is contained in:
Joey Hess 2020-12-03 16:21:20 -04:00
parent 82dbc4387c
commit cad147cbbf
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
10 changed files with 98 additions and 96 deletions

View file

@ -1,15 +1,14 @@
{- git-annex command, used internally by assistant
{- git-annex command
-
- Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Command.TransferKeys where
import Command
import qualified Annex
import Annex.Content
import Logs.Location
import Annex.Transfer
@ -18,8 +17,19 @@ import Utility.SimpleProtocol (dupIoHandles)
import Git.Types (RemoteName)
import qualified Database.Keys
import Annex.BranchState
import Types.Messages
import Types.Key
import Messages.Internal
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
import Text.Read (readMaybe)
data TransferRequest = TransferRequest Direction (Either UUID RemoteName) KeyData AssociatedFile
deriving (Show, Read)
data TransferResponse
= TransferOutput SerializedOutput
| TransferResult Bool
deriving (Show, Read)
cmd :: Command
cmd = command "transferkeys" SectionPlumbing "transfers keys"
@ -32,10 +42,12 @@ start :: CommandStart
start = do
enableInteractiveBranchAccess
(readh, writeh) <- liftIO dupIoHandles
Annex.setOutput $ SerializedOutput $
hPutStrLn writeh . show . TransferOutput
runRequests readh writeh runner
stop
where
runner (TransferRequest direction remote key file)
runner (TransferRequest direction _ keydata file) remote
| direction == Upload = notifyTransfer direction file $
upload (Remote.uuid remote) key file stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case
@ -58,82 +70,58 @@ start = do
-- not old cached data.
Database.Keys.closeDb
return r
where
key = mkKey (const keydata)
runRequests
:: Handle
-> Handle
-> (TransferRequest -> Annex Bool)
-> (TransferRequest -> Remote -> Annex Bool)
-> Annex ()
runRequests readh writeh a = do
liftIO $ hSetBuffering readh NoBuffering
go =<< readrequests
runRequests readh writeh a = go Nothing Nothing
where
go (d:rn:k:f:rest) = do
case (deserialize d, deserialize rn, deserialize k, deserialize f) of
(Just direction, Just remotename, Just key, Just file) -> do
mremote <- Remote.byName' remotename
go lastremoteoruuid lastremote = unlessM (liftIO $ hIsEOF readh) $ do
l <- liftIO $ hGetLine readh
case readMaybe l of
Just tr@(TransferRequest _ remoteoruuid _ _) -> do
-- Often the same remote will be used
-- repeatedly, so cache the last one to
-- avoid looking up repeatedly.
mremote <- if lastremoteoruuid == Just remoteoruuid
then pure lastremote
else eitherToMaybe <$> Remote.byName'
(either fromUUID id remoteoruuid)
case mremote of
Left _ -> sendresult False
Right remote -> sendresult =<< a
(TransferRequest direction remote key file)
_ -> sendresult False
go rest
go [] = noop
go [""] = noop
go v = error $ "transferkeys protocol error: " ++ show v
Just remote -> do
sendresult =<< a tr remote
go (Just remoteoruuid) mremote
Nothing -> protocolError l
Nothing -> protocolError l
readrequests = liftIO $ split fieldSep <$> hGetContents readh
sendresult b = liftIO $ do
hPutStrLn writeh $ serialize b
hPutStrLn writeh $ show $ TransferResult b
hFlush writeh
sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
sendRequest t tinfo h = do
hPutStr h $ intercalate fieldSep
[ serialize (transferDirection t)
, maybe (serialize ((fromUUID (transferUUID t)) :: String))
(serialize . Remote.name)
(transferRemote tinfo)
, serialize (transferKey t)
, serialize (associatedFile tinfo)
, "" -- adds a trailing null
]
hFlush h
sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest
(transferDirection t)
(maybe (Left (transferUUID t)) (Right . Remote.name) (transferRemote tinfo))
(keyData (transferKey t))
(associatedFile tinfo)
readResponse :: Handle -> IO Bool
readResponse h = fromMaybe False . deserialize <$> hGetLine h
-- | Read a response from this command.
--
-- Each TransferOutput line that is read before the final TransferResult
-- will be output.
readResponse :: Handle -> Annex Bool
readResponse h = do
l <- liftIO $ hGetLine h
case readMaybe l of
Just (TransferOutput so) -> do
emitSerializedOutput so
readResponse h
Just (TransferResult r) -> return r
Nothing -> protocolError l
fieldSep :: String
fieldSep = "\0"
class TCSerialized a where
serialize :: a -> String
deserialize :: String -> Maybe a
instance TCSerialized Bool where
serialize True = "1"
serialize False = "0"
deserialize "1" = Just True
deserialize "0" = Just False
deserialize _ = Nothing
instance TCSerialized Direction where
serialize Upload = "u"
serialize Download = "d"
deserialize "u" = Just Upload
deserialize "d" = Just Download
deserialize _ = Nothing
instance TCSerialized AssociatedFile where
serialize (AssociatedFile (Just f)) = fromRawFilePath f
serialize (AssociatedFile Nothing) = ""
deserialize "" = Just (AssociatedFile Nothing)
deserialize f = Just (AssociatedFile (Just (toRawFilePath f)))
instance TCSerialized RemoteName where
serialize n = n
deserialize n = Just n
instance TCSerialized Key where
serialize = serializeKey
deserialize = deserializeKey
protocolError :: String -> a
protocolError l = error $ "transferkeys protocol error: " ++ show l