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..92ea47e 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -87,6 +87,15 @@ data SessionConfiguration = SessionConfiguration , enableRoster :: Bool -- | Track incomming presence stancas. , enablePresenceTracking :: Bool + -- | 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 @@ -101,6 +110,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.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 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..5e4cd1b 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 (Jid -> 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 fr 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) 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