{-# LANGUAGE OverloadedStrings #-}

module Bcc.Node.Configuration.Topology
  ( TopologyError(..)
  , NetworkTopology(..)
  , NodeHostIPAddress(..)
  , NodeHostIPv4Address(..)
  , NodeHostIPv6Address(..)
  , NodeSetup(..)
  , RemoteAddress(..)
  , nodeAddressToSockAddr
  , readTopologyFile
  , remoteAddressToNodeAddress
  )
where

import           Bcc.Prelude
import           Prelude (String)

import qualified Control.Exception as Exception
import           Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Text as Text

import           Bcc.Node.Configuration.POM (NodeConfiguration (..))
import           Bcc.Node.Types

import           Shardagnostic.Consensus.Util.Condense (Condense (..))


newtype TopologyError
  = NodeIdNotFoundInToplogyFile FilePath
  deriving Int -> TopologyError -> ShowS
[TopologyError] -> ShowS
TopologyError -> String
(Int -> TopologyError -> ShowS)
-> (TopologyError -> String)
-> ([TopologyError] -> ShowS)
-> Show TopologyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TopologyError] -> ShowS
$cshowList :: [TopologyError] -> ShowS
show :: TopologyError -> String
$cshow :: TopologyError -> String
showsPrec :: Int -> TopologyError -> ShowS
$cshowsPrec :: Int -> TopologyError -> ShowS
Show

-- | Domain name with port number
--
data RemoteAddress = RemoteAddress
  { RemoteAddress -> Text
raAddress   :: !Text
  -- ^ Either a dns address or an ip address.
  , RemoteAddress -> PortNumber
raPort      :: !PortNumber
  -- ^ Port number of the destination.
  , RemoteAddress -> Int
raValency :: !Int
  -- ^ If a DNS address is given valency governs
  -- to how many resolved IP addresses
  -- should we maintain active (hot) connection;
  -- if an IP address is given valency is used as
  -- a Boolean value, @0@ means to ignore the address;
  } deriving (RemoteAddress -> RemoteAddress -> Bool
(RemoteAddress -> RemoteAddress -> Bool)
-> (RemoteAddress -> RemoteAddress -> Bool) -> Eq RemoteAddress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RemoteAddress -> RemoteAddress -> Bool
$c/= :: RemoteAddress -> RemoteAddress -> Bool
== :: RemoteAddress -> RemoteAddress -> Bool
$c== :: RemoteAddress -> RemoteAddress -> Bool
Eq, Eq RemoteAddress
Eq RemoteAddress
-> (RemoteAddress -> RemoteAddress -> Ordering)
-> (RemoteAddress -> RemoteAddress -> Bool)
-> (RemoteAddress -> RemoteAddress -> Bool)
-> (RemoteAddress -> RemoteAddress -> Bool)
-> (RemoteAddress -> RemoteAddress -> Bool)
-> (RemoteAddress -> RemoteAddress -> RemoteAddress)
-> (RemoteAddress -> RemoteAddress -> RemoteAddress)
-> Ord RemoteAddress
RemoteAddress -> RemoteAddress -> Bool
RemoteAddress -> RemoteAddress -> Ordering
RemoteAddress -> RemoteAddress -> RemoteAddress
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RemoteAddress -> RemoteAddress -> RemoteAddress
$cmin :: RemoteAddress -> RemoteAddress -> RemoteAddress
max :: RemoteAddress -> RemoteAddress -> RemoteAddress
$cmax :: RemoteAddress -> RemoteAddress -> RemoteAddress
>= :: RemoteAddress -> RemoteAddress -> Bool
$c>= :: RemoteAddress -> RemoteAddress -> Bool
> :: RemoteAddress -> RemoteAddress -> Bool
$c> :: RemoteAddress -> RemoteAddress -> Bool
<= :: RemoteAddress -> RemoteAddress -> Bool
$c<= :: RemoteAddress -> RemoteAddress -> Bool
< :: RemoteAddress -> RemoteAddress -> Bool
$c< :: RemoteAddress -> RemoteAddress -> Bool
compare :: RemoteAddress -> RemoteAddress -> Ordering
$ccompare :: RemoteAddress -> RemoteAddress -> Ordering
$cp1Ord :: Eq RemoteAddress
Ord, Int -> RemoteAddress -> ShowS
[RemoteAddress] -> ShowS
RemoteAddress -> String
(Int -> RemoteAddress -> ShowS)
-> (RemoteAddress -> String)
-> ([RemoteAddress] -> ShowS)
-> Show RemoteAddress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RemoteAddress] -> ShowS
$cshowList :: [RemoteAddress] -> ShowS
show :: RemoteAddress -> String
$cshow :: RemoteAddress -> String
showsPrec :: Int -> RemoteAddress -> ShowS
$cshowsPrec :: Int -> RemoteAddress -> ShowS
Show)


-- | Parse 'raAddress' field as an IP address; if it parses and the valency is
-- non zero return corresponding NodeAddress.
--
remoteAddressToNodeAddress
  :: RemoteAddress
  -> Maybe (Either NodeIPAddress
                   (NodeDnsAddress, Int))
remoteAddressToNodeAddress :: RemoteAddress -> Maybe (Either NodeIPAddress (NodeDnsAddress, Int))
remoteAddressToNodeAddress (RemoteAddress Text
_addrText PortNumber
_port Int
0) =
    Maybe (Either NodeIPAddress (NodeDnsAddress, Int))
forall a. Maybe a
Nothing
remoteAddressToNodeAddress (RemoteAddress Text
addrText PortNumber
port Int
valency) =
    case String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
addrText) of
      Maybe IP
Nothing   -> Either NodeIPAddress (NodeDnsAddress, Int)
-> Maybe (Either NodeIPAddress (NodeDnsAddress, Int))
forall a. a -> Maybe a
Just (Either NodeIPAddress (NodeDnsAddress, Int)
 -> Maybe (Either NodeIPAddress (NodeDnsAddress, Int)))
-> Either NodeIPAddress (NodeDnsAddress, Int)
-> Maybe (Either NodeIPAddress (NodeDnsAddress, Int))
forall a b. (a -> b) -> a -> b
$ (NodeDnsAddress, Int) -> Either NodeIPAddress (NodeDnsAddress, Int)
forall a b. b -> Either a b
Right (NodeHostDnsAddress -> PortNumber -> NodeDnsAddress
forall addr. addr -> PortNumber -> NodeAddress' addr
NodeAddress (Text -> NodeHostDnsAddress
NodeHostDnsAddress Text
addrText) PortNumber
port
                                , Int
valency)
      Just IP
addr -> Either NodeIPAddress (NodeDnsAddress, Int)
-> Maybe (Either NodeIPAddress (NodeDnsAddress, Int))
forall a. a -> Maybe a
Just (Either NodeIPAddress (NodeDnsAddress, Int)
 -> Maybe (Either NodeIPAddress (NodeDnsAddress, Int)))
-> Either NodeIPAddress (NodeDnsAddress, Int)
-> Maybe (Either NodeIPAddress (NodeDnsAddress, Int))
forall a b. (a -> b) -> a -> b
$ NodeIPAddress -> Either NodeIPAddress (NodeDnsAddress, Int)
forall a b. a -> Either a b
Left  (NodeHostIPAddress -> PortNumber -> NodeIPAddress
forall addr. addr -> PortNumber -> NodeAddress' addr
NodeAddress (IP -> NodeHostIPAddress
NodeHostIPAddress IP
addr) PortNumber
port)


instance Condense RemoteAddress where
  condense :: RemoteAddress -> String
condense (RemoteAddress Text
addr PortNumber
port Int
val) =
    Text -> String
Text.unpack Text
addr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PortNumber -> String
forall a b. (Show a, ConvertText String b) => a -> b
show PortNumber
port String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

instance FromJSON RemoteAddress where
  parseJSON :: Value -> Parser RemoteAddress
parseJSON = String
-> (Object -> Parser RemoteAddress)
-> Value
-> Parser RemoteAddress
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RemoteAddress" ((Object -> Parser RemoteAddress) -> Value -> Parser RemoteAddress)
-> (Object -> Parser RemoteAddress)
-> Value
-> Parser RemoteAddress
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    Text -> PortNumber -> Int -> RemoteAddress
RemoteAddress
      (Text -> PortNumber -> Int -> RemoteAddress)
-> Parser Text -> Parser (PortNumber -> Int -> RemoteAddress)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"addr"
      Parser (PortNumber -> Int -> RemoteAddress)
-> Parser PortNumber -> Parser (Int -> RemoteAddress)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> PortNumber) (Int -> PortNumber) -> Parser Int -> Parser PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"port")
      Parser (Int -> RemoteAddress) -> Parser Int -> Parser RemoteAddress
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"valency"

instance ToJSON RemoteAddress where
  toJSON :: RemoteAddress -> Value
toJSON RemoteAddress
ra =
    [Pair] -> Value
object
      [ Text
"addr" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= RemoteAddress -> Text
raAddress RemoteAddress
ra
      , Text
"port" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (RemoteAddress -> PortNumber
raPort RemoteAddress
ra) :: Int)
      , Text
"valency" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= RemoteAddress -> Int
raValency RemoteAddress
ra
      ]

data NodeSetup = NodeSetup
  { NodeSetup -> Word64
nodeId :: !Word64
  , NodeSetup -> Maybe NodeIPv4Address
nodeIPv4Address :: !(Maybe NodeIPv4Address)
  , NodeSetup -> Maybe NodeIPv6Address
nodeIPv6Address :: !(Maybe NodeIPv6Address)
  , NodeSetup -> [RemoteAddress]
producers :: ![RemoteAddress]
  } deriving (NodeSetup -> NodeSetup -> Bool
(NodeSetup -> NodeSetup -> Bool)
-> (NodeSetup -> NodeSetup -> Bool) -> Eq NodeSetup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeSetup -> NodeSetup -> Bool
$c/= :: NodeSetup -> NodeSetup -> Bool
== :: NodeSetup -> NodeSetup -> Bool
$c== :: NodeSetup -> NodeSetup -> Bool
Eq, Int -> NodeSetup -> ShowS
[NodeSetup] -> ShowS
NodeSetup -> String
(Int -> NodeSetup -> ShowS)
-> (NodeSetup -> String)
-> ([NodeSetup] -> ShowS)
-> Show NodeSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeSetup] -> ShowS
$cshowList :: [NodeSetup] -> ShowS
show :: NodeSetup -> String
$cshow :: NodeSetup -> String
showsPrec :: Int -> NodeSetup -> ShowS
$cshowsPrec :: Int -> NodeSetup -> ShowS
Show)

instance FromJSON NodeSetup where
  parseJSON :: Value -> Parser NodeSetup
parseJSON = String -> (Object -> Parser NodeSetup) -> Value -> Parser NodeSetup
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NodeSetup" ((Object -> Parser NodeSetup) -> Value -> Parser NodeSetup)
-> (Object -> Parser NodeSetup) -> Value -> Parser NodeSetup
forall a b. (a -> b) -> a -> b
$ \Object
o ->
                Word64
-> Maybe NodeIPv4Address
-> Maybe NodeIPv6Address
-> [RemoteAddress]
-> NodeSetup
NodeSetup
                  (Word64
 -> Maybe NodeIPv4Address
 -> Maybe NodeIPv6Address
 -> [RemoteAddress]
 -> NodeSetup)
-> Parser Word64
-> Parser
     (Maybe NodeIPv4Address
      -> Maybe NodeIPv6Address -> [RemoteAddress] -> NodeSetup)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Word64
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"nodeId"
                  Parser
  (Maybe NodeIPv4Address
   -> Maybe NodeIPv6Address -> [RemoteAddress] -> NodeSetup)
-> Parser (Maybe NodeIPv4Address)
-> Parser (Maybe NodeIPv6Address -> [RemoteAddress] -> NodeSetup)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe NodeIPv4Address)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"nodeIPv4Address"
                  Parser (Maybe NodeIPv6Address -> [RemoteAddress] -> NodeSetup)
-> Parser (Maybe NodeIPv6Address)
-> Parser ([RemoteAddress] -> NodeSetup)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe NodeIPv6Address)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"nodeIPv6Address"
                  Parser ([RemoteAddress] -> NodeSetup)
-> Parser [RemoteAddress] -> Parser NodeSetup
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser [RemoteAddress]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"producers"

instance ToJSON NodeSetup where
  toJSON :: NodeSetup -> Value
toJSON NodeSetup
ns =
    [Pair] -> Value
object
      [ Text
"nodeId" Text -> Word64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= NodeSetup -> Word64
nodeId NodeSetup
ns
      , Text
"nodeIPv4Address" Text -> Maybe NodeIPv4Address -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= NodeSetup -> Maybe NodeIPv4Address
nodeIPv4Address NodeSetup
ns
      , Text
"nodeIPv6Address" Text -> Maybe NodeIPv6Address -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= NodeSetup -> Maybe NodeIPv6Address
nodeIPv6Address NodeSetup
ns
      , Text
"producers" Text -> [RemoteAddress] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= NodeSetup -> [RemoteAddress]
producers NodeSetup
ns
      ]

data NetworkTopology = MockNodeTopology ![NodeSetup]
                     | RealNodeTopology ![RemoteAddress]
  deriving (NetworkTopology -> NetworkTopology -> Bool
(NetworkTopology -> NetworkTopology -> Bool)
-> (NetworkTopology -> NetworkTopology -> Bool)
-> Eq NetworkTopology
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NetworkTopology -> NetworkTopology -> Bool
$c/= :: NetworkTopology -> NetworkTopology -> Bool
== :: NetworkTopology -> NetworkTopology -> Bool
$c== :: NetworkTopology -> NetworkTopology -> Bool
Eq, Int -> NetworkTopology -> ShowS
[NetworkTopology] -> ShowS
NetworkTopology -> String
(Int -> NetworkTopology -> ShowS)
-> (NetworkTopology -> String)
-> ([NetworkTopology] -> ShowS)
-> Show NetworkTopology
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NetworkTopology] -> ShowS
$cshowList :: [NetworkTopology] -> ShowS
show :: NetworkTopology -> String
$cshow :: NetworkTopology -> String
showsPrec :: Int -> NetworkTopology -> ShowS
$cshowsPrec :: Int -> NetworkTopology -> ShowS
Show)

instance FromJSON NetworkTopology where
  parseJSON :: Value -> Parser NetworkTopology
parseJSON = String
-> (Object -> Parser NetworkTopology)
-> Value
-> Parser NetworkTopology
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NetworkTopology" ((Object -> Parser NetworkTopology)
 -> Value -> Parser NetworkTopology)
-> (Object -> Parser NetworkTopology)
-> Value
-> Parser NetworkTopology
forall a b. (a -> b) -> a -> b
$ \Object
o -> [Parser NetworkTopology] -> Parser NetworkTopology
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
                [ [NodeSetup] -> NetworkTopology
MockNodeTopology ([NodeSetup] -> NetworkTopology)
-> Parser [NodeSetup] -> Parser NetworkTopology
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser [NodeSetup]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"MockProducers"
                , [RemoteAddress] -> NetworkTopology
RealNodeTopology ([RemoteAddress] -> NetworkTopology)
-> Parser [RemoteAddress] -> Parser NetworkTopology
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser [RemoteAddress]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Producers"
                ]

instance ToJSON NetworkTopology where
  toJSON :: NetworkTopology -> Value
toJSON NetworkTopology
top =
    case NetworkTopology
top of
      MockNodeTopology [NodeSetup]
nss -> [Pair] -> Value
object [ Text
"MockProducers" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [NodeSetup] -> Value
forall a. ToJSON a => a -> Value
toJSON [NodeSetup]
nss ]
      RealNodeTopology [RemoteAddress]
ras -> [Pair] -> Value
object [ Text
"Producers" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [RemoteAddress] -> Value
forall a. ToJSON a => a -> Value
toJSON [RemoteAddress]
ras ]

-- | Read the `NetworkTopology` configuration from the specified file.
-- While running a real protocol, this gives your node its own address and
-- other remote peers it will attempt to connect to.
readTopologyFile :: NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile :: NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile NodeConfiguration
nc = do
  Either IOException ByteString
eBs <- IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile (TopologyFile -> String
unTopology (TopologyFile -> String) -> TopologyFile -> String
forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> TopologyFile
ncTopologyFile NodeConfiguration
nc)

  case Either IOException ByteString
eBs of
    Left IOException
e -> Either Text NetworkTopology -> IO (Either Text NetworkTopology)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text NetworkTopology -> IO (Either Text NetworkTopology))
-> (Text -> Either Text NetworkTopology)
-> Text
-> IO (Either Text NetworkTopology)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Either Text NetworkTopology
forall a b. a -> Either a b
Left (Text -> IO (Either Text NetworkTopology))
-> Text -> IO (Either Text NetworkTopology)
forall a b. (a -> b) -> a -> b
$ IOException -> Text
handler IOException
e
    Right ByteString
bs -> Either Text NetworkTopology -> IO (Either Text NetworkTopology)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text NetworkTopology -> IO (Either Text NetworkTopology))
-> (ByteString -> Either Text NetworkTopology)
-> ByteString
-> IO (Either Text NetworkTopology)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (String -> Text)
-> Either String NetworkTopology -> Either Text NetworkTopology
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
handlerJSON (Either String NetworkTopology -> Either Text NetworkTopology)
-> (ByteString -> Either String NetworkTopology)
-> ByteString
-> Either Text NetworkTopology
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either String NetworkTopology
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> IO (Either Text NetworkTopology))
-> ByteString -> IO (Either Text NetworkTopology)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs

 where
  handler :: IOException -> Text
  handler :: IOException -> Text
handler IOException
e = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Bcc.Node.Configuration.Topology.readTopologyFile: "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall e. Exception e => e -> String
displayException IOException
e
  handlerJSON :: String -> Text
  handlerJSON :: String -> Text
handlerJSON String
err = Text
"Is your topology file formatted correctly? \
                    \The port and valency fields should be numerical. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err