{-# 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 :: p (Map Jid (Map Jid (Maybe IMPresence)))
  (f (Map Jid (Map Jid (Maybe IMPresence))))
-> p Peers (f Peers)
_peers = (Peers -> Map Jid (Map Jid (Maybe IMPresence)))
-> (Map Jid (Map Jid (Maybe IMPresence)) -> Peers)
-> Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))
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 :: p (Maybe IMPresence) (f (Maybe IMPresence))
-> p PeerStatus (f PeerStatus)
_PeerAvailable = (Maybe IMPresence -> PeerStatus)
-> (PeerStatus -> Maybe (Maybe IMPresence))
-> Prism PeerStatus (Maybe IMPresence)
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) = Maybe IMPresence -> Maybe (Maybe IMPresence)
forall a. a -> Maybe a
Just Maybe IMPresence
pa
    fromPeerAvailable PeerStatus
_  = Maybe (Maybe IMPresence)
forall a. Maybe a
Nothing

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

_PeerStatus :: Iso (Maybe (Maybe IMPresence)) PeerStatus
_PeerStatus :: p PeerStatus (f PeerStatus)
-> p (Maybe (Maybe IMPresence)) (f (Maybe (Maybe IMPresence)))
_PeerStatus = (Maybe (Maybe IMPresence) -> PeerStatus)
-> (PeerStatus -> Maybe (Maybe IMPresence))
-> Iso (Maybe (Maybe IMPresence)) 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 = Maybe (Maybe IMPresence)
forall a. Maybe a
Nothing
    fromPeerStatus (PeerAvailable Maybe IMPresence
imp) = Maybe IMPresence -> Maybe (Maybe IMPresence)
forall a. a -> Maybe a
Just Maybe IMPresence
imp

maybeMap :: Iso (Maybe (Map a b)) (Map a b)
maybeMap :: p (Map a b) (f (Map a b))
-> p (Maybe (Map a b)) (f (Maybe (Map a b)))
maybeMap = (Maybe (Map a b) -> Map a b)
-> (Map a b -> Maybe (Map a b)) -> Iso (Maybe (Map a b)) (Map a b)
forall a b. (a -> b) -> (b -> a) -> Iso a b
mkIso Maybe (Map a b) -> Map a b
forall k a. Maybe (Map k a) -> Map k a
maybeToMap Map a b -> Maybe (Map a b)
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 = Map k a
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 | Map k a -> Bool
forall k a. Map k a -> Bool
Map.null Map k a
m = Maybe (Map k a)
forall a. Maybe a
Nothing
                 | Bool
otherwise = Map k a -> Maybe (Map k a)
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 = (Map Jid (Map Jid (Maybe IMPresence))
 -> f (Map Jid (Map Jid (Maybe IMPresence))))
-> Peers -> f Peers
Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))
_peers ((Map Jid (Map Jid (Maybe IMPresence))
  -> f (Map Jid (Map Jid (Maybe IMPresence))))
 -> Peers -> f Peers)
-> ((PeerStatus -> f PeerStatus)
    -> Map Jid (Map Jid (Maybe IMPresence))
    -> f (Map Jid (Map Jid (Maybe IMPresence))))
-> (PeerStatus -> f PeerStatus)
-> Peers
-> f Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jid
-> Lens'
     (Map Jid (Map Jid (Maybe IMPresence)))
     (Maybe (Map Jid (Maybe IMPresence)))
forall k v. Ord k => k -> Lens' (Map k v) (Maybe v)
at (Jid -> Jid
toBare Jid
j)  LensLike'
  f
  (Map Jid (Map Jid (Maybe IMPresence)))
  (Maybe (Map Jid (Maybe IMPresence)))
-> ((PeerStatus -> f PeerStatus)
    -> Maybe (Map Jid (Maybe IMPresence))
    -> f (Maybe (Map Jid (Maybe IMPresence))))
-> (PeerStatus -> f PeerStatus)
-> Map Jid (Map Jid (Maybe IMPresence))
-> f (Map Jid (Map Jid (Maybe IMPresence)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Jid (Maybe IMPresence) -> f (Map Jid (Maybe IMPresence)))
-> Maybe (Map Jid (Maybe IMPresence))
-> f (Maybe (Map Jid (Maybe IMPresence)))
forall a b. Iso (Maybe (Map a b)) (Map a b)
maybeMap ((Map Jid (Maybe IMPresence) -> f (Map Jid (Maybe IMPresence)))
 -> Maybe (Map Jid (Maybe IMPresence))
 -> f (Maybe (Map Jid (Maybe IMPresence))))
-> ((PeerStatus -> f PeerStatus)
    -> Map Jid (Maybe IMPresence) -> f (Map Jid (Maybe IMPresence)))
-> (PeerStatus -> f PeerStatus)
-> Maybe (Map Jid (Maybe IMPresence))
-> f (Maybe (Map Jid (Maybe IMPresence)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jid
-> Lens' (Map Jid (Maybe IMPresence)) (Maybe (Maybe IMPresence))
forall k v. Ord k => k -> Lens' (Map k v) (Maybe v)
at Jid
j LensLike' f (Map Jid (Maybe IMPresence)) (Maybe (Maybe IMPresence))
-> ((PeerStatus -> f PeerStatus)
    -> Maybe (Maybe IMPresence) -> f (Maybe (Maybe IMPresence)))
-> (PeerStatus -> f PeerStatus)
-> Map Jid (Maybe IMPresence)
-> f (Map Jid (Maybe IMPresence))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PeerStatus -> f PeerStatus)
-> Maybe (Maybe IMPresence) -> f (Maybe (Maybe IMPresence))
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 (Bool -> Bool) -> (Peers -> Bool) -> Peers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold Peers Peers (Maybe IMPresence) (Maybe IMPresence)
-> Peers -> Bool
forall s t a b. Fold s t a b -> s -> Bool
nullOf (Jid -> Lens' Peers PeerStatus
peerStatusL Jid
j LensLike' f Peers PeerStatus
-> ((Maybe IMPresence -> f (Maybe IMPresence))
    -> PeerStatus -> f PeerStatus)
-> (Maybe IMPresence -> f (Maybe IMPresence))
-> Peers
-> f Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe IMPresence -> f (Maybe IMPresence))
-> PeerStatus -> f PeerStatus
Prism PeerStatus (Maybe IMPresence)
_PeerAvailable)
                       | Bool
otherwise = Bool -> Bool
not (Bool -> Bool) -> (Peers -> Bool) -> Peers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold
  Peers
  Peers
  (Map Jid (Maybe IMPresence))
  (Map Jid (Maybe IMPresence))
-> Peers -> Bool
forall s t a b. Fold s t a b -> s -> Bool
nullOf ((Map Jid (Map Jid (Maybe IMPresence))
 -> f (Map Jid (Map Jid (Maybe IMPresence))))
-> Peers -> f Peers
Iso Peers (Map Jid (Map Jid (Maybe IMPresence)))
_peers ((Map Jid (Map Jid (Maybe IMPresence))
  -> f (Map Jid (Map Jid (Maybe IMPresence))))
 -> Peers -> f Peers)
-> ((Map Jid (Maybe IMPresence) -> f (Map Jid (Maybe IMPresence)))
    -> Map Jid (Map Jid (Maybe IMPresence))
    -> f (Map Jid (Map Jid (Maybe IMPresence))))
-> (Map Jid (Maybe IMPresence) -> f (Map Jid (Maybe IMPresence)))
-> Peers
-> f Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jid
-> Lens'
     (Map Jid (Map Jid (Maybe IMPresence)))
     (Maybe (Map Jid (Maybe IMPresence)))
forall k v. Ord k => k -> Lens' (Map k v) (Maybe v)
at Jid
j LensLike'
  f
  (Map Jid (Map Jid (Maybe IMPresence)))
  (Maybe (Map Jid (Maybe IMPresence)))
-> ((Map Jid (Maybe IMPresence) -> f (Map Jid (Maybe IMPresence)))
    -> Maybe (Map Jid (Maybe IMPresence))
    -> f (Maybe (Map Jid (Maybe IMPresence))))
-> (Map Jid (Maybe IMPresence) -> f (Map Jid (Maybe IMPresence)))
-> Map Jid (Map Jid (Maybe IMPresence))
-> f (Map Jid (Map Jid (Maybe IMPresence)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Jid (Maybe IMPresence) -> f (Map Jid (Maybe IMPresence)))
-> Maybe (Map Jid (Maybe IMPresence))
-> f (Maybe (Map Jid (Maybe IMPresence)))
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 XmppElement
-> Fold XmppElement XmppElement Presence Presence -> Maybe Presence
forall s t a b. s -> Fold s t a b -> Maybe a
^? (Stanza -> f Stanza) -> XmppElement -> f XmppElement
Prism XmppElement Stanza
_Stanza ((Stanza -> f Stanza) -> XmppElement -> f XmppElement)
-> ((Presence -> f Presence) -> Stanza -> f Stanza)
-> (Presence -> f Presence)
-> XmppElement
-> f XmppElement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Presence -> f Presence) -> Stanza -> f Stanza
Prism Stanza Presence
_Presence -- Only act on presence stanzas
                Jid
fr <- Presence
pr Presence -> Fold Presence Presence Jid Jid -> Maybe Jid
forall s t a b. s -> Fold s t a b -> Maybe a
^? (Maybe Jid -> f (Maybe Jid)) -> Presence -> f Presence
forall s. IsStanza s => Lens s (Maybe Jid)
from ((Maybe Jid -> f (Maybe Jid)) -> Presence -> f Presence)
-> ((Jid -> f Jid) -> Maybe Jid -> f (Maybe Jid))
-> (Jid -> f Jid)
-> Presence
-> f Presence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Jid -> f Jid) -> Maybe Jid -> f (Maybe Jid)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Jid -> f Jid) -> Maybe Jid -> f (Maybe Jid))
-> ((Jid -> f Jid) -> Jid -> f Jid)
-> (Jid -> f Jid)
-> Maybe Jid
-> f (Maybe Jid)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Jid -> f Jid) -> Jid -> f Jid
Prism Jid Jid
_isFull -- Only act on full JIDs
                (Presence, Jid) -> Maybe (Presence, Jid)
forall (m :: * -> *) a. Monad m => a -> m a
return (Presence
pr, Jid
fr)
        Maybe (Presence, Jid) -> ((Presence, Jid) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Foldable.forM_ Maybe (Presence, Jid)
mbPr (((Presence, Jid) -> IO ()) -> IO ())
-> ((Presence, Jid) -> IO ()) -> IO ()
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
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [(XmppElement, [Annotation])] -> IO [(XmppElement, [Annotation])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(XmppElement
st, [])]
  where
    setStatus :: Jid -> PeerStatus -> IO ()
setStatus Jid
fr PeerStatus
newStatus = do
        PeerStatus
os <- STM PeerStatus -> IO PeerStatus
forall a. STM a -> IO a
atomically (STM PeerStatus -> IO PeerStatus)
-> STM PeerStatus -> IO PeerStatus
forall a b. (a -> b) -> a -> b
$ do
            Peers
ps <- TVar Peers -> STM Peers
forall a. TVar a -> STM a
readTVar TVar Peers
peers
            let oldStatus :: PeerStatus
oldStatus = Peers
ps Peers
-> FoldLike PeerStatus Peers Peers PeerStatus PeerStatus
-> PeerStatus
forall s a t b. s -> FoldLike a s t a b -> a
^. Jid -> Lens' Peers PeerStatus
peerStatusL Jid
fr
            TVar Peers -> Peers -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Peers
peers (Peers -> STM ()) -> Peers -> STM ()
forall a b. (a -> b) -> a -> b
$ Peers
ps Peers -> (Peers -> Peers) -> Peers
forall s t. s -> (s -> t) -> t
& Setter Peers Peers PeerStatus PeerStatus
-> PeerStatus -> Peers -> Peers
forall s t a b. Setter s t a b -> b -> s -> t
set (Jid -> Lens' Peers PeerStatus
peerStatusL Jid
fr) PeerStatus
newStatus
            PeerStatus -> STM PeerStatus
forall (m :: * -> *) a. Monad m => a -> m a
return PeerStatus
oldStatus
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PeerStatus
os PeerStatus -> PeerStatus -> Bool
forall a. Eq a => a -> a -> Bool
== PeerStatus
newStatus) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
onChange of
            Maybe (Jid -> PeerStatus -> PeerStatus -> IO ())
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Jid -> PeerStatus -> PeerStatus -> IO ()
oc -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Jid -> PeerStatus -> PeerStatus -> IO ()
oc Jid
fr PeerStatus
os PeerStatus
newStatus
        () -> IO ()
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 (Peers -> Bool) -> STM Peers -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Peers -> STM Peers
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 <- TVar Peers -> STM Peers
forall a. TVar a -> STM a
readTVar (Session -> TVar Peers
presenceRef Session
sess)
    PeerStatus -> STM PeerStatus
forall (m :: * -> *) a. Monad m => a -> m a
return (PeerStatus -> STM PeerStatus) -> PeerStatus -> STM PeerStatus
forall a b. (a -> b) -> a -> b
$ Peers
peers Peers
-> FoldLike PeerStatus Peers Peers PeerStatus PeerStatus
-> PeerStatus
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 <- TVar Peers -> STM Peers
forall a. TVar a -> STM a
readTVar (Session -> TVar Peers
presenceRef Session
sess)
    [Jid] -> STM [Jid]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Jid] -> STM [Jid]) -> [Jid] -> STM [Jid]
forall a b. (a -> b) -> a -> b
$ Map Jid (Map Jid (Maybe IMPresence)) -> [Jid]
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 <- TVar Peers -> STM Peers
forall a. TVar a -> STM a
readTVar (Session -> TVar Peers
presenceRef Session
sess)
    case Jid
-> Map Jid (Map Jid (Maybe IMPresence))
-> Maybe (Map Jid (Maybe IMPresence))
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 -> Map Jid (Maybe IMPresence) -> STM (Map Jid (Maybe IMPresence))
forall (m :: * -> *) a. Monad m => a -> m a
return Map Jid (Maybe IMPresence)
forall k a. Map k a
Map.empty
        Just Map Jid (Maybe IMPresence)
js -> Map Jid (Maybe IMPresence) -> STM (Map Jid (Maybe IMPresence))
forall (m :: * -> *) a. Monad m => a -> m a
return Map Jid (Maybe IMPresence)
js