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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
|
{- core xmpp support
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.XMPP where
import Assistant.Common
import Assistant.Types.NetMessager
import Assistant.Pairing
import Network.Protocol.XMPP hiding (Node)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.XML.Types
import qualified Codec.Binary.Base64 as B64
{- Name of the git-annex tag, in our own XML namespace.
- (Not using a namespace URL to avoid unnecessary bloat.) -}
gitAnnexTagName :: Name
gitAnnexTagName = "{git-annex}git-annex"
{- Creates a git-annex tag containing a particular attribute and value. -}
gitAnnexTag :: Name -> Text -> Element
gitAnnexTag attr val = gitAnnexTagContent attr val []
{- Also with some content. -}
gitAnnexTagContent :: Name -> Text -> [Node] -> Element
gitAnnexTagContent attr val = Element gitAnnexTagName [(attr, [ContentText val])]
isGitAnnexTag :: Element -> Bool
isGitAnnexTag t = elementName t == gitAnnexTagName
{- Things that a git-annex tag can inserted into. -}
class GitAnnexTaggable a where
insertGitAnnexTag :: a -> Element -> a
extractGitAnnexTag :: a -> Maybe Element
hasGitAnnexTag :: a -> Bool
hasGitAnnexTag = isJust . extractGitAnnexTag
instance GitAnnexTaggable Message where
insertGitAnnexTag m elt = m { messagePayloads = elt : messagePayloads m }
extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads
instance GitAnnexTaggable Presence where
-- always mark extended away and set presence priority to negative
insertGitAnnexTag p elt = p
{ presencePayloads = extendedAway : negativePriority : elt : presencePayloads p }
extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
data GitAnnexTagInfo = GitAnnexTagInfo
{ tagAttr :: Name
, tagValue :: Text
, tagElement :: Element
}
type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo
gitAnnexTagInfo v = case extractGitAnnexTag v of
{- Each git-annex tag has a single attribute. -}
Just (tag@(Element _ [(attr, _)] _)) -> GitAnnexTagInfo
<$> pure attr
<*> attributeText attr tag
<*> pure tag
_ -> Nothing
{- A presence with a git-annex tag in it. -}
gitAnnexPresence :: Element -> Presence
gitAnnexPresence = insertGitAnnexTag $ emptyPresence PresenceAvailable
{- A presence with an empty git-annex tag in it, used for letting other
- clients know we're around and are a git-annex client. -}
gitAnnexSignature :: Presence
gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] []
{- A message with a git-annex tag in it. -}
gitAnnexMessage :: Element -> JID -> JID -> Message
gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)
{ messageTo = Just tojid
, messageFrom = Just fromjid
}
{- A notification that we've pushed to some repositories, listing their
- UUIDs. -}
pushNotification :: [UUID] -> Presence
pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification
encodePushNotification :: [UUID] -> Text
encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
decodePushNotification :: Text -> [UUID]
decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep
uuidSep :: Text
uuidSep = ","
{- A request for other git-annex clients to send presence. -}
presenceQuery :: Presence
presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty
{- A notification about a stage of pairing. -}
pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
pairingNotification pairstage u = gitAnnexMessage $
gitAnnexTag pairAttr $ encodePairingNotification pairstage u
encodePairingNotification :: PairStage -> UUID -> Text
encodePairingNotification pairstage u = T.unwords $ map T.pack
[ show pairstage
, fromUUID u
]
decodePairingNotification :: Decoder
decodePairingNotification m = parse . words . T.unpack . tagValue
where
parse [stage, u] = PairingNotification
<$> readish stage
<*> (formatJID <$> messageFrom m)
<*> pure (toUUID u)
parse _ = Nothing
pushMessage :: PushStage -> JID -> JID -> Message
pushMessage = gitAnnexMessage . encode
where
encode CanPush = gitAnnexTag canPushAttr T.empty
encode PushRequest = gitAnnexTag pushRequestAttr T.empty
encode StartingPush = gitAnnexTag startingPushAttr T.empty
encode (ReceivePackOutput b) =
gitAnnexTagContent receivePackAttr T.empty $ encodeTagContent b
encode (SendPackOutput b) =
gitAnnexTagContent sendPackAttr T.empty $ encodeTagContent b
encode (ReceivePackDone code) =
gitAnnexTag receivePackDoneAttr $
T.pack $ show $ encodeExitCode code
decodeMessage :: Message -> Maybe NetMessage
decodeMessage m = decode =<< gitAnnexTagInfo m
where
decode i = M.lookup (tagAttr i) decoders >>= rundecoder i
rundecoder i d = d m i
decoders = M.fromList $ zip
[ pairAttr
, canPushAttr
, pushRequestAttr
, startingPushAttr
, receivePackAttr
, sendPackAttr
, receivePackDoneAttr
]
[ decodePairingNotification
, pushdecoder $ const $ Just CanPush
, pushdecoder $ const $ Just PushRequest
, pushdecoder $ const $ Just StartingPush
, pushdecoder $
fmap ReceivePackOutput . decodeTagContent . tagElement
, pushdecoder $
fmap SendPackOutput . decodeTagContent . tagElement
, pushdecoder $
fmap (ReceivePackDone . decodeExitCode) . readish .
T.unpack . tagValue
]
pushdecoder a m' i = Pushing
<$> (formatJID <$> messageFrom m')
<*> a i
decodeExitCode :: Int -> ExitCode
decodeExitCode 0 = ExitSuccess
decodeExitCode n = ExitFailure n
encodeExitCode :: ExitCode -> Int
encodeExitCode ExitSuccess = 0
encodeExitCode (ExitFailure n) = n
{- Base 64 encoding a ByteString to use as the content of a tag. -}
encodeTagContent :: ByteString -> [Node]
encodeTagContent b = [NodeContent $ ContentText $ T.pack $ B64.encode $ B.unpack b]
decodeTagContent :: Element -> Maybe ByteString
decodeTagContent elt = B.pack <$> B64.decode s
where
s = T.unpack $ T.concat $ elementText elt
{- The JID without the client part. -}
baseJID :: JID -> JID
baseJID j = JID (jidNode j) (jidDomain j) Nothing
{- An XMPP chat message with an empty body. This should not be displayed
- by clients, but can be used for communications. -}
silentMessage :: Message
silentMessage = (emptyMessage MessageChat)
{ messagePayloads = [ emptybody ] }
where
emptybody = Element
{ elementName = "body"
, elementAttributes = []
, elementNodes = []
}
{- Add to a presence to mark its client as extended away. -}
extendedAway :: Element
extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
{- Add to a presence to give it a negative priority. -}
negativePriority :: Element
negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"]
pushAttr :: Name
pushAttr = "push"
queryAttr :: Name
queryAttr = "query"
pairAttr :: Name
pairAttr = "pair"
canPushAttr :: Name
canPushAttr = "canpush"
pushRequestAttr :: Name
pushRequestAttr = "pushrequest"
startingPushAttr :: Name
startingPushAttr = "startingpush"
receivePackAttr :: Name
receivePackAttr = "rp"
sendPackAttr :: Name
sendPackAttr = "sp"
receivePackDoneAttr :: Name
receivePackDoneAttr = "rpdone"
|
