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
|
{- core xmpp support
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.XMPP where
import Assistant.Common
import Assistant.Types.NetMessager
import Assistant.Pairing
import Network.Protocol.XMPP
import qualified Data.Text as T
import Data.XML.Types
{- A presence with a git-annex tag in it. -}
gitAnnexPresence :: Element -> Presence
gitAnnexPresence tag = (emptyPresence PresenceAvailable)
{ presencePayloads = [extendedAway, tag] }
where
extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
[NodeContent $ ContentText $ T.pack "xa"]
{- Does a presence contain a git-annex tag? -}
isGitAnnexPresence :: Presence -> Bool
isGitAnnexPresence p = any isGitAnnexTag (presencePayloads p)
{- Name of a git-annex tag, in our own XML namespace.
- (Not using a namespace URL to avoid unnecessary bloat.) -}
gitAnnexTagName :: Name
gitAnnexTagName = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing
isGitAnnexTag :: Element -> Bool
isGitAnnexTag t = elementName t == gitAnnexTagName
{- A git-annex tag, to let other clients know we're a git-annex client too. -}
gitAnnexSignature :: Element
gitAnnexSignature = Element gitAnnexTagName [] []
queryAttr :: Name
queryAttr = Name (T.pack "query") Nothing Nothing
pushAttr :: Name
pushAttr = Name (T.pack "push") Nothing Nothing
pairAttr :: Name
pairAttr = Name (T.pack "pair") Nothing Nothing
isAttr :: Name -> (Name, [Content]) -> Bool
isAttr attr (k, _) = k == attr
getAttr :: Element -> Name -> Maybe T.Text
getAttr (Element _name attrs _nodes) name =
T.concat . map unpack . snd <$> headMaybe (filter (isAttr name) attrs)
where
unpack (ContentText t) = t
unpack (ContentEntity t) = t
uuidSep :: T.Text
uuidSep = T.pack ","
{- git-annex tag with one push attribute per UUID pushed to. -}
encodePushNotification :: [UUID] -> Element
encodePushNotification us = Element gitAnnexTagName
[(pushAttr, [ContentText pushvalue])] []
where
pushvalue = T.intercalate uuidSep $
map (T.pack . fromUUID) us
decodePushNotification :: Element -> Maybe [UUID]
decodePushNotification (Element name attrs _nodes)
| name == gitAnnexTagName && not (null us) = Just us
| otherwise = Nothing
where
us = map (toUUID . T.unpack) $
concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $
filter ispush attrs
ispush (k, _) = k == pushAttr
fromContent (ContentText t) = t
fromContent (ContentEntity t) = t
pushNotification :: [UUID] -> Presence
pushNotification = gitAnnexPresence . encodePushNotification
{- A request for other git-annex clients to send presence. -}
presenceQuery :: Presence
presenceQuery = gitAnnexPresence $ Element gitAnnexTagName
[ (queryAttr, [ContentText T.empty]) ]
[]
isPresenceQuery :: Presence -> Bool
isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
[] -> False
((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
{- A notification about a stage of pairing, sent as directed presence
- to all clients of a jid.
-
- For PairReq, the directed presence is followed by a second presence
- without the pair notification. This is done because XMPP servers
- resend the last directed presence periodically, which can make
- the pair request alert be re-displayed annoyingly. For PairAck and
- PairDone, that resending is a desirable feature, as it helps ensure
- clients see them.
-}
pairingNotification :: PairStage -> UUID -> JID -> JID -> [Presence]
pairingNotification pairstage u tojid fromjid
| pairstage == PairReq = [send, clear]
| otherwise = [send]
where
send = directed $ gitAnnexPresence $ Element gitAnnexTagName
[(pairAttr, [ContentText content])] []
clear = directed $ gitAnnexPresence gitAnnexSignature
directed p = p
{ presenceTo = Just $ JID (jidNode tojid) (jidDomain tojid) Nothing
, presenceFrom = Just fromjid
}
content = T.unwords
[ T.pack $ show pairstage
, T.pack $ fromUUID u
]
decodePairingNotification :: Presence -> Maybe NetMessage
decodePairingNotification p = case filter isGitAnnexTag (presencePayloads p) of
[] -> Nothing
(elt:_) -> parse =<< words . T.unpack <$> getAttr elt pairAttr
where
parse [stage, u] =
PairingNotification
<$> readish stage
<*> (formatJID <$> presenceFrom p)
<*> pure (toUUID u)
parse _ = Nothing
|
