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
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -81,26 +81,24 @@ getStartPairR = noPairing "local or jabber"
|
|||
getStartXMPPPairR :: BuddyKey -> Handler RepHtml
|
||||
#ifdef WITH_XMPP
|
||||
getStartXMPPPairR bid = do
|
||||
creds <- runAnnex Nothing getXMPPCreds
|
||||
let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
|
||||
buddy <- liftAssistant $ getBuddy bid <<~ buddyList
|
||||
case S.toList . buddyAssistants <$> buddy of
|
||||
-- A buddy could have logged out, or the XMPP client restarted;
|
||||
-- so handle unforseen by going back.
|
||||
Nothing -> redirect StartPairR
|
||||
(Just []) -> redirect StartPairR
|
||||
(Just clients@((Client exemplar):_)) -> do
|
||||
let samejid = baseJID ourjid == baseJID exemplar
|
||||
let account = formatJID $ baseJID exemplar
|
||||
liftAssistant $ do
|
||||
u <- liftAnnex getUUID
|
||||
if samejid
|
||||
then forM_ clients $ \(Client c) ->
|
||||
sendNetMessage $ SelfPairingNotification PairReq (formatJID c) u
|
||||
else sendNetMessage $ PairingNotification PairReq account u
|
||||
pairPage $ do
|
||||
let name = buddyName exemplar
|
||||
$(widgetFile "configurators/pairing/xmpp/inprogress")
|
||||
go $ S.toList . buddyAssistants <$> buddy
|
||||
where
|
||||
go (Just (clients@((Client exemplar):_))) = do
|
||||
creds <- runAnnex Nothing getXMPPCreds
|
||||
let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
|
||||
let samejid = baseJID ourjid == baseJID exemplar
|
||||
let account = formatJID $ baseJID exemplar
|
||||
liftAssistant $ do
|
||||
u <- liftAnnex getUUID
|
||||
forM_ clients $ \(Client c) -> sendNetMessage $
|
||||
PairingNotification PairReq (formatJID c) u
|
||||
pairPage $ do
|
||||
let name = buddyName exemplar
|
||||
$(widgetFile "configurators/pairing/xmpp/inprogress")
|
||||
-- A buddy could have logged out, or the XMPP client restarted,
|
||||
-- and there be no clients to message; handle unforseen by going back.
|
||||
go _ = redirect StartPairR
|
||||
#else
|
||||
getStartXMPPPairR _ = noXMPPPairing
|
||||
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue