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
160
161
162
|
{- 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
import qualified Data.ByteString.Lazy as L
-- 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 (decodeBS (encode_c isUtf8Byte m))]
formatMessage (TransferOutput (OutputError e)) =
["oe", Proto.serialize (decodeBS (encode_c isUtf8Byte (encodeBS 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 (decodeBS (encode_c isUtf8Byte (L.toStrict b)))]
formatMessage (TransferResult True) =
["t"]
formatMessage (TransferResult False) =
["f"]
instance Proto.Receivable TransferResponse where
parseCommand "om" = Proto.parse1 $
TransferOutput . OutputMessage . decode_c . encodeBS
parseCommand "oe" = Proto.parse1 $
TransferOutput . OutputError . decodeBS . decode_c . encodeBS
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 . L.fromStrict . decode_c . encodeBS
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':decodeBS (encode_c is_space_or_unicode (encodeBS r))
where
is_space_or_unicode c = isUtf8Byte c || isSpace (chr (fromIntegral c))
deserialize ('u':u) = Just (TransferRemoteUUID (toUUID u))
deserialize ('r':r) = Just (TransferRemoteName (decodeBS (decode_c (encodeBS 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))) =
fromRawFilePath (encode_c isUtf8Byte (fromOsPath f))
serialize (TransferAssociatedFile (AssociatedFile Nothing)) = ""
deserialize "" = Just $ TransferAssociatedFile $
AssociatedFile Nothing
deserialize s = Just $ TransferAssociatedFile $
AssociatedFile $ Just $ toOsPath $ decode_c $ toRawFilePath s
|
