summaryrefslogtreecommitdiff
path: root/Assistant/XMPP.hs
blob: e7470502176f75cf413654a24fc9781c7e627920 (plain)
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
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
{- core xmpp support
 -
 - Copyright 2012-2013 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 Git.Sha (extractSha)
import Git

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 "dataenc" 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.
 - Also includes a status tag, which may be visible in XMPP clients. -}
gitAnnexPresence :: Element -> Presence
gitAnnexPresence = insertGitAnnexTag $ addStatusTag $ emptyPresence PresenceAvailable
  where
	addStatusTag p = p
		{ presencePayloads = status : presencePayloads p }
	status = Element "status" [] [statusMessage]
	statusMessage = NodeContent $ ContentText $ T.pack "git-annex"

{- 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 [] []

{- XMPP client to server ping -}
xmppPing :: JID -> IQ
xmppPing selfjid = (emptyIQ IQGet)
	{ iqID = Just "c2s1"
	, iqFrom = Just selfjid
	, iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing
	, iqPayload = Just $ Element xmppPingTagName [] []
	}

xmppPingTagName :: Name
xmppPingTagName = "{urn:xmpp}ping"

{- 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 u shas) =
		gitAnnexTag canPushAttr $ T.pack $ unwords $
			fromUUID u : map fromRef shas
	encode (PushRequest u) =
		gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
	encode (StartingPush u) =
		gitAnnexTag startingPushAttr $ T.pack $ fromUUID u
	encode (ReceivePackOutput n b) = 
		gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b
	encode (SendPackOutput n b) =
		gitAnnexTagContent sendPackAttr (val n) $ encodeTagContent b
	encode (ReceivePackDone code) =
		gitAnnexTag receivePackDoneAttr $ val $ encodeExitCode code
	val = T.pack . show

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 $ shasgen CanPush
		, pushdecoder $ gen PushRequest
		, pushdecoder $ gen StartingPush
		, pushdecoder $ seqgen ReceivePackOutput
		, pushdecoder $ seqgen SendPackOutput
		, pushdecoder $
			fmap (ReceivePackDone . decodeExitCode) . readish .
				T.unpack . tagValue
		]
	pushdecoder a m' i = Pushing
		<$> (formatJID <$> messageFrom m')
		<*> a i
	gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i)))
	seqgen c i = do
	  	packet <- decodeTagContent $ tagElement i
		let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
		return $ c seqnum packet
	shasgen c i = do
		let (u:shas) = words $ T.unpack $ tagValue i
		return $ c (toUUID u) (mapMaybe extractSha shas)

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"

shasAttr :: Name
shasAttr = "shas"