diff options
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 46 | ||||
| -rw-r--r-- | Assistant/Types/NetMessager.hs | 3 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 202 | ||||
| -rw-r--r-- | Assistant/XMPP/Buddies.hs | 2 | ||||
| -rw-r--r-- | doc/design/assistant/xmpp.mdwn | 18 |
5 files changed, 121 insertions, 150 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 4f41fdb30..0836fa0f6 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -76,7 +76,7 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do - the client connects, so that stale info - is not retained. -} void $ liftIO ioemptybuddies - putStanza $ gitAnnexPresence gitAnnexSignature + putStanza gitAnnexSignature xmppThread $ receivenotifications selfjid forever $ do a <- liftIO $ iorelay selfjid @@ -90,13 +90,11 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do handle (PresenceMessage p) = void $ liftIO $ ioupdatebuddies p handle (GotNetMessage QueryPresence) = - putStanza $ gitAnnexPresence gitAnnexSignature + putStanza gitAnnexSignature handle (GotNetMessage (NotifyPush us)) = 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 @@ -119,22 +117,24 @@ decodeStanza selfjid s@(ReceivedPresence p) | presenceType p == PresenceError = [ProtocolError s] | presenceFrom p == Nothing = [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 - Nothing -> [PresenceMessage p] - Just pn -> impliedp $ GotNetMessage pn + | otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p) where - -- Things sent via presence imply a presence message, - -- along with their real meaning. + decode (attr, v) + | attr == pushAttr = impliedp $ GotNetMessage $ NotifyPush $ + decodePushNotification v + | attr == queryAttr = impliedp $ GotNetMessage QueryPresence + | otherwise = [Unknown s] + {- 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 decodeSelfPairingNotification iq of - Nothing -> [Unknown s] - Just pn -> [GotNetMessage pn] +decodeStanza _ s@(ReceivedMessage m) + | messageType m == MessageError = [ProtocolError s] + | otherwise = maybe [Unknown s] decode (getGitAnnexAttrValue m) + where + decode (attr, v) + | attr == pairAttr = + [maybe (Unknown s) GotNetMessage (decodePairingNotification v m)] + | otherwise = [Unknown s] decodeStanza _ s = [Unknown s] {- Waits for a NetMessager message to be sent, and relays it to XMPP. -} @@ -145,12 +145,10 @@ relayNetMessage selfjid = convert <$> waitNetMessage convert QueryPresence = putStanza $ presenceQuery convert (PairingNotification stage t u) = case parseJID t of Nothing -> noop - Just tojid -> mapM_ putStanza $ - encodePairingNotification stage u tojid selfjid - convert (SelfPairingNotification stage t u) = case parseJID t of - Nothing -> noop - Just tojid -> putStanza $ - encodeSelfPairingNotification stage u tojid selfjid + Just tojid + | tojid == selfjid -> noop + | otherwise -> putStanza $ + pairingNotification 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 3df1782f8..f84247d6c 100644 --- a/Assistant/Types/NetMessager.hs +++ b/Assistant/Types/NetMessager.hs @@ -23,9 +23,6 @@ data NetMessage -- notification about a stage in the pairing process, -- 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 e3013a92f..37cf00374 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -12,157 +12,133 @@ import Assistant.Types.NetMessager import Assistant.Pairing import Network.Protocol.XMPP +import Data.Text (Text) 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. +{- Name of the 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 +{- Creates a git-annex tag containing a particular attribute and value. -} +gitAnnexTag :: Name -> Text -> Element +gitAnnexTag attr val = Element gitAnnexTagName [(attr, [ContentText val])] [] + 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 [] [] +{- Things that a git-annex tag can inserted into. -} +class GitAnnexTaggable a where + insertGitAnnexTag :: a -> Element -> a -queryAttr :: Name -queryAttr = Name (T.pack "query") Nothing Nothing + extractGitAnnexTag :: a -> Maybe Element -pushAttr :: Name -pushAttr = Name (T.pack "push") Nothing Nothing + hasGitAnnexTag :: a -> Bool + hasGitAnnexTag = isJust . extractGitAnnexTag -pairAttr :: Name -pairAttr = Name (T.pack "pair") Nothing Nothing +instance GitAnnexTaggable Message where + insertGitAnnexTag m e = m { messagePayloads = e : messagePayloads m } + extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads -isAttr :: Name -> (Name, [Content]) -> Bool -isAttr attr (k, _) = k == attr +instance GitAnnexTaggable Presence where + -- always mark extended away + insertGitAnnexTag p e = p { presencePayloads = extendedAway : e : presencePayloads p } + extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads -getAttr :: Element -> Name -> Maybe T.Text -getAttr (Element _name attrs _nodes) name = - T.concat . map unpack . snd <$> headMaybe (filter (isAttr name) attrs) +{- Gets the attr and value from a git-annex tag. -} +getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, Text) +getGitAnnexAttrValue a = case extractGitAnnexTag a of + Just (Element _ [(attr, content)] []) -> Just $ + (attr, T.concat $ map unpack content) + _ -> Nothing where unpack (ContentText t) = t unpack (ContentEntity t) = t -uuidSep :: T.Text -uuidSep = T.pack "," +{- A presence with a git-annex tag in it. -} +gitAnnexPresence :: Element -> Presence +gitAnnexPresence = insertGitAnnexTag $ emptyPresence PresenceAvailable -{- 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 +{- 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 [] [] -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 +{- A message with a git-annex tag in it. -} +gitAnnexMessage :: Element -> Message +gitAnnexMessage = insertGitAnnexTag silentMessage +{- A notification that we've pushed to some repositories, listing their + - UUIDs. -} pushNotification :: [UUID] -> Presence -pushNotification = gitAnnexPresence . encodePushNotification +pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification + +pushAttr :: Name +pushAttr = Name (T.pack "push") Nothing Nothing + +uuidSep :: T.Text +uuidSep = T.pack "," + +encodePushNotification :: [UUID] -> Text +encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID) + +decodePushNotification :: Text -> [UUID] +decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep {- A request for other git-annex clients to send presence. -} presenceQuery :: Presence -presenceQuery = gitAnnexPresence $ Element gitAnnexTagName - [ (queryAttr, [ContentText T.empty]) ] - [] +presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty + +queryAttr :: Name +queryAttr = Name (T.pack "query") Nothing Nothing -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. -} +pairingNotification :: PairStage -> UUID -> JID -> JID -> Message +pairingNotification pairstage u tojid fromjid = + (gitAnnexMessage tag) + { messageTo = Just tojid + , messageFrom = Just fromjid + } + where + tag = gitAnnexTag pairAttr $ + encodePairingNotification pairstage u -{- 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. - -} -encodePairingNotification :: PairStage -> UUID -> JID -> JID -> [Presence] -encodePairingNotification 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 $ baseJID tojid - , presenceFrom = Just fromjid - } - - 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:_) -> 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 +pairAttr :: Name +pairAttr = Name (T.pack "pair") Nothing Nothing + +encodePairingNotification :: PairStage -> UUID -> Text +encodePairingNotification 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 +decodePairingNotification :: Text -> Message -> Maybe NetMessage +decodePairingNotification t msg = parse $ words $ T.unpack t where parse [stage, u] = PairingNotification <$> readish stage - <*> (formatJID <$> jid) + <*> (formatJID <$> messageFrom msg) <*> pure (toUUID u) parse _ = Nothing {- 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 = Name (T.pack "body") Nothing Nothing + , elementAttributes = [] + , elementNodes = [] + } + +{- Add to a presence to mark its client as extended away. -} +extendedAway :: Element +extendedAway = Element (Name (T.pack "show") Nothing Nothing) [] + [NodeContent $ ContentText $ T.pack "xa"] diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs index 77e506ee9..fe5d8c6a9 100644 --- a/Assistant/XMPP/Buddies.hs +++ b/Assistant/XMPP/Buddies.hs @@ -67,7 +67,7 @@ applyPresence p b = fromMaybe b $! go <$> presenceFrom p , buddyPresent = removefrom $ buddyPresent b , buddyAssistants = removefrom $ buddyAssistants b } - | isGitAnnexPresence p = b + | hasGitAnnexTag p = b { buddyAssistants = addto $ buddyAssistants b , buddyAway = removefrom $ buddyAway b } | presenceType p == PresenceAvailable = b diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index 570084dda..284e56fa3 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/doc/design/assistant/xmpp.mdwn @@ -29,26 +29,26 @@ who share a repository, that is stored in the [[cloud]]. ## protocol To avoid relying on XMPP extensions, git-annex communicates -using presence messages. These always mark it as extended away. -To this, it adds its own tag as [extended content](http://xmpp.org/rfcs/rfc6121.html#presence-extended). +using presence messages (which always mark it as extended away), +and chat messages (with empty body tags, so clients don't display them). + +To these messages, it adds its own tag as +[extended content](http://xmpp.org/rfcs/rfc6121.html#presence-extended). The xml namespace is "git-annex" (not an URL because I hate wasting bandwidth). -To indicate it's pushed changes to a git repo with a given UUID, a client uses: +To indicate it's pushed changes to a git repo with a given UUID, +a message that should be sent to all buddies and other clients using the account +(no explicit pairing needed), a client uses a broadcast presence message with: <git-annex xmlns='git-annex' push="uuid[,uuid...]" /> 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, a directed presence message is sent, also using the git-annex tag: +For pairing, a chat message is sent, also using the git-annex tag: <git-annex xmlns='git-annex' pairing="PairReq uuid" /> -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 |