switch to silent chat messages for XMPP pairing
Along the way, significantly cleaned up Assistant.XMPP, and made XMPP message decoding more efficient.
This commit is contained in:
Joey Hess
parent
a2c393b4ae
commit
db36b11e28
6 changed files with 136 additions and 167 deletions
|
|
@ -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
|
||||
|
||||
{- A presence with a git-annex tag in it. -}
|
||||
gitAnnexPresence :: Element -> Presence
|
||||
gitAnnexPresence = insertGitAnnexTag $ emptyPresence PresenceAvailable
|
||||
|
||||
{- 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 [] []
|
||||
|
||||
{- 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 . gitAnnexTag pushAttr . encodePushNotification
|
||||
|
||||
pushAttr :: Name
|
||||
pushAttr = Name (T.pack "push") Nothing Nothing
|
||||
|
||||
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
|
||||
encodePushNotification :: [UUID] -> Text
|
||||
encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
isPresenceQuery :: Presence -> Bool
|
||||
isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
|
||||
[] -> False
|
||||
((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
|
||||
queryAttr :: Name
|
||||
queryAttr = Name (T.pack "query") Nothing Nothing
|
||||
|
||||
{- 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
|
||||
{- 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
|
||||
|
||||
directed p = p
|
||||
{ presenceTo = Just $ baseJID tojid
|
||||
, presenceFrom = Just fromjid
|
||||
}
|
||||
pairAttr :: Name
|
||||
pairAttr = Name (T.pack "pair") Nothing Nothing
|
||||
|
||||
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
|
||||
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"]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue