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
pontarius · Sep 17, 2014 · 5c8040b · 5c8040b
1 parent 5bdd200
commit 5c8040b
Show file tree

Hide file tree

Showing 5 changed files with 27 additions and 13 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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)