From 5c8040b80cbf86d9d31d6962790574cd70877d7d Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 17 Sep 2014 15:52:36 +0200 Subject: [PATCH 1/4] add onPresenceChange method onPresenceChange is called when the presence status of a peer changes, i.e. it goes online or offline or the IM presence is changed --- source/Network/Xmpp/Concurrent.hs | 2 +- source/Network/Xmpp/Concurrent/Types.hs | 2 ++ source/Network/Xmpp/IM/Presence.hs | 4 +-- source/Network/Xmpp/IM/PresenceTracker.hs | 30 +++++++++++++------ .../Network/Xmpp/IM/PresenceTracker/Types.hs | 2 +- 5 files changed, 27 insertions(+), 13 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 52855fb..ccfa84a 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -175,7 +175,7 @@ newSession stream config realm mbSasl = runErrorT $ do then [handleRoster boundJid ros out] else [] let presenceH = if (enablePresenceTracking config) - then [handlePresence peers out] + then [handlePresence (onPresenceChange config) peers out] else [] (sStanza, ps) <- initPlugins out $ plugins config let stanzaHandler = runHandlers $ List.concat diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 91460ff..4085150 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -87,6 +87,7 @@ data SessionConfiguration = SessionConfiguration , enableRoster :: Bool -- | Track incomming presence stancas. , enablePresenceTracking :: Bool + , onPresenceChange :: Maybe (PeerStatus -> PeerStatus -> IO ()) } instance Default SessionConfiguration where @@ -101,6 +102,7 @@ instance Default SessionConfiguration where , plugins = [] , enableRoster = True , enablePresenceTracking = True + , onPresenceChange = Nothing } -- | Handlers to be run when the Xmpp session ends and when the Xmpp connection is diff --git a/source/Network/Xmpp/IM/Presence.hs b/source/Network/Xmpp/IM/Presence.hs index 42adfeb..6e13135 100644 --- a/source/Network/Xmpp/IM/Presence.hs +++ b/source/Network/Xmpp/IM/Presence.hs @@ -13,12 +13,12 @@ import Network.Xmpp.Types data ShowStatus = StatusAway | StatusChat | StatusDnd - | StatusXa deriving (Read, Show) + | StatusXa deriving (Read, Show, Eq) data IMPresence = IMP { showStatus :: Maybe ShowStatus , status :: Maybe Text , priority :: Maybe Int - } deriving Show + } deriving (Show, Eq) imPresence :: IMPresence imPresence = IMP { showStatus = Nothing diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs index 82c331d..c4ff0ad 100644 --- a/source/Network/Xmpp/IM/PresenceTracker.hs +++ b/source/Network/Xmpp/IM/PresenceTracker.hs @@ -2,8 +2,10 @@ module Network.Xmpp.IM.PresenceTracker where import Control.Applicative +import Control.Concurrent import Control.Concurrent.STM -import Data.Foldable +import Control.Monad +import qualified Data.Foldable as Foldable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe @@ -57,21 +59,31 @@ peerMapPeerAvailable :: Jid -> Peers -> Bool peerMapPeerAvailable j | isFull j = not . nullOf (peerStatusL j . _PeerAvailable) | otherwise = not . nullOf (_peers . at j . _Just) -handlePresence :: TVar Peers -> StanzaHandler -handlePresence peers _ st _ = do +handlePresence :: Maybe (PeerStatus -> PeerStatus -> IO ()) + -> TVar Peers + -> StanzaHandler +handlePresence onChange peers _ st _ = do let mbPr = do pr <- st ^? _Presence -- Only act on presence stanzas fr <- pr ^? from . _Just . _isFull -- Only act on full JIDs return (pr, fr) - forM_ mbPr $ \(pr, fr) -> + Foldable.forM_ mbPr $ \(pr, fr) -> case presenceType pr of - Available -> atomically . modifyTVar peers - $ set (peerStatusL fr) - (PeerAvailable (getIMPresence pr)) - Unavailable -> atomically . modifyTVar peers - $ set (peerStatusL fr) PeerUnavailable + Available -> setStatus fr (PeerAvailable (getIMPresence pr)) + Unavailable -> setStatus fr PeerUnavailable _ -> return () return [(st, [])] + where + setStatus fr newStatus = do + os <- atomically $ do + ps <- readTVar peers + let oldStatus = ps ^. peerStatusL fr + writeTVar peers $ ps & set (peerStatusL fr) newStatus + return oldStatus + unless (os == newStatus) $ case onChange of + Nothing -> return () + Just oc -> void . forkIO $ oc os newStatus + return () -- | Check whether a given jid is available isPeerAvailable :: Jid -> Session -> STM Bool diff --git a/source/Network/Xmpp/IM/PresenceTracker/Types.hs b/source/Network/Xmpp/IM/PresenceTracker/Types.hs index 334c066..5e02800 100644 --- a/source/Network/Xmpp/IM/PresenceTracker/Types.hs +++ b/source/Network/Xmpp/IM/PresenceTracker/Types.hs @@ -17,4 +17,4 @@ newtype Peers = Peers { unPeers :: Map Jid (Map Jid (Maybe IMPresence))} data PeerStatus = PeerAvailable (Maybe IMPresence) | PeerUnavailable - deriving (Show) + deriving (Show, Eq) From f99bcf0fd196d0ea075be76b4fce3d9713d193f3 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Wed, 17 Sep 2014 15:57:49 +0200 Subject: [PATCH 2/4] pass JID to onPresenceChange callback --- source/Network/Xmpp/Concurrent/Types.hs | 10 +++++++++- source/Network/Xmpp/IM/PresenceTracker.hs | 4 ++-- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 4085150..92ea47e 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -87,7 +87,15 @@ data SessionConfiguration = SessionConfiguration , enableRoster :: Bool -- | Track incomming presence stancas. , enablePresenceTracking :: Bool - , onPresenceChange :: Maybe (PeerStatus -> PeerStatus -> IO ()) + -- | Callback that is invoked when the presence status of a peer changes, + -- i.e. it comes online, goes offline or its IM presence changes. The + -- arguments are the (full) JID of the peer, the old state and the new + -- state. The function is called in a new thread to avoid blocking + -- handling stanzas + , onPresenceChange :: Maybe ( Jid + -> PeerStatus + -> PeerStatus + -> IO ()) } instance Default SessionConfiguration where diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs index c4ff0ad..5e4cd1b 100644 --- a/source/Network/Xmpp/IM/PresenceTracker.hs +++ b/source/Network/Xmpp/IM/PresenceTracker.hs @@ -59,7 +59,7 @@ peerMapPeerAvailable :: Jid -> Peers -> Bool peerMapPeerAvailable j | isFull j = not . nullOf (peerStatusL j . _PeerAvailable) | otherwise = not . nullOf (_peers . at j . _Just) -handlePresence :: Maybe (PeerStatus -> PeerStatus -> IO ()) +handlePresence :: Maybe (Jid -> PeerStatus -> PeerStatus -> IO ()) -> TVar Peers -> StanzaHandler handlePresence onChange peers _ st _ = do @@ -82,7 +82,7 @@ handlePresence onChange peers _ st _ = do return oldStatus unless (os == newStatus) $ case onChange of Nothing -> return () - Just oc -> void . forkIO $ oc os newStatus + Just oc -> void . forkIO $ oc fr os newStatus return () -- | Check whether a given jid is available From 069b9efb4ae81a8845c4f41a4a81de721968b90f Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 18 Sep 2014 00:29:27 +0200 Subject: [PATCH 3/4] add lens for onPresenceChange --- source/Network/Xmpp/Lens.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/source/Network/Xmpp/Lens.hs b/source/Network/Xmpp/Lens.hs index 8e8d35a..b7339b8 100644 --- a/source/Network/Xmpp/Lens.hs +++ b/source/Network/Xmpp/Lens.hs @@ -94,6 +94,7 @@ module Network.Xmpp.Lens , sessionStanzaIDsL , ensableRosterL , pluginsL + , onPresenceChangeL -- ** IM -- *** Roster -- **** 'Roster' @@ -152,6 +153,7 @@ import Network.TLS as TLS import Network.Xmpp.Concurrent.Types import Network.Xmpp.IM.Message import Network.Xmpp.IM.Presence +import Network.Xmpp.IM.PresenceTracker.Types import Network.Xmpp.IM.Roster.Types import Network.Xmpp.Types @@ -538,6 +540,11 @@ pluginsL :: Lens SessionConfiguration [Plugin] pluginsL inj sc@SessionConfiguration{plugins = x} = (\x' -> sc{plugins = x'}) <$> inj x +onPresenceChangeL :: Lens SessionConfiguration (Maybe ( Jid -> PeerStatus + -> PeerStatus -> IO ())) +onPresenceChangeL inj sc@SessionConfiguration{onPresenceChange = x} + = (\x' -> sc{onPresenceChange = x'}) <$> inj x + -- | Access clientServerIdentification inside tlsParams inside streamConfiguration tlsServerIdentificationL :: Lens SessionConfiguration (String, BS.ByteString) tlsServerIdentificationL = streamConfigurationL From faf7e6451f8e7cbfe4cc867ce20b0f099050da5c Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 18 Sep 2014 00:48:39 +0200 Subject: [PATCH 4/4] export PeerStatus --- source/Network/Xmpp/IM.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs index b1455ea..bc0cf07 100644 --- a/source/Network/Xmpp/IM.hs +++ b/source/Network/Xmpp/IM.hs @@ -26,6 +26,7 @@ module Network.Xmpp.IM , rosterAdd , rosterRemove -- * presenceTracker + , PeerStatus(..) , isPeerAvailable , getEntityStatus , getAvailablePeers @@ -37,3 +38,4 @@ import Network.Xmpp.IM.Presence import Network.Xmpp.IM.Roster import Network.Xmpp.IM.Roster.Types import Network.Xmpp.IM.PresenceTracker +import Network.Xmpp.IM.PresenceTracker.Types