From fc6d4cdfcc7c83163d12059a8f784442ce5c4ca9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 3 Nov 2012 22:52:41 -0400 Subject: workaround for Google Talk's insane handling of self-directed presence Maybe the spec allows it, but broadcasting self-directed presence info to all buddies is just insane. I had to bring back the IQ messages for self-pairing, while still using directed presence for other pairing. Ugly. --- Assistant/Threads/XMPPClient.hs | 37 ++++++++++++++++---------- Assistant/Types/NetMessager.hs | 5 +++- Assistant/XMPP.hs | 57 +++++++++++++++++++++++++++++++---------- Assistant/XMPP/Buddies.hs | 2 +- doc/design/assistant/xmpp.mdwn | 5 ++++ 5 files changed, 78 insertions(+), 28 deletions(-) diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 63040001b..4f41fdb30 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -58,32 +58,32 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do - if it keeps failing, back off to wait 5 minutes before - trying it again. -} loop c starttime = do - runclient c + e <- runclient c now <- getCurrentTime if diffUTCTime now starttime > 300 then do - void $ iodebug ["connection lost; reconnecting"] + void $ iodebug ["connection lost; reconnecting", show e] loop c now else do - void $ iodebug ["connection failed; will retry"] + void $ iodebug ["connection failed; will retry", show e] threadDelaySeconds (Seconds 300) loop c =<< getCurrentTime runclient c = void $ connectXMPP c $ \jid -> do - fulljid <- bindJID jid - debug' ["connected", show fulljid] + selfjid <- bindJID jid + debug' ["connected", show selfjid] {- The buddy list starts empty each time - the client connects, so that stale info - is not retained. -} void $ liftIO ioemptybuddies putStanza $ gitAnnexPresence gitAnnexSignature - xmppThread $ receivenotifications fulljid + xmppThread $ receivenotifications selfjid forever $ do - a <- liftIO $ iorelay fulljid + a <- liftIO $ iorelay selfjid a - receivenotifications fulljid = forever $ do - l <- decodeStanza fulljid <$> getStanza + receivenotifications selfjid = forever $ do + l <- decodeStanza selfjid <$> getStanza debug' ["received:", show l] mapM_ handle l @@ -95,6 +95,8 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do void $ liftIO $ iopull us handle (GotNetMessage (PairingNotification stage t u)) = maybe noop (handlePairing stage u) (parseJID t) + handle (GotNetMessage (SelfPairingNotification stage t u)) = + error "TODO" handle (Ignorable _) = noop handle (Unknown _) = noop handle (ProtocolError _) = noop @@ -113,10 +115,10 @@ data XMPPEvent {- Decodes an XMPP stanza into one or more events. -} decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent] -decodeStanza fulljid s@(ReceivedPresence p) +decodeStanza selfjid s@(ReceivedPresence p) | presenceType p == PresenceError = [ProtocolError s] | presenceFrom p == Nothing = [Ignorable p] - | presenceFrom p == Just fulljid = [Ignorable p] + | presenceFrom p == Just selfjid = [Ignorable p] | not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed | isPresenceQuery p = impliedp $ GotNetMessage QueryPresence | otherwise = case decodePairingNotification p of @@ -128,18 +130,27 @@ decodeStanza fulljid s@(ReceivedPresence p) impliedp v = [PresenceMessage p, v] pushed = concat $ catMaybes $ map decodePushNotification $ presencePayloads p +decodeStanza _ s@(ReceivedIQ iq) + | iqType iq == IQError = [ProtocolError s] + | otherwise = case decodeSelfPairingNotification 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. -} relayNetMessage :: JID -> Assistant (XMPP ()) -relayNetMessage fulljid = convert <$> waitNetMessage +relayNetMessage selfjid = convert <$> waitNetMessage where convert (NotifyPush us) = putStanza $ pushNotification us convert QueryPresence = putStanza $ presenceQuery convert (PairingNotification stage t u) = case parseJID t of Nothing -> noop Just tojid -> mapM_ putStanza $ - pairingNotification stage u tojid fulljid + encodePairingNotification stage u tojid selfjid + convert (SelfPairingNotification stage t u) = case parseJID t of + Nothing -> noop + Just tojid -> putStanza $ + encodeSelfPairingNotification stage u tojid selfjid {- Runs the client, handing restart events. -} restartableClient :: IO () -> Assistant () diff --git a/Assistant/Types/NetMessager.hs b/Assistant/Types/NetMessager.hs index 79342b666..3df1782f8 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -21,8 +21,11 @@ data NetMessage -- requests other clients to inform us of their presence | QueryPresence -- notification about a stage in the pairing process, - -- involving another client identified by the Text, and a UUID. + -- involving a client identified by the Text, and a UUID. | PairingNotification PairStage Text UUID + -- notification about a stage in the pairing process with + -- other clients using the same account. + | SelfPairingNotification PairStage Text UUID deriving (Show) data NetMessagerControl = NetMessagerControl diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index d18087976..e3013a92f 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -105,8 +105,8 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of - 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 +encodePairingNotification :: PairStage -> UUID -> JID -> JID -> [Presence] +encodePairingNotification pairstage u tojid fromjid | pairstage == PairReq = [send, clear] | otherwise = [send] where @@ -115,23 +115,54 @@ pairingNotification pairstage u tojid fromjid clear = directed $ gitAnnexPresence gitAnnexSignature directed p = p - { presenceTo = Just $ JID (jidNode tojid) (jidDomain tojid) Nothing + { presenceTo = Just $ baseJID tojid , presenceFrom = Just fromjid } - content = T.unwords - [ T.pack $ show pairstage - , T.pack $ fromUUID u - ] + content = mkPairingContent pairstage u + +{- A notification about a stage of pairing. Sent to self as an XMPP IQ. + - Directed presence is not used for self-messaging presence because + - some XMPP clients seem very confused by it. Google Talk has been + - observed leaking self-directed presence to other friends, seeming + - to think it sets the visible presence. + - + - The pairing info is sent using its id attribute; it also has a git-annex + - tag to identify it as from us. -} +encodeSelfPairingNotification :: PairStage -> UUID -> JID -> JID -> IQ +encodeSelfPairingNotification pairstage u tojid fromjid = (emptyIQ IQGet) + { iqTo = Just tojid + , iqFrom = Just fromjid + , iqID = Just $ mkPairingContent pairstage u + , iqPayload = Just gitAnnexSignature + } decodePairingNotification :: Presence -> Maybe NetMessage decodePairingNotification p = case filter isGitAnnexTag (presencePayloads p) of [] -> Nothing - (elt:_) -> parse =<< words . T.unpack <$> getAttr elt pairAttr + (elt:_) -> parsePairingContent (presenceFrom p) =<< getAttr elt pairAttr + +decodeSelfPairingNotification :: IQ -> Maybe NetMessage +decodeSelfPairingNotification iq@(IQ { iqPayload = Just elt }) + | isGitAnnexTag elt = parsePairingContent (iqFrom iq) =<< iqID iq + | otherwise = Nothing +decodeSelfPairingNotification _ = Nothing + +mkPairingContent :: PairStage -> UUID -> T.Text +mkPairingContent pairstage u = T.unwords $ map T.pack + [ show pairstage + , fromUUID u + ] + +parsePairingContent :: Maybe JID -> T.Text -> Maybe NetMessage +parsePairingContent jid t = parse $ words $ T.unpack t where - parse [stage, u] = - PairingNotification - <$> readish stage - <*> (formatJID <$> presenceFrom p) - <*> pure (toUUID u) + parse [stage, u] = PairingNotification + <$> readish stage + <*> (formatJID <$> jid) + <*> pure (toUUID u) parse _ = Nothing + +{- The JID without the client part. -} +baseJID :: JID -> JID +baseJID j = JID (jidNode j) (jidDomain j) Nothing diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs index 087a34879..77e506ee9 100644 --- a/Assistant/XMPP/Buddies.hs +++ b/Assistant/XMPP/Buddies.hs @@ -18,7 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T genKey :: JID -> BuddyKey -genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing +genKey j = BuddyKey $ formatJID $ baseJID j buddyName :: JID -> Text buddyName j = maybe (T.pack "") strNode (jidNode j) diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index 9410b3e7c..570084dda 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -44,6 +44,11 @@ For pairing, a directed presence message is sent, also using the git-annex tag: +For pairing with other clients using the same XMPP account, git-annex uses +IQ messages, also containing a git-annex tag. The id attribute of the iq +tag contains the pairing information. This is done because self-directed +presence is not handled correctly by Google Talk. (Or is ill-specified.) + ### security Data git-annex sends over XMPP will be visible to the XMPP -- cgit v1.2.3