add presence Tracker

pontarius-xmpp.cabal

@@ -93,6 +93,7 @@ Library
                  , Network.Xmpp.Concurrent.Types
                  , Network.Xmpp.IM.Message
                  , Network.Xmpp.IM.Presence
+                 , Network.Xmpp.IM.PresenceTracker
                  , Network.Xmpp.IM.Roster
                  , Network.Xmpp.IM.Roster.Types
                  , Network.Xmpp.Marshal

source/Network/Xmpp/IM/PresenceTracker.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE RankNTypes #-}
+module Network.Xmpp.IM.PresenceTracker where
+
+import           Control.Applicative
+import           Control.Concurrent.STM
+import           Control.Monad (guard)
+import           Data.Foldable
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import           Data.Maybe
+import           Data.Traversable
+import           Lens.Family2
+import           Lens.Family2.Stock
+import           Network.Xmpp.Concurrent.Types
+import           Network.Xmpp.IM.Presence
+import           Network.Xmpp.IM.Roster
+import           Network.Xmpp.Lens hiding (Lens, Traversal)
+import           Network.Xmpp.Types
+import           Prelude hiding (mapM)
+
+-- Map from bare JIDs to a map of full JIDs to show maybe status.
+--
+-- Invariants:
+-- * The outer map should not have entries for bare JIDs that have no
+--   available resource, i.e. the inner map should never be empty
+--
+-- * The inner map keys' local and domain part coincide with the outer keys'
+newtype Peers = Peers { unPeers :: Map Jid (Map Jid (Maybe IMPresence))}
+                deriving (Show)
+
+_peers :: Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))
+_peers = mkIso unPeers Peers
+
+data PeerStatus = PeerAvailable (Maybe IMPresence)
+                | PeerUnavailable
+                  deriving (Show)
+
+_PeerAvailable :: Prism PeerStatus (Maybe IMPresence)
+_PeerAvailable = prism' PeerAvailable fromPeerAvailable
+  where
+    fromPeerAvailable (PeerAvailable pa) = Just pa
+    fromPeerAvailable _  = Nothing
+
+_PeerUnavailable :: Prism PeerStatus ()
+_PeerUnavailable = prism' (const PeerUnavailable) fromPeerUnavailable
+  where
+    fromPeerUnavailable PeerUnavailable = Just ()
+    fromPeerUnavailable _ = Nothing
+
+_PeerStatus :: Iso (Maybe (Maybe IMPresence)) PeerStatus
+_PeerStatus = mkIso toPeerStatus fromPeerStatus
+  where
+    toPeerStatus (Nothing) = PeerUnavailable
+    toPeerStatus (Just imp) = PeerAvailable imp
+    fromPeerStatus PeerUnavailable = Nothing
+    fromPeerStatus (PeerAvailable imp) = Just imp
+
+maybeMap :: Iso (Maybe (Map a b)) (Map a b)
+maybeMap = mkIso maybeToMap mapToMaybe
+  where
+    maybeToMap Nothing = Map.empty
+    maybeToMap (Just m) = m
+    mapToMaybe m | Map.null m = Nothing
+                 | otherwise = Just m
+
+peerStatusL :: Jid -> Lens' Peers PeerStatus
+peerStatusL j = _peers . at (toBare j)  . maybeMap . at j . _PeerStatus
+
+peerMapPeerAvailable :: Jid -> Peers -> Bool
+peerMapPeerAvailable j =  not . nullOf (peerStatusL j . _PeerAvailable)
+
+statusTracker :: (Stanza -> IO (Either XmppFailure ()))
+              -> IO (Plugin', TVar Peers)
+statusTracker out = do
+    sessRef <- newTVarIO Nothing
+    peerMap <- newTVarIO (Peers Map.empty)
+
+    return (Plugin' { inHandler = handleIn sessRef peerMap
+                    , outHandler = out
+                    , onSessionUp = atomically . writeTVar sessRef . Just
+                    }, peerMap)
+  where
+    handleIn sessRef peers st _ = do
+        mbRoster <- atomically (mapM getRoster' =<< readTVar sessRef)
+        let mbPr = do
+                pr <- st ^? _Presence -- Only act on presence stanzas
+                fr <- pr ^? from . _Just . _isFull -- Only act on full JIDs
+                roster <- mbRoster
+                -- Check that the from address is in our roster. This means that
+                -- deactivating the roster effectively turns off this plugin
+                guard $ Map.member (toBare fr) (roster ^. itemsL)
+                return (pr, fr)
+        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
+                _ -> return ()
+        return [(st, [])]
+
+isPeerAvailable :: Jid -> TVar Peers -> STM Bool
+isPeerAvailable j peerRef = peerMapPeerAvailable j <$> readTVar peerRef