switch to directed presence for pair requests
Testing between Google Talk and prosody, the directed IQ messages were not received. Google Talk probably only relays them between clients using the same account. I first tried even more directed presence, with each client JID being sent a separate presence, but that didn't work on Google Talk, particularly it was ignored when one client sent it to another client using the same account. So, presence directed at the user@host of the client to pair with. Tested working between Google Talk and prosody (in both directions), as well as between two clients with the same account on Google Talk, and two clients with the same account on prosody. Only problem with this form of directed presence is that if I also use it for git pushes, more clients than are interested in a push's data will receive it. So I may need some better approach, or a hybrid between directed IQ and directed presence.
This commit is contained in:
parent
5108d4b364
commit
17e84a8096
4 changed files with 44 additions and 40 deletions
|
@ -119,18 +119,15 @@ decodeStanza fulljid s@(ReceivedPresence p)
|
|||
| presenceFrom p == Just fulljid = [Ignorable p]
|
||||
| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
|
||||
| isPresenceQuery p = impliedp $ GotNetMessage QueryPresence
|
||||
| otherwise = [PresenceMessage p]
|
||||
| otherwise = case decodePairingNotification p of
|
||||
Nothing -> [PresenceMessage p]
|
||||
Just pn -> impliedp $ GotNetMessage pn
|
||||
where
|
||||
-- Some things are sent via presence, so imply a presence message,
|
||||
-- along with their real value.
|
||||
-- Things sent via presence imply a presence message,
|
||||
-- along with their real meaning.
|
||||
impliedp v = [PresenceMessage p, v]
|
||||
pushed = concat $ catMaybes $ map decodePushNotification $
|
||||
presencePayloads p
|
||||
decodeStanza _ s@(ReceivedIQ iq)
|
||||
| iqType iq == IQError = [ProtocolError s]
|
||||
| otherwise = case decodePairingNotification iq of
|
||||
Nothing -> [Unknown s]
|
||||
Just pn -> [GotNetMessage pn]
|
||||
decodeStanza _ s = [Unknown s]
|
||||
|
||||
{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
|
||||
|
@ -141,9 +138,8 @@ relayNetMessage fulljid = convert <$> waitNetMessage
|
|||
convert QueryPresence = putStanza $ presenceQuery
|
||||
convert (PairingNotification stage t u) = case parseJID t of
|
||||
Nothing -> noop
|
||||
Just tojid -> do
|
||||
liftIO $ print $ pairingNotification stage u tojid fulljid
|
||||
putStanza $ pairingNotification stage u tojid fulljid
|
||||
Just tojid -> putStanza $
|
||||
pairingNotification stage u tojid fulljid
|
||||
|
||||
{- Runs the client, handing restart events. -}
|
||||
restartableClient :: IO () -> Assistant ()
|
||||
|
|
|
@ -89,13 +89,11 @@ getStartXMPPPairR bid = do
|
|||
(Just []) -> redirect StartPairR
|
||||
(Just clients@((Client exemplar):_)) -> do
|
||||
let samejid = basejid ourjid == basejid exemplar
|
||||
liftAssistant $ forM_ clients $ \(Client jid) ->
|
||||
unless (jid == ourjid) $ do
|
||||
u <- liftAnnex getUUID
|
||||
sendNetMessage $ PairingNotification
|
||||
PairReq (formatJID jid) u
|
||||
pairPage $ do
|
||||
let account = formatJID $ basejid exemplar
|
||||
liftAssistant $ do
|
||||
u <- liftAnnex getUUID
|
||||
sendNetMessage $ PairingNotification PairReq account u
|
||||
pairPage $ do
|
||||
let name = buddyName exemplar
|
||||
$(widgetFile "configurators/pairing/xmpp/inprogress")
|
||||
where
|
||||
|
|
|
@ -45,9 +45,19 @@ 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 ","
|
||||
|
||||
|
@ -85,29 +95,29 @@ 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 an XMPP IQ.
|
||||
- The pairing info is sent using its id attribute; it also has a git-annex
|
||||
- tag to identify it as from us. -}
|
||||
pairingNotification :: PairStage -> UUID -> JID -> JID -> IQ
|
||||
pairingNotification pairstage u tojid fromjid = (emptyIQ IQGet)
|
||||
{ iqTo = Just tojid
|
||||
, iqFrom = Just fromjid
|
||||
, iqID = Just $ T.unwords $ map T.pack
|
||||
[ show pairstage
|
||||
, fromUUID u
|
||||
]
|
||||
, iqPayload = Just gitAnnexSignature
|
||||
{- A notification about a stage of pairing, sent as directed presence
|
||||
- to all clients of a jid. -}
|
||||
pairingNotification :: PairStage -> UUID -> JID -> JID -> Presence
|
||||
pairingNotification pairstage u tojid fromjid = (gitAnnexPresence elt)
|
||||
{ presenceTo = Just $ JID (jidNode tojid) (jidDomain tojid) Nothing
|
||||
, presenceFrom = Just fromjid
|
||||
}
|
||||
|
||||
decodePairingNotification :: IQ -> Maybe NetMessage
|
||||
decodePairingNotification iq@(IQ { iqPayload = Just elt })
|
||||
| isGitAnnexTag elt = parseid =<< words . T.unpack <$> iqID iq
|
||||
| otherwise = Nothing
|
||||
where
|
||||
parseid [stage, u] =
|
||||
elt = Element gitAnnexTagName
|
||||
[(pairAttr, [ContentText content])] []
|
||||
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 <$> iqFrom iq)
|
||||
<*> (formatJID <$> presenceFrom p)
|
||||
<*> pure (toUUID u)
|
||||
parseid _ = Nothing
|
||||
decodePairingNotification _ = Nothing
|
||||
parse _ = Nothing
|
||||
|
|
|
@ -40,9 +40,9 @@ To indicate it's pushed changes to a git repo with a given UUID, a client uses:
|
|||
Multiple UUIDs can be listed when multiple clients were pushed. If the
|
||||
git repo does not have a git-annex UUID, an empty string is used.
|
||||
|
||||
For pairing over XMPP, git-annex uses IQ messages, also containing a
|
||||
git-annex tag. The id attribute of the iq tag contains the pairing
|
||||
information.
|
||||
For pairing, a directed presence message is sent, also using the git-annex tag:
|
||||
|
||||
<git-annex xmlns='git-annex' pairing="PairReq uuid" />
|
||||
|
||||
### security
|
||||
|
||||
|
|
Loading…
Reference in a new issue