{-# LANGUAGE ViewPatterns, RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-}
-- | Hermes is a middleware layer providing best-effort unicast,
-- remote procedure calls, probabilistic (and slow!) broadcast and
-- automatic membership management. It is meant for small-to-medium
-- networks; its broadcast gossip protocol, which is used for
-- membership management, will scale poorly to very large ones.
--
-- Hermes uses HsLogger for event logging, using the \"hermes\" namespace.
module Network.Hermes(
  HermesException(..),
  withHermes,
  -- * Authorities 
  -- | Unless you turn security off entirely, one Hermes node will not
  -- talk with another unless it trusts the other node. There are two
  -- ways to achieve this: You can specify trusted keys explicitly, or
  -- you can create an signature authority that can create trusted
  -- keys.
  --
  -- This section deals with the latter.
  SignatureRequest, Signature, Authority,
  newAuthority, newSignatureRequest, signRequest, installSignature, addAuthority,
  -- * Context control 
  -- | All communication requires a Hermes context. This section deals
  -- with creating, saving and loading them.
  Context, TrustLevel(..), HermesID,
  newContext, newSignedContext, snapshotContext, snapshotContext',
  restoreContext, uuid, setTimeout, setTrustLimit,
  -- * Listeners
  startListener, Address(..),
  -- * Explicit connections
  -- | While Hermes will normally maintain a membership list on its
  -- own, you still need the address of at least one node in order
  -- to download the list.
  connect,
  -- * Messaging
  send, send', recv, recv', acceptType, refuseType,
  -- * Remote Procedure Calls
  call, registerCallback, ProcName,
  -- * Gossip
  writeFactoid, readFactoid, readFactoids, addCallback, setPeriod, TTL,
  -- * Address book
  snapshotAddresses, restoreAddresses,
  -- * Debugging
  setDebug, Priority(..)
  ) where

import Network.Hermes.Signature(newAuthority, SignatureRequest,
                                Authority(..), signRequest)
import Network.Hermes.Core(CoreContext, TrustLevel(..), HermesID, HermesException(..),
                           withHermes)
import Network.Hermes.Types
import Network.Hermes.Protocol(Address(..),decode')
import Network.Hermes.RPC(RPCContext, ProcName)
import Network.Hermes.Gossip(GossipContext,TTL)
import Network.Hermes.Address
import Network.Hermes.Misc
import System.Log.Logger

import qualified Network.Hermes.Core as Core
import qualified Network.Hermes.Signature as Sig
import qualified Network.Hermes.RPC as RPC
import qualified Network.Hermes.Gossip as Gossip

import qualified Data.Map as M
import Control.Concurrent.STM
import Data.ByteString
import Data.Typeable
import Data.Serialize
 
data Context = Context {
  core :: CoreContext
 ,rpc :: RPCContext
 ,gossip :: GossipContext
  }

-- | Creates a signature request for serialization
newSignatureRequest :: Context -> SignatureRequest
newSignatureRequest = Sig.newSignatureRequest . core

installSignature :: Context -> Signature -> IO ()
installSignature Context{core} = Core.setKeySignature core

-- | Adds an authority to the list of trusted authorities
addAuthority :: Context -> Authority -> IO ()
addAuthority Context{core} = Core.addAuthority core . Sig.authorityKey

-- * Context control

-- | Creates a new Hermes context allowing messaging, RPC and gossip,
-- and using automatic address dissemination via the gossip protocol.
--
-- The trust level defaults to Indirect.
--
-- The gossip interval defaults to 300 seconds, call setPeriod to
-- change it.
newContext :: IO Context
newContext = do
  core <- Core.newContext
  rpc <- RPC.newContext core
  gossip <- Gossip.newGossiper core 300
  startAddresser core gossip
  return Context{..}

-- | Creates a pre-signed context. You may snapshot this to restore on
-- another computer, or use on this one.
newSignedContext :: Authority -> IO Context
newSignedContext authority = do
  core <- Sig.newSignedContext authority
  rpc <- RPC.newContext core
  gossip <- Gossip.newGossiper core 300
  return Context{..}


-- | Snapshots a context for storage  
--
-- Transient state (RPC calls, messages) are discarded, as are
-- connection, listener information and RPC bindings.
snapshotContext' :: Context -> STM ByteString
snapshotContext' Context{..} = do
  coreSnap <- Core.snapshotContext core
  gossipSnap <- Gossip.snapshotGossiper gossip
  return $ encode (coreSnap,gossipSnap)

snapshotContext :: Context -> IO ByteString
snapshotContext = atomically . snapshotContext'

-- | Restores a context from storage
--
-- You will have to reset RPC bindings and listeners.
restoreContext :: ByteString -> IO Context
restoreContext snap = do
  let (coreSnap,gossipSnap) = decode' snap
  core <- atomically $ Core.restoreContext' coreSnap
  rpc <- RPC.newContext core
  gossip <- Gossip.restoreGossiper core gossipSnap
  startAddresser core gossip
  return Context{..}

uuid :: Context -> HermesID
uuid = Core.myHermesID . core

-- | For operations that may block, other than recv, this sets a
-- maximum wait time. Hermes will never block longer than this.
setTimeout :: Context 
             -> Double -- ^ Desired timeout, in seconds
             -> IO ()
setTimeout Context{core} = Core.setTimeout core

-- | Sets the number of retries, for retryable operations. Setting
-- this to N and the timeout to T makes Hermes time-out after T/N
-- seconds, then retry.
setRetries :: Context -> Int -> IO ()
setRetries = undefined -- TODO

-- | Set the desired trust limit, which will take effect on next
-- connection
--
-- When connecting peers (either way), a degree of trust is required,
-- or the connection will be rejected.
setTrustLimit :: Context -> TrustLevel -> IO ()
setTrustLimit Context{core} = Core.setTrustLimit core

-- | Set up a listener for incoming connections. These are not stored
-- when snapshotting contexts. This function will return once the port
-- has been bound.
startListener :: Context
                -> Address -- ^ The local address we should bind to
                -> Maybe Address -- ^ An address to provide peers;
                                -- handy for firewalls.
                -> IO ()
startListener Context{core} = Core.startListener core

-- | Connects to a given address without knowing in advance who will
-- be answering. The answerer's HermesID is returned, assuming the
-- connection is properly established.
--
-- Typically used for bootstrapping.
connect :: Context -> Address -> IO HermesID
connect Context{core} = Core.connect core


-- | Sends a message. The type representation is included, so a
-- modicum of type safety is provided, and recv will only attempt to
-- decode and return a message of the matching (not necessarily
-- correct! Make sure your de/serializers match!) type. There is, of
-- course, a possibility of exceptions if application versions differ.
--
-- You may use send' to provide an arbitrary tag to match on, in which
-- case recv' will only return a message with an equal tag; if you
-- don't, recv will only return messages without tags.
--
-- This function normally blocks until the entire message has been
-- sent, an exception occurs or a timeout is reached. It will retry
-- once if the connection fails within the timeout.
--
-- Unless acceptType or recv has been called in advance, sent messages
-- are thrown away instead of queued. Once either has been, they are
-- indefinitely queued until refuseType is called.
send :: (Serialize msg, Typeable msg)
         => Context -> HermesID -> msg -> IO ()
send Context{core} uuid msg = Core.send core uuid msg

send' :: (Serialize msg, Typeable msg, Serialize tag, Typeable tag)
         => Context -> HermesID -> msg -> tag -> IO ()
send' Context{core} uuid msg tag = Core.send' core uuid msg tag


-- | Receives a message. This function blocks until a message of the
-- appropriate type has been received, possibly forever. You may use
-- multiple simultaneous recv calls; each message will only be
-- delivered once.
recv :: (Serialize msg, Typeable msg)
        => Context -> IO (HermesID,msg)
recv Context{core} = Core.recv core

recv' :: (Serialize msg, Typeable msg, Serialize tag, Typeable tag)
        => Context -> tag -> IO (HermesID,msg)
recv' Context{core} tag = Core.recv' core tag


-- | Registers (or replaces) a callback that is to be executed
-- whenever we receive a properly typed call to this name.
--
-- You may register calls with the same name, so long as they have
-- different types.
--
-- If the callback already exists, it is overwritten.
registerCallback :: forall a b. (Serialize a, Serialize b, Typeable a, Typeable b)
                   => Context
                   -> ProcName   -- ^ Callback's name
                   -> (a -> IO b) -- ^ The callback itself
                   -> IO ()
registerCallback Context{rpc} = RPC.registerCallback rpc

-- | Remote procedure call
--
-- In addition to the usual core exceptions, this function may fail in
-- the specific case the the named procedure doesn't exist or has the
-- wrong type, in which case it returns Nothing.
call :: forall a b. (Serialize a, Typeable a, Serialize b, Typeable b) =>
       Context -> HermesID -> ProcName -> a -> IO (Maybe b)
call Context{rpc} = RPC.call rpc

-- | This utility function decides the lowest priority that will be
-- shown. The default is WARNING.
setDebug :: Priority -> IO ()
setDebug level = updateGlobalLogger "hermes" (setLevel level)


-- | If you wish to queue messages without immediately calling recv, use this.
--
-- acceptType is idempotent.
acceptType :: forall tag msg. (Typeable msg, Serialize tag, Typeable tag)
              => Context
              -> msg -- ^ The message type to accept. Only the type is used, so undefined is fine.
              -> tag
              -> IO ()
acceptType Context{core} msg tag = Core.acceptType core msg tag

-- | If you wish to *stop* queueing messages of a given type, use this.
--
-- Calling refuseType will cause all recv calls to this type/tag
-- combination to throw RecvCancelled.
--
-- refuseType is idempotent.
refuseType :: forall tag msg. (Typeable msg, Serialize tag, Typeable tag)
              => Context
              -> msg -- ^ The message type to accept. Only the type is used, so undefined is fine.
              -> tag
              -> IO ()
refuseType Context{core} msg tag = Core.refuseType core msg tag


-- | Insert a factoid in the gossip network. This will immediately
-- trigger a limited gossip exchange, hopefully spreading it to a
-- large fraction of the network.
--
-- Factoids are keyed by their type, source, and the type and
-- serialized value of an arbitrary tag. They can be replaced by
-- re-inserting later, and optionally expire after a timeout.
-- 
-- Don't rely on the timeout, though. It's for garbage collection, and
-- is not required to be exact.
writeFactoid :: forall factoid tag. (Typeable factoid, Serialize factoid, Typeable tag, Serialize tag)
                => Context -> factoid -> tag
                -> Maybe TTL -- ^ The timeout, in seconds
                -> IO ()
writeFactoid Context{gossip} factoid tag ttl = Gossip.writeFactoid gossip factoid tag ttl

-- | Read a factoid, assuming it exists.
readFactoid :: forall factoid tag. (Typeable factoid, Serialize factoid, Typeable tag, Serialize tag)
               => Context -> tag -> HermesID -> IO (Maybe factoid)
readFactoid Context{gossip} tag source = Gossip.readFactoid gossip tag source

-- | Read all factoids with an appropriate type and tag. Useful if you
-- don't know what source to expect.
readFactoids :: forall factoid tag. (Typeable factoid, Serialize factoid, Typeable tag, Serialize tag)
                => Context -> tag -> IO [(HermesID,factoid)]
readFactoids Context{gossip} tag = Gossip.readFactoids gossip tag

-- | Add a callback to be called every time a type-matching factoid is
-- inserted or updated. It will not be called for writeFactoid calls.
addCallback :: forall msg tag. (Serialize tag, Typeable tag, Serialize msg, Typeable msg)
               => Context -> (HermesID -> tag -> msg -> IO ()) -> IO ()
addCallback Context{gossip} function = Gossip.addCallback gossip function

-- | Set the period for the periodic gossiper. It will take effect
-- after the next periodic gossip.
setPeriod :: Context
             -> Double -- ^ The period, in seconds
             -> IO ()
setPeriod Context{gossip} period = Gossip.setPeriod gossip period


-- | The address snapshot contains address information for every node
-- we know of, which can be restored into another node to bootstrap
-- it.
snapshotAddresses :: Context -> STM ByteString
snapshotAddresses = fmap encode . readTVar . peerAddress . core

-- | Restore an address snapshot to bootstrap your node.
--
-- Returns Nothing on success, otherwise a parse error.
restoreAddresses :: Context -> ByteString -> STM (Maybe String)
restoreAddresses Context{core} (decode -> info) = either (return . Just) mergeInfo info
  where mergeInfo addresses = modifyTVar (peerAddress core) (M.union addresses) >> return Nothing