{-# LANGUAGE RankNTypes #-}
module Network.Xmpp.IM.PresenceTracker where

import           Control.Applicative
import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Lens.Prism (_Just)
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 hiding (Prism)
import           Lens.Family2.Stock hiding (Prism, _Just, from)
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 :: Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))
_peers = forall a b. (a -> b) -> (b -> a) -> Iso a b
mkIso Peers -> Map Jid (Map Jid (Maybe IMPresence))
unPeers Map Jid (Map Jid (Maybe IMPresence)) -> Peers
Peers

_PeerAvailable :: Prism PeerStatus (Maybe IMPresence)
_PeerAvailable :: Prism PeerStatus (Maybe IMPresence)
_PeerAvailable = forall b s. (b -> s) -> (s -> Maybe b) -> Prism s b
prism' Maybe IMPresence -> PeerStatus
PeerAvailable PeerStatus -> Maybe (Maybe IMPresence)
fromPeerAvailable
  where
    fromPeerAvailable :: PeerStatus -> Maybe (Maybe IMPresence)
fromPeerAvailable (PeerAvailable Maybe IMPresence
pa) = forall a. a -> Maybe a
Just Maybe IMPresence
pa
    fromPeerAvailable PeerStatus
_  = forall a. Maybe a
Nothing

_PeerUnavailable :: Prism PeerStatus ()
_PeerUnavailable :: Prism PeerStatus ()
_PeerUnavailable = forall b s. (b -> s) -> (s -> Maybe b) -> Prism s b
prism' (forall a b. a -> b -> a
const PeerStatus
PeerUnavailable) PeerStatus -> Maybe ()
fromPeerUnavailable
  where
    fromPeerUnavailable :: PeerStatus -> Maybe ()
fromPeerUnavailable PeerStatus
PeerUnavailable = forall a. a -> Maybe a
Just ()
    fromPeerUnavailable PeerStatus
_ = forall a. Maybe a
Nothing

_PeerStatus :: Iso (Maybe (Maybe IMPresence)) PeerStatus
_PeerStatus :: Iso (Maybe (Maybe IMPresence)) PeerStatus
_PeerStatus = forall a b. (a -> b) -> (b -> a) -> Iso a b
mkIso Maybe (Maybe IMPresence) -> PeerStatus
toPeerStatus PeerStatus -> Maybe (Maybe IMPresence)
fromPeerStatus
  where
    toPeerStatus :: Maybe (Maybe IMPresence) -> PeerStatus
toPeerStatus (Maybe (Maybe IMPresence)
Nothing) = PeerStatus
PeerUnavailable
    toPeerStatus (Just Maybe IMPresence
imp) = Maybe IMPresence -> PeerStatus
PeerAvailable Maybe IMPresence
imp
    fromPeerStatus :: PeerStatus -> Maybe (Maybe IMPresence)
fromPeerStatus PeerStatus
PeerUnavailable = forall a. Maybe a
Nothing
    fromPeerStatus (PeerAvailable Maybe IMPresence
imp) = forall a. a -> Maybe a
Just Maybe IMPresence
imp

maybeMap :: Iso (Maybe (Map a b)) (Map a b)
maybeMap :: forall a b. Iso (Maybe (Map a b)) (Map a b)
maybeMap = forall a b. (a -> b) -> (b -> a) -> Iso a b
mkIso forall {k} {a}. Maybe (Map k a) -> Map k a
maybeToMap forall {k} {a}. Map k a -> Maybe (Map k a)
mapToMaybe
  where
    maybeToMap :: Maybe (Map k a) -> Map k a
maybeToMap Maybe (Map k a)
Nothing = forall k a. Map k a
Map.empty
    maybeToMap (Just Map k a
m) = Map k a
m
    mapToMaybe :: Map k a -> Maybe (Map k a)
mapToMaybe Map k a
m | forall k a. Map k a -> Bool
Map.null Map k a
m = forall a. Maybe a
Nothing
                 | Bool
otherwise = forall a. a -> Maybe a
Just Map k a
m


-- | Status of give full JID
peerStatusL :: Jid -> Lens' Peers PeerStatus
peerStatusL :: Jid -> Lens' Peers PeerStatus
peerStatusL Jid
j = Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))
_peers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => k -> Lens' (Map k v) (Maybe v)
at (Jid -> Jid
toBare Jid
j)  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Iso (Maybe (Map a b)) (Map a b)
maybeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => k -> Lens' (Map k v) (Maybe v)
at Jid
j forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso (Maybe (Maybe IMPresence)) PeerStatus
_PeerStatus

peerMapPeerAvailable :: Jid -> Peers -> Bool
peerMapPeerAvailable :: Jid -> Peers -> Bool
peerMapPeerAvailable Jid
j | Jid -> Bool
isFull Jid
j = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Fold s t a b -> s -> Bool
nullOf (Jid -> Lens' Peers PeerStatus
peerStatusL Jid
j forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism PeerStatus (Maybe IMPresence)
_PeerAvailable)
                       | Bool
otherwise = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Fold s t a b -> s -> Bool
nullOf (Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))
_peers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => k -> Lens' (Map k v) (Maybe v)
at Jid
j forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just)

handlePresence :: Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
               -> TVar Peers
               -> StanzaHandler
handlePresence :: Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
-> TVar Peers -> StanzaHandler
handlePresence Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
onChange TVar Peers
peers XmppElement -> IO (Either XmppFailure ())
_ XmppElement
st [Annotation]
_  = do
        let mbPr :: Maybe (Presence, Jid)
mbPr = do
                Presence
pr <- XmppElement
st forall s t a b. s -> Fold s t a b -> Maybe a
^? Prism XmppElement Stanza
_Stanza forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism Stanza Presence
_Presence -- Only act on presence stanzas
                Jid
fr <- Presence
pr forall s t a b. s -> Fold s t a b -> Maybe a
^? forall s. IsStanza s => Lens s (Maybe Jid)
from forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism Jid Jid
_isFull -- Only act on full JIDs
                forall (m :: * -> *) a. Monad m => a -> m a
return (Presence
pr, Jid
fr)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Foldable.forM_ Maybe (Presence, Jid)
mbPr forall a b. (a -> b) -> a -> b
$ \(Presence
pr, Jid
fr) ->
            case Presence -> PresenceType
presenceType Presence
pr of
                PresenceType
Available -> Jid -> PeerStatus -> IO ()
setStatus Jid
fr   (Maybe IMPresence -> PeerStatus
PeerAvailable (Presence -> Maybe IMPresence
getIMPresence Presence
pr))
                PresenceType
Unavailable -> Jid -> PeerStatus -> IO ()
setStatus Jid
fr PeerStatus
PeerUnavailable
                PresenceType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall (m :: * -> *) a. Monad m => a -> m a
return [(XmppElement
st, [])]
  where
    setStatus :: Jid -> PeerStatus -> IO ()
setStatus Jid
fr PeerStatus
newStatus = do
        PeerStatus
os <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            Peers
ps <- forall a. TVar a -> STM a
readTVar TVar Peers
peers
            let oldStatus :: PeerStatus
oldStatus = Peers
ps forall s a t b. s -> FoldLike a s t a b -> a
^. Jid -> Lens' Peers PeerStatus
peerStatusL Jid
fr
            forall a. TVar a -> a -> STM ()
writeTVar TVar Peers
peers forall a b. (a -> b) -> a -> b
$ Peers
ps forall s t. s -> (s -> t) -> t
& forall s t a b. Setter s t a b -> b -> s -> t
set (Jid -> Lens' Peers PeerStatus
peerStatusL Jid
fr) PeerStatus
newStatus
            forall (m :: * -> *) a. Monad m => a -> m a
return PeerStatus
oldStatus
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PeerStatus
os forall a. Eq a => a -> a -> Bool
== PeerStatus
newStatus) forall a b. (a -> b) -> a -> b
$ case Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
onChange of
            Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Jid -> PeerStatus -> PeerStatus -> IO ()
oc -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Jid -> PeerStatus -> PeerStatus -> IO ()
oc Jid
fr PeerStatus
os PeerStatus
newStatus
        forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Check whether a given jid is available
isPeerAvailable :: Jid -> Session -> STM Bool
isPeerAvailable :: Jid -> Session -> STM Bool
isPeerAvailable Jid
j Session
sess = Jid -> Peers -> Bool
peerMapPeerAvailable Jid
j forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar (Session -> TVar Peers
presenceRef Session
sess)

-- | Get status of given full JID
getEntityStatus :: Jid -> Session -> STM PeerStatus
getEntityStatus :: Jid -> Session -> STM PeerStatus
getEntityStatus Jid
j Session
sess = do
    Peers
peers <- forall a. TVar a -> STM a
readTVar (Session -> TVar Peers
presenceRef Session
sess)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Peers
peers forall s a t b. s -> FoldLike a s t a b -> a
^. Jid -> Lens' Peers PeerStatus
peerStatusL Jid
j

-- | Get list of (bare) Jids with available entities
getAvailablePeers :: Session -> STM [Jid]
getAvailablePeers :: Session -> STM [Jid]
getAvailablePeers Session
sess = do
    Peers Map Jid (Map Jid (Maybe IMPresence))
peers <- forall a. TVar a -> STM a
readTVar (Session -> TVar Peers
presenceRef Session
sess)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map Jid (Map Jid (Maybe IMPresence))
peers

-- | Get all available full JIDs to the given JID
getPeerEntities :: Jid -> Session -> STM (Map Jid (Maybe IMPresence))
getPeerEntities :: Jid -> Session -> STM (Map Jid (Maybe IMPresence))
getPeerEntities Jid
j Session
sess = do
    Peers Map Jid (Map Jid (Maybe IMPresence))
peers <- forall a. TVar a -> STM a
readTVar (Session -> TVar Peers
presenceRef Session
sess)
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Jid -> Jid
toBare Jid
j) Map Jid (Map Jid (Maybe IMPresence))
peers of
        Maybe (Map Jid (Maybe IMPresence))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
Map.empty
        Just Map Jid (Maybe IMPresence)
js -> forall (m :: * -> *) a. Monad m => a -> m a
return Map Jid (Maybe IMPresence)
js