{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE DeriveDataTypeable, ViewPatterns, GeneralizedNewtypeDeriving, RecordWildCards #-}
-- | Gossiping about addresses
module Network.Hermes.Address(startAddresser) where

import Network.Hermes.Protocol
import Network.Hermes.Misc
import Network.Hermes.Types
import Network.Hermes.Gossip
import Network.Hermes.Core

import System.Log.Logger
import Data.Typeable
import Data.Serialize
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Data.ByteString(ByteString)
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Map(Map)
import qualified Data.Map as M
import qualified Data.Set as S

-- | We gossip about addresses using () for a tag, and.. well, this
-- for a value.
newtype AGossip = AGossip { agAddress :: Address }
                deriving(Serialize,Show,Typeable)

-- | Start the address gossiper. As there are no controls, there is no
-- context returned.
startAddresser :: CoreContext -> GossipContext -> IO ()
startAddresser core gossip = (fmap (const ()) . forkIO) $ do
  mbox <- newEmptyMVar
  -- A listener to check for and insert new addresses
  listenTVar (listeners core) $ \ls -> do
    unless (S.null ls) $ do
      let address = remoteAddress $ S.findMin ls
      noticeM "hermes.address" $ "Updating our address to " ++ show address
      writeFactoid gossip (AGossip address) () Nothing
      atomically $ modifyTVar (peerAddress core) (M.insert (myHermesID core) address)
  -- And one to handle incoming address updates
  addCallback gossip $ \source () AGossip{..} -> do
    noticeM "hermes.address" $ "Updating address for " ++ show source ++ " to " ++ show agAddress
    atomically $ modifyTVar (peerAddress core) (M.insert source agAddress)