module Network.Xmpp.IM.PresenceTracker where
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import qualified Data.Foldable as Foldable
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Lens.Family2
import Lens.Family2.Stock
import Network.Xmpp.Concurrent.Types
import Network.Xmpp.IM.Presence
import Network.Xmpp.Lens hiding (Lens, Traversal)
import Network.Xmpp.Types
import Prelude hiding (mapM)
import Network.Xmpp.IM.PresenceTracker.Types
_peers :: Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))
_peers = mkIso unPeers Peers
_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 | isFull j = not . nullOf (peerStatusL j . _PeerAvailable)
| otherwise = not . nullOf (_peers . at j . _Just)
handlePresence :: Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
-> TVar Peers
-> StanzaHandler
handlePresence onChange peers _ st _ = do
let mbPr = do
pr <- st ^? _Stanza . _Presence
fr <- pr ^? from . _Just . _isFull
return (pr, fr)
Foldable.forM_ mbPr $ \(pr, fr) ->
case presenceType pr of
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 ()
isPeerAvailable :: Jid -> Session -> STM Bool
isPeerAvailable j sess = peerMapPeerAvailable j <$> readTVar (presenceRef sess)
getEntityStatus :: Jid -> Session -> STM PeerStatus
getEntityStatus j sess = do
peers <- readTVar (presenceRef sess)
return $ peers ^. peerStatusL j
getAvailablePeers :: Session -> STM [Jid]
getAvailablePeers sess = do
Peers peers <- readTVar (presenceRef sess)
return $ Map.keys peers
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