1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
{- protocol used by "git-annex transferrer"
-
- Copyright 2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Types.Transferrer where
import Annex.Common
import Types.Messages
import Git.Types (RemoteName)
import qualified Utility.SimpleProtocol as Proto
import Utility.Format
import Utility.Metered (TotalSize(..))
import Data.Char
-- 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)
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 BeginProgressMeter) =
["opb"]
formatMessage (TransferOutput (UpdateProgressMeterTotalSize (TotalSize sz))) =
["ops", Proto.serialize sz]
formatMessage (TransferOutput (UpdateProgressMeter n)) =
["op", Proto.serialize n]
formatMessage (TransferOutput EndProgressMeter) =
["ope"]
formatMessage (TransferOutput BeginPrompt) =
["oprb"]
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 "opb" = Proto.parse0 $
TransferOutput BeginProgressMeter
parseCommand "ops" = Proto.parse1 $
TransferOutput . UpdateProgressMeterTotalSize . TotalSize
parseCommand "op" = Proto.parse1 $
TransferOutput . UpdateProgressMeter
parseCommand "ope" = Proto.parse0 $
TransferOutput EndProgressMeter
parseCommand "oprb" = Proto.parse0 $
TransferOutput BeginPrompt
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
|
