content: {-# 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 (Jid -> PeerStatus -> PeerStatus -> IO ())
                 -> TVar Peers
                 -> StanzaHandler
  handlePresence onChange peers _ st _  = do
          let mbPr = do
                  pr <- st ^? _Stanza . _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 fr 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
  