From 0f29daf8d5da5740b705c6c70585fc8ebb58fc7e Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Sat, 6 Sep 2014 16:22:06 +0200
Subject: [PATCH] add accessor functions for tracked presence

---
 source/Network/Xmpp/IM.hs                     |  6 ++++
 source/Network/Xmpp/IM/PresenceTracker.hs     | 34 +++++++++++++++----
 .../Network/Xmpp/IM/PresenceTracker/Types.hs  |  4 +++
 3 files changed, 37 insertions(+), 7 deletions(-)

diff --git a/source/Network/Xmpp/IM.hs b/source/Network/Xmpp/IM.hs
index 5c1b682..731d9db 100644
--- a/source/Network/Xmpp/IM.hs
+++ b/source/Network/Xmpp/IM.hs
@@ -24,9 +24,15 @@ module Network.Xmpp.IM
   , getRoster
   , rosterAdd
   , rosterRemove
+  -- * presenceTracker
+  , isPeerAvailable
+  , getEntityStatus
+  , getAvailablePeers
+  , getPeerEntities
   ) where
 
 import Network.Xmpp.IM.Message
 import Network.Xmpp.IM.Presence
 import Network.Xmpp.IM.Roster
 import Network.Xmpp.IM.Roster.Types
+import Network.Xmpp.IM.PresenceTracker
diff --git a/source/Network/Xmpp/IM/PresenceTracker.hs b/source/Network/Xmpp/IM/PresenceTracker.hs
index 0663e28..82c331d 100644
--- a/source/Network/Xmpp/IM/PresenceTracker.hs
+++ b/source/Network/Xmpp/IM/PresenceTracker.hs
@@ -20,10 +20,6 @@ import           Network.Xmpp.IM.PresenceTracker.Types
 _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
@@ -52,11 +48,14 @@ maybeMap = mkIso maybeToMap mapToMaybe
     mapToMaybe m | Map.null m = Nothing
                  | otherwise = Just m
 
+
+-- | Status of give full JID
 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)
+peerMapPeerAvailable j | isFull j = not . nullOf (peerStatusL j . _PeerAvailable)
+                       | otherwise = not . nullOf (_peers . at j . _Just)
 
 handlePresence :: TVar Peers -> StanzaHandler
 handlePresence peers _ st _  = do
@@ -74,5 +73,26 @@ handlePresence peers _ st _  = do
                 _ -> return ()
         return [(st, [])]
 
-isPeerAvailable :: Jid -> TVar Peers -> STM Bool
-isPeerAvailable j peerRef = peerMapPeerAvailable j <$> readTVar peerRef
+-- | Check whether a given jid is available
+isPeerAvailable :: Jid -> Session -> STM Bool
+isPeerAvailable j sess = peerMapPeerAvailable j <$> readTVar (presenceRef sess)
+
+-- | Get status of given full JID
+getEntityStatus :: Jid -> Session -> STM PeerStatus
+getEntityStatus j sess = do
+    peers <- readTVar (presenceRef sess)
+    return $ peers ^. peerStatusL j
+
+-- | Get list of (bare) Jids with available entities
+getAvailablePeers :: Session -> STM [Jid]
+getAvailablePeers sess = do
+    Peers peers <- readTVar (presenceRef sess)
+    return $ Map.keys peers
+
+-- | Get all available full JIDs to the given JID
+getPeerEntities :: Jid -> Session -> STM (Map Jid (Maybe IMPresence))
+getPeerEntities j sess = do
+    Peers peers <- readTVar (presenceRef sess)
+    case Map.lookup (toBare j) peers of
+        Nothing -> return Map.empty
+        Just js -> return js
diff --git a/source/Network/Xmpp/IM/PresenceTracker/Types.hs b/source/Network/Xmpp/IM/PresenceTracker/Types.hs
index 4dc412c..334c066 100644
--- a/source/Network/Xmpp/IM/PresenceTracker/Types.hs
+++ b/source/Network/Xmpp/IM/PresenceTracker/Types.hs
@@ -14,3 +14,7 @@ import           Network.Xmpp.IM.Presence
 -- * 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)
+
+data PeerStatus = PeerAvailable (Maybe IMPresence)
+                | PeerUnavailable
+                  deriving (Show)