diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 17 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 9 |
2 files changed, 21 insertions, 5 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index ee1db0666..12ec9d550 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -137,7 +137,13 @@ decodeStanza selfjid s@(ReceivedMessage m) | otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)] decodeStanza _ s = [Unknown s] -{- Waits for a NetMessager message to be sent, and relays it to XMPP. -} +{- Waits for a NetMessager message to be sent, and relays it to XMPP. + - + - Chat messages must be directed to specific clients, not a base + - account JID, due to git-annex clients using a negative presence priority. + - PairingNotification messages are always directed at specific + - clients, but Pushing messages are sometimes not, and need to be exploded. + -} relayNetMessage :: JID -> Assistant (XMPP ()) relayNetMessage selfjid = convert =<< waitNetMessage where @@ -146,8 +152,13 @@ relayNetMessage selfjid = convert =<< waitNetMessage convert (PairingNotification stage c u) = withclient c $ \tojid -> do changeBuddyPairing tojid True return $ putStanza $ pairingNotification stage u tojid selfjid - convert (Pushing c pushstage) = withclient c $ \tojid -> - return $ putStanza $ pushMessage pushstage tojid selfjid + convert (Pushing c pushstage) = withclient c $ \tojid -> do + if tojid == baseJID tojid + then do + bud <- getBuddy (genBuddyKey tojid) <<~ buddyList + return $ forM_ (maybe [] (S.toList . buddyAssistants) bud) $ \(Client jid) -> + putStanza $ pushMessage pushstage jid selfjid + else return $ putStanza $ pushMessage pushstage tojid selfjid withclient c a = case parseJID c of Nothing -> return noop diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index e473b5305..2c0004403 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -52,8 +52,9 @@ instance GitAnnexTaggable Message where extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads instance GitAnnexTaggable Presence where - -- always mark extended away - insertGitAnnexTag p elt = p { presencePayloads = extendedAway : elt : presencePayloads p } + -- always mark extended away and set presence priority to negative + insertGitAnnexTag p elt = p + { presencePayloads = extendedAway : negativePriority : elt : presencePayloads p } extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads data GitAnnexTagInfo = GitAnnexTagInfo @@ -208,6 +209,10 @@ silentMessage = (emptyMessage MessageChat) extendedAway :: Element extendedAway = Element "show" [] [NodeContent $ ContentText "xa"] +{- Add to a presence to give it a negative priority. -} +negativePriority :: Element +negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"] + pushAttr :: Name pushAttr = "push" |