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.
104 lines
3.9 KiB
104 lines
3.9 KiB
{-# 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
|
|
|