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.
105 lines
3.9 KiB
105 lines
3.9 KiB
12 years ago
|
{-# 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
|