You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
110 lines
3.9 KiB
110 lines
3.9 KiB
{-# LANGUAGE RankNTypes #-} |
|
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 |
|
|
|
|
|
-- | 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 | isFull j = not . nullOf (peerStatusL j . _PeerAvailable) |
|
| otherwise = not . nullOf (_peers . at j . _Just) |
|
|
|
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) |
|
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 os newStatus |
|
return () |
|
|
|
-- | 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
|
|
|