custom protocol for transferrer

Rather than using Read/Show, which would force me to preserve data types
into the future.

I considered just deriving json and sending that, but I don't much like
deriving json with data types that have named constructors (like Key
does) because again it locks in data type details.

So instead, used SimpleProtocol, with a fairly complex and unreadable
protocol. But it is as efficient as the p2p protocol at least, and as
future proof.

(Writing my own custom json instances would have worked but I thought
of it too late and don't want to do all the work twice. The only real
benefit might be that aeson could be faster.)

Note that, when a new protocol request type is added later, git-annex
trying to use it will cause the git-annex transferrer to display a
protocol error message. That seems ok; it would only happen if a new
git-annex found an old version of itself in PATH or the program
file. So it's unlikely, and all it can do anyway is display an error.
(The error message could perhaps be improved..)

This commit was sponsored by Jack Hill on Patreon.
This commit is contained in:
Joey Hess 2020-12-09 15:44:00 -04:00
parent 447d798987
commit 04c12aa6df
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
6 changed files with 194 additions and 53 deletions

View file

@ -8,17 +8,140 @@
module Types.Transferrer where
import Annex.Common
import Types.Transfer
import Types.Messages
import Git.Types (RemoteName)
import qualified Utility.SimpleProtocol as Proto
import Utility.Format
data TransferRequest = TransferRequest TransferRequestLevel Direction (Either UUID RemoteName) KeyData AssociatedFile
deriving (Show, Read)
import Data.Char
data TransferRequestLevel = AnnexLevel | AssistantLevel
deriving (Show, Read)
-- Sent to start a transfer.
data TransferRequest
= UploadRequest TransferRemote Key TransferAssociatedFile
| DownloadRequest TransferRemote Key TransferAssociatedFile
| AssistantUploadRequest TransferRemote Key TransferAssociatedFile
| AssistantDownloadRequest TransferRemote Key TransferAssociatedFile
deriving (Show)
transferRequestRemote :: TransferRequest -> TransferRemote
transferRequestRemote (UploadRequest r _ _) = r
transferRequestRemote (DownloadRequest r _ _) = r
transferRequestRemote (AssistantUploadRequest r _ _) = r
transferRequestRemote (AssistantDownloadRequest r _ _) = r
data TransferRemote
= TransferRemoteUUID UUID
| TransferRemoteName RemoteName
deriving (Show, Eq)
newtype TransferAssociatedFile = TransferAssociatedFile AssociatedFile
deriving (Show)
data TransferResponse
= TransferOutput SerializedOutput
-- ^ any number may be sent before TransferResult
| TransferResult Bool
deriving (Show, Read)
deriving (Show)
data TransferSerializedOutputResponse = TransferSerializedOutputResponse SerializedOutputResponse
deriving (Show)
instance Proto.Sendable TransferRequest where
formatMessage (UploadRequest r kd af) =
[ "u"
, Proto.serialize r
, Proto.serialize kd
, Proto.serialize af
]
formatMessage (DownloadRequest r kd af) =
[ "d"
, Proto.serialize r
, Proto.serialize kd
, Proto.serialize af
]
formatMessage (AssistantUploadRequest r kd af) =
[ "au"
, Proto.serialize r
, Proto.serialize kd
, Proto.serialize af
]
formatMessage (AssistantDownloadRequest r kd af) =
[ "ad"
, Proto.serialize r
, Proto.serialize kd
, Proto.serialize af
]
instance Proto.Receivable TransferRequest where
parseCommand "u" = Proto.parse3 UploadRequest
parseCommand "d" = Proto.parse3 DownloadRequest
parseCommand "au" = Proto.parse3 AssistantUploadRequest
parseCommand "ad" = Proto.parse3 AssistantDownloadRequest
parseCommand _ = Proto.parseFail
instance Proto.Sendable TransferResponse where
formatMessage (TransferOutput (OutputMessage m)) =
["om", Proto.serialize (encode_c (decodeBS m))]
formatMessage (TransferOutput (OutputError e)) =
["oe", Proto.serialize (encode_c e)]
formatMessage (TransferOutput (StartProgressMeter (Just n))) =
["ops", Proto.serialize n]
formatMessage (TransferOutput (StartProgressMeter Nothing)) =
["opsx"]
formatMessage (TransferOutput (UpdateProgressMeter n)) =
["op", Proto.serialize n]
formatMessage (TransferOutput EndProgressMeter) =
["ope"]
formatMessage (TransferOutput StartPrompt) =
["oprs"]
formatMessage (TransferOutput EndPrompt) =
["opre"]
formatMessage (TransferOutput (JSONObject b)) =
["oj", Proto.serialize (encode_c (decodeBL b))]
formatMessage (TransferResult True) =
["t"]
formatMessage (TransferResult False) =
["f"]
instance Proto.Receivable TransferResponse where
parseCommand "om" = Proto.parse1 (TransferOutput . OutputMessage . encodeBS . decode_c)
parseCommand "oe" = Proto.parse1 (TransferOutput . OutputError . decode_c)
parseCommand "ops" = Proto.parse1 (TransferOutput . StartProgressMeter . Just)
parseCommand "opsx" = Proto.parse0 (TransferOutput (StartProgressMeter Nothing))
parseCommand "op" = Proto.parse1 (TransferOutput . UpdateProgressMeter)
parseCommand "ope" = Proto.parse0 (TransferOutput EndProgressMeter)
parseCommand "oprs" = Proto.parse0 (TransferOutput StartPrompt)
parseCommand "opre" = Proto.parse0 (TransferOutput EndPrompt)
parseCommand "oj" = Proto.parse1 (TransferOutput . JSONObject . encodeBL . decode_c)
parseCommand "t" = Proto.parse0 (TransferResult True)
parseCommand "f" = Proto.parse0 (TransferResult False)
parseCommand _ = Proto.parseFail
instance Proto.Sendable TransferSerializedOutputResponse where
formatMessage (TransferSerializedOutputResponse ReadyPrompt) = ["opr"]
instance Proto.Receivable TransferSerializedOutputResponse where
parseCommand "opr" = Proto.parse0 (TransferSerializedOutputResponse ReadyPrompt)
parseCommand _ = Proto.parseFail
instance Proto.Serializable TransferRemote where
serialize (TransferRemoteUUID u) = 'u':fromUUID u
-- A remote name could contain whitespace or newlines, which needs
-- to be escaped for the protocol. Use C-style encoding.
serialize (TransferRemoteName r) = 'r':encode_c' isSpace r
deserialize ('u':u) = Just (TransferRemoteUUID (toUUID u))
deserialize ('r':r) = Just (TransferRemoteName (decode_c r))
deserialize _ = Nothing
instance Proto.Serializable TransferAssociatedFile where
-- Comes last, so whitespace is ok. But, in case the filename
-- contains eg a newline, escape it. Use C-style encoding.
serialize (TransferAssociatedFile (AssociatedFile (Just f))) =
encode_c (fromRawFilePath f)
serialize (TransferAssociatedFile (AssociatedFile Nothing)) = ""
deserialize "" = Just $ TransferAssociatedFile $
AssociatedFile Nothing
deserialize s = Just $ TransferAssociatedFile $
AssociatedFile $ Just $ toRawFilePath $ decode_c s