summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Assistant/Threads/XMPPClient.hs46
-rw-r--r--Assistant/Types/NetMessager.hs3
-rw-r--r--Assistant/XMPP.hs202
-rw-r--r--Assistant/XMPP/Buddies.hs2
-rw-r--r--doc/design/assistant/xmpp.mdwn18
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