{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Asynchronous messaging interface to the Hydra Network, e.g to other Hydra nodes.
--
-- Concrete implementations are
-- provided by submodules. Import those instead of this one if interested in
-- actually configuring and running a real network layer.
--
-- Incoming and outgoing messages are modelled as 'Message' data type.
module Hydra.Network (
  -- * Types
  Network (..),
  NetworkCallback (..),
  NetworkComponent,
  IP,
  Host (..),
  NodeId (..),
  showHost,
  readHost,
  PortNumber,
  readPort,

  -- * Utility functions
  close,
) where

import Hydra.Prelude hiding (show)

import Cardano.Ledger.Orphans ()
import Data.IP (IP, toIPv4w)
import Data.Text (pack, unpack)
import Network.Socket (PortNumber, close)
import Network.TypedProtocol.Pipelined ()
import Test.QuickCheck (elements, listOf, suchThat)
import Text.Read (Read (readsPrec))
import Text.Show (Show (show))

deriving anyclass instance ToJSON IP
deriving anyclass instance FromJSON IP

-- * Hydra network interface

-- | Interface from the application to the network layer.
newtype Network m msg = Network
  { forall (m :: * -> *) msg. Network m msg -> msg -> m ()
broadcast :: msg -> m ()
  -- ^ Send a `msg` to the whole configured hydra network including ourselves.
  }

instance Contravariant (Network m) where
  contramap :: forall a' a. (a' -> a) -> Network m a -> Network m a'
contramap a' -> a
f (Network a -> m ()
bcast) = (a' -> m ()) -> Network m a'
forall (m :: * -> *) msg. (msg -> m ()) -> Network m msg
Network ((a' -> m ()) -> Network m a') -> (a' -> m ()) -> Network m a'
forall a b. (a -> b) -> a -> b
$ \a'
msg -> a -> m ()
bcast (a' -> a
f a'
msg)

-- | Interface from network layer to the application.
-- XXX: Reliably delivering a message in the crash-recovery fault model is
-- tricky. According to "Introduction to Reliable and Secure Distributed
-- Programming" section "2.2.4 Crashes with recoveries" explains that storing to
-- stable storage and just pointing to stored events is a better way.
newtype NetworkCallback msg m = NetworkCallback
  { forall msg (m :: * -> *). NetworkCallback msg m -> msg -> m ()
deliver :: msg -> m ()
  -- ^ The given `msg` was received from the network.
  }

-- | A type tying both inbound and outbound messages sending in a single /Component/.
--
-- A `NetworkComponent` can have different inbound and outbound message types.
type NetworkComponent m inbound outbound a = NetworkCallback inbound m -> (Network m outbound -> m a) -> m a

-- * Types used by concrete implementations

-- ** PortNumber (Orphans)

instance ToJSON PortNumber where
  toJSON :: PortNumber -> Value
toJSON = Integer -> Value
forall a. ToJSON a => a -> Value
toJSON (Integer -> Value)
-> (PortNumber -> Integer) -> PortNumber -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> Integer
forall a. Integral a => a -> Integer
toInteger

instance FromJSON PortNumber where
  parseJSON :: Value -> Parser PortNumber
parseJSON = (Integer -> PortNumber) -> Parser Integer -> Parser PortNumber
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Parser Integer -> Parser PortNumber)
-> (Value -> Parser Integer) -> Value -> Parser PortNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Integer
forall a. FromJSON a => Value -> Parser a
parseJSON

instance Arbitrary PortNumber where
  arbitrary :: Gen PortNumber
arbitrary = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 (Word16 -> PortNumber) -> Gen Word16 -> Gen PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word16
forall a. Arbitrary a => Gen a
arbitrary

instance ToCBOR PortNumber where
  toCBOR :: PortNumber -> Encoding
toCBOR = Integer -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Integer -> Encoding)
-> (PortNumber -> Integer) -> PortNumber -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> Integer
forall a. Integral a => a -> Integer
toInteger

instance FromCBOR PortNumber where
  fromCBOR :: forall s. Decoder s PortNumber
fromCBOR = (Integer -> PortNumber)
-> Decoder s Integer -> Decoder s PortNumber
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR

newtype NodeId = NodeId {NodeId -> Text
nodeId :: Text}
  deriving newtype (NodeId -> NodeId -> Bool
(NodeId -> NodeId -> Bool)
-> (NodeId -> NodeId -> Bool) -> Eq NodeId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeId -> NodeId -> Bool
== :: NodeId -> NodeId -> Bool
$c/= :: NodeId -> NodeId -> Bool
/= :: NodeId -> NodeId -> Bool
Eq, Int -> NodeId -> ShowS
[NodeId] -> ShowS
NodeId -> String
(Int -> NodeId -> ShowS)
-> (NodeId -> String) -> ([NodeId] -> ShowS) -> Show NodeId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeId -> ShowS
showsPrec :: Int -> NodeId -> ShowS
$cshow :: NodeId -> String
show :: NodeId -> String
$cshowList :: [NodeId] -> ShowS
showList :: [NodeId] -> ShowS
Show, String -> NodeId
(String -> NodeId) -> IsString NodeId
forall a. (String -> a) -> IsString a
$cfromString :: String -> NodeId
fromString :: String -> NodeId
IsString, ReadPrec [NodeId]
ReadPrec NodeId
Int -> ReadS NodeId
ReadS [NodeId]
(Int -> ReadS NodeId)
-> ReadS [NodeId]
-> ReadPrec NodeId
-> ReadPrec [NodeId]
-> Read NodeId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS NodeId
readsPrec :: Int -> ReadS NodeId
$creadList :: ReadS [NodeId]
readList :: ReadS [NodeId]
$creadPrec :: ReadPrec NodeId
readPrec :: ReadPrec NodeId
$creadListPrec :: ReadPrec [NodeId]
readListPrec :: ReadPrec [NodeId]
Read, Eq NodeId
Eq NodeId =>
(NodeId -> NodeId -> Ordering)
-> (NodeId -> NodeId -> Bool)
-> (NodeId -> NodeId -> Bool)
-> (NodeId -> NodeId -> Bool)
-> (NodeId -> NodeId -> Bool)
-> (NodeId -> NodeId -> NodeId)
-> (NodeId -> NodeId -> NodeId)
-> Ord NodeId
NodeId -> NodeId -> Bool
NodeId -> NodeId -> Ordering
NodeId -> NodeId -> NodeId
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
$ccompare :: NodeId -> NodeId -> Ordering
compare :: NodeId -> NodeId -> Ordering
$c< :: NodeId -> NodeId -> Bool
< :: NodeId -> NodeId -> Bool
$c<= :: NodeId -> NodeId -> Bool
<= :: NodeId -> NodeId -> Bool
$c> :: NodeId -> NodeId -> Bool
> :: NodeId -> NodeId -> Bool
$c>= :: NodeId -> NodeId -> Bool
>= :: NodeId -> NodeId -> Bool
$cmax :: NodeId -> NodeId -> NodeId
max :: NodeId -> NodeId -> NodeId
$cmin :: NodeId -> NodeId -> NodeId
min :: NodeId -> NodeId -> NodeId
Ord, [NodeId] -> Value
[NodeId] -> Encoding
NodeId -> Bool
NodeId -> Value
NodeId -> Encoding
(NodeId -> Value)
-> (NodeId -> Encoding)
-> ([NodeId] -> Value)
-> ([NodeId] -> Encoding)
-> (NodeId -> Bool)
-> ToJSON NodeId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: NodeId -> Value
toJSON :: NodeId -> Value
$ctoEncoding :: NodeId -> Encoding
toEncoding :: NodeId -> Encoding
$ctoJSONList :: [NodeId] -> Value
toJSONList :: [NodeId] -> Value
$ctoEncodingList :: [NodeId] -> Encoding
toEncodingList :: [NodeId] -> Encoding
$comitField :: NodeId -> Bool
omitField :: NodeId -> Bool
ToJSON, Maybe NodeId
Value -> Parser [NodeId]
Value -> Parser NodeId
(Value -> Parser NodeId)
-> (Value -> Parser [NodeId]) -> Maybe NodeId -> FromJSON NodeId
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser NodeId
parseJSON :: Value -> Parser NodeId
$cparseJSONList :: Value -> Parser [NodeId]
parseJSONList :: Value -> Parser [NodeId]
$comittedField :: Maybe NodeId
omittedField :: Maybe NodeId
FromJSON)

instance Arbitrary NodeId where
  arbitrary :: Gen NodeId
arbitrary =
    Text -> NodeId
NodeId (Text -> NodeId) -> (String -> Text) -> String -> NodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> NodeId) -> Gen String -> Gen NodeId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String -> (String -> Bool) -> Gen String
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat (Gen Char -> Gen String
forall a. Gen a -> Gen [a]
listOf (String -> Gen Char
forall a. HasCallStack => [a] -> Gen a
elements [Char
'a' .. Char
'z'])) (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)

-- return $ NodeId $ pack c

instance FromCBOR NodeId where
  fromCBOR :: forall s. Decoder s NodeId
fromCBOR = Text -> NodeId
NodeId (Text -> NodeId) -> Decoder s Text -> Decoder s NodeId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance ToCBOR NodeId where
  toCBOR :: NodeId -> Encoding
toCBOR NodeId{Text
$sel:nodeId:NodeId :: NodeId -> Text
nodeId :: Text
nodeId} = Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Text
nodeId

-- ** Host

-- REVIEW(SN): This is also used in hydra-tui
data Host = Host
  { Host -> Text
hostname :: Text
  , Host -> PortNumber
port :: PortNumber
  }
  deriving stock (Eq Host
Eq Host =>
(Host -> Host -> Ordering)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Bool)
-> (Host -> Host -> Host)
-> (Host -> Host -> Host)
-> Ord Host
Host -> Host -> Bool
Host -> Host -> Ordering
Host -> Host -> Host
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
$ccompare :: Host -> Host -> Ordering
compare :: Host -> Host -> Ordering
$c< :: Host -> Host -> Bool
< :: Host -> Host -> Bool
$c<= :: Host -> Host -> Bool
<= :: Host -> Host -> Bool
$c> :: Host -> Host -> Bool
> :: Host -> Host -> Bool
$c>= :: Host -> Host -> Bool
>= :: Host -> Host -> Bool
$cmax :: Host -> Host -> Host
max :: Host -> Host -> Host
$cmin :: Host -> Host -> Host
min :: Host -> Host -> Host
Ord, (forall x. Host -> Rep Host x)
-> (forall x. Rep Host x -> Host) -> Generic Host
forall x. Rep Host x -> Host
forall x. Host -> Rep Host x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Host -> Rep Host x
from :: forall x. Host -> Rep Host x
$cto :: forall x. Rep Host x -> Host
to :: forall x. Rep Host x -> Host
Generic, Host -> Host -> Bool
(Host -> Host -> Bool) -> (Host -> Host -> Bool) -> Eq Host
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Host -> Host -> Bool
== :: Host -> Host -> Bool
$c/= :: Host -> Host -> Bool
/= :: Host -> Host -> Bool
Eq)
  deriving anyclass ([Host] -> Value
[Host] -> Encoding
Host -> Bool
Host -> Value
Host -> Encoding
(Host -> Value)
-> (Host -> Encoding)
-> ([Host] -> Value)
-> ([Host] -> Encoding)
-> (Host -> Bool)
-> ToJSON Host
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Host -> Value
toJSON :: Host -> Value
$ctoEncoding :: Host -> Encoding
toEncoding :: Host -> Encoding
$ctoJSONList :: [Host] -> Value
toJSONList :: [Host] -> Value
$ctoEncodingList :: [Host] -> Encoding
toEncodingList :: [Host] -> Encoding
$comitField :: Host -> Bool
omitField :: Host -> Bool
ToJSON, Maybe Host
Value -> Parser [Host]
Value -> Parser Host
(Value -> Parser Host)
-> (Value -> Parser [Host]) -> Maybe Host -> FromJSON Host
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Host
parseJSON :: Value -> Parser Host
$cparseJSONList :: Value -> Parser [Host]
parseJSONList :: Value -> Parser [Host]
$comittedField :: Maybe Host
omittedField :: Maybe Host
FromJSON)

instance Show Host where
  show :: Host -> String
show = Host -> String
showHost

instance Read Host where
  readsPrec :: Int -> ReadS Host
readsPrec Int
_ String
s = case String -> Maybe Host
forall (m :: * -> *). MonadFail m => String -> m Host
readHost String
s of
    Just Host
h -> [(Host
h, String
"")]
    Maybe Host
Nothing -> []

instance Arbitrary Host where
  arbitrary :: Gen Host
arbitrary = do
    IPv4
ip <- Word32 -> IPv4
toIPv4w (Word32 -> IPv4) -> Gen Word32 -> Gen IPv4
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
    Text -> PortNumber -> Host
Host (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IPv4 -> String
forall a. Show a => a -> String
show IPv4
ip) (PortNumber -> Host) -> Gen PortNumber -> Gen Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen PortNumber
forall a. Arbitrary a => Gen a
arbitrary

instance ToCBOR Host where
  toCBOR :: Host -> Encoding
toCBOR Host{Text
$sel:hostname:Host :: Host -> Text
hostname :: Text
hostname, PortNumber
$sel:port:Host :: Host -> PortNumber
port :: PortNumber
port} =
    [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
      [ Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Text
hostname
      , PortNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PortNumber
port
      ]

instance FromCBOR Host where
  fromCBOR :: forall s. Decoder s Host
fromCBOR =
    Text -> PortNumber -> Host
Host
      (Text -> PortNumber -> Host)
-> Decoder s Text -> Decoder s (PortNumber -> Host)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (PortNumber -> Host)
-> Decoder s PortNumber -> Decoder s Host
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber)
-> Decoder s Integer -> Decoder s PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
forall a s. FromCBOR a => Decoder s a
fromCBOR)

showHost :: Host -> String
showHost :: Host -> String
showHost Host{Text
$sel:hostname:Host :: Host -> Text
hostname :: Text
hostname, PortNumber
$sel:port:Host :: Host -> PortNumber
port :: PortNumber
port} =
  Text -> String
unpack Text
hostname String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port

readHost :: MonadFail m => String -> m Host
readHost :: forall (m :: * -> *). MonadFail m => String -> m Host
readHost String
s =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
s of
    (String
h, Char
':' : String
p) -> Text -> PortNumber -> Host
Host (String -> Text
pack String
h) (PortNumber -> Host) -> m PortNumber -> m Host
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m PortNumber
forall (m :: * -> *). MonadFail m => String -> m PortNumber
readPort String
p
    (String, String)
_ -> String -> m Host
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Host) -> String -> m Host
forall a b. (a -> b) -> a -> b
$ String
"readHost: missing : in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s

readPort :: MonadFail m => String -> m PortNumber
readPort :: forall (m :: * -> *). MonadFail m => String -> m PortNumber
readPort String
s =
  case String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe String
s of
    Maybe Integer
Nothing -> String -> m PortNumber
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot read port"
    Just Integer
n
      | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
minPort Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxPort -> PortNumber -> m PortNumber
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PortNumber -> m PortNumber) -> PortNumber -> m PortNumber
forall a b. (a -> b) -> a -> b
$ Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger Integer
n
      | Bool
otherwise ->
          String -> m PortNumber
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m PortNumber) -> String -> m PortNumber
forall a b. (a -> b) -> a -> b
$
            String
"readPort: "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
n
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" not within valid port range: ("
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
minPort
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
maxPort
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
 where
  maxPort :: Integer
maxPort = Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16)
  minPort :: Integer
minPort = Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
minBound :: Word16)