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:
parent
82dbc4387c
commit
cad147cbbf
10 changed files with 98 additions and 96 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue