Merge branch 'master' of github.com:pontarius/pontarius-xmpp

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

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

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

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

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

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)

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