{-# LANGUAGE UndecidableInstances #-}

module Hydra.Network.Message where

import Hydra.Prelude

import Cardano.Binary (serialize')
import Cardano.Crypto.Util (SignableRepresentation, getSignableRepresentation)
import Hydra.Network (Connectivity)
import Hydra.Tx (
  IsTx (TxIdType),
  Party,
  Snapshot,
  SnapshotNumber,
  SnapshotVersion,
  UTxOType,
 )
import Hydra.Tx.Crypto (Signature)
import Hydra.Tx.IsTx (ArbitraryIsTx)

data NetworkEvent msg
  = ConnectivityEvent Connectivity
  | ReceivedMessage {forall msg. NetworkEvent msg -> Party
sender :: Party, forall msg. NetworkEvent msg -> msg
msg :: msg}
  deriving stock (NetworkEvent msg -> NetworkEvent msg -> Bool
(NetworkEvent msg -> NetworkEvent msg -> Bool)
-> (NetworkEvent msg -> NetworkEvent msg -> Bool)
-> Eq (NetworkEvent msg)
forall msg. Eq msg => NetworkEvent msg -> NetworkEvent msg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall msg. Eq msg => NetworkEvent msg -> NetworkEvent msg -> Bool
== :: NetworkEvent msg -> NetworkEvent msg -> Bool
$c/= :: forall msg. Eq msg => NetworkEvent msg -> NetworkEvent msg -> Bool
/= :: NetworkEvent msg -> NetworkEvent msg -> Bool
Eq, Int -> NetworkEvent msg -> ShowS
[NetworkEvent msg] -> ShowS
NetworkEvent msg -> String
(Int -> NetworkEvent msg -> ShowS)
-> (NetworkEvent msg -> String)
-> ([NetworkEvent msg] -> ShowS)
-> Show (NetworkEvent msg)
forall msg. Show msg => Int -> NetworkEvent msg -> ShowS
forall msg. Show msg => [NetworkEvent msg] -> ShowS
forall msg. Show msg => NetworkEvent msg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall msg. Show msg => Int -> NetworkEvent msg -> ShowS
showsPrec :: Int -> NetworkEvent msg -> ShowS
$cshow :: forall msg. Show msg => NetworkEvent msg -> String
show :: NetworkEvent msg -> String
$cshowList :: forall msg. Show msg => [NetworkEvent msg] -> ShowS
showList :: [NetworkEvent msg] -> ShowS
Show, (forall x. NetworkEvent msg -> Rep (NetworkEvent msg) x)
-> (forall x. Rep (NetworkEvent msg) x -> NetworkEvent msg)
-> Generic (NetworkEvent msg)
forall x. Rep (NetworkEvent msg) x -> NetworkEvent msg
forall x. NetworkEvent msg -> Rep (NetworkEvent msg) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall msg x. Rep (NetworkEvent msg) x -> NetworkEvent msg
forall msg x. NetworkEvent msg -> Rep (NetworkEvent msg) x
$cfrom :: forall msg x. NetworkEvent msg -> Rep (NetworkEvent msg) x
from :: forall x. NetworkEvent msg -> Rep (NetworkEvent msg) x
$cto :: forall msg x. Rep (NetworkEvent msg) x -> NetworkEvent msg
to :: forall x. Rep (NetworkEvent msg) x -> NetworkEvent msg
Generic)
  deriving anyclass ([NetworkEvent msg] -> Value
[NetworkEvent msg] -> Encoding
NetworkEvent msg -> Bool
NetworkEvent msg -> Value
NetworkEvent msg -> Encoding
(NetworkEvent msg -> Value)
-> (NetworkEvent msg -> Encoding)
-> ([NetworkEvent msg] -> Value)
-> ([NetworkEvent msg] -> Encoding)
-> (NetworkEvent msg -> Bool)
-> ToJSON (NetworkEvent msg)
forall msg. ToJSON msg => [NetworkEvent msg] -> Value
forall msg. ToJSON msg => [NetworkEvent msg] -> Encoding
forall msg. ToJSON msg => NetworkEvent msg -> Bool
forall msg. ToJSON msg => NetworkEvent msg -> Value
forall msg. ToJSON msg => NetworkEvent msg -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall msg. ToJSON msg => NetworkEvent msg -> Value
toJSON :: NetworkEvent msg -> Value
$ctoEncoding :: forall msg. ToJSON msg => NetworkEvent msg -> Encoding
toEncoding :: NetworkEvent msg -> Encoding
$ctoJSONList :: forall msg. ToJSON msg => [NetworkEvent msg] -> Value
toJSONList :: [NetworkEvent msg] -> Value
$ctoEncodingList :: forall msg. ToJSON msg => [NetworkEvent msg] -> Encoding
toEncodingList :: [NetworkEvent msg] -> Encoding
$comitField :: forall msg. ToJSON msg => NetworkEvent msg -> Bool
omitField :: NetworkEvent msg -> Bool
ToJSON)

instance Arbitrary msg => Arbitrary (NetworkEvent msg) where
  arbitrary :: Gen (NetworkEvent msg)
arbitrary = Gen (NetworkEvent msg)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

data Message tx
  = ReqTx {forall tx. Message tx -> tx
transaction :: tx}
  | ReqSn
      { forall tx. Message tx -> SnapshotVersion
snapshotVersion :: SnapshotVersion
      , forall tx. Message tx -> SnapshotNumber
snapshotNumber :: SnapshotNumber
      , forall tx. Message tx -> [TxIdType tx]
transactionIds :: [TxIdType tx]
      , forall tx. Message tx -> Maybe tx
decommitTx :: Maybe tx
      , forall tx. Message tx -> Maybe (UTxOType tx)
incrementUTxO :: Maybe (UTxOType tx)
      }
  | AckSn
      { forall tx. Message tx -> Signature (Snapshot tx)
signed :: Signature (Snapshot tx)
      , snapshotNumber :: SnapshotNumber
      }
  | ReqDec {transaction :: tx}
  deriving stock ((forall x. Message tx -> Rep (Message tx) x)
-> (forall x. Rep (Message tx) x -> Message tx)
-> Generic (Message tx)
forall x. Rep (Message tx) x -> Message tx
forall x. Message tx -> Rep (Message tx) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall tx x. Rep (Message tx) x -> Message tx
forall tx x. Message tx -> Rep (Message tx) x
$cfrom :: forall tx x. Message tx -> Rep (Message tx) x
from :: forall x. Message tx -> Rep (Message tx) x
$cto :: forall tx x. Rep (Message tx) x -> Message tx
to :: forall x. Rep (Message tx) x -> Message tx
Generic)

deriving stock instance IsTx tx => Eq (Message tx)
deriving stock instance IsTx tx => Show (Message tx)
deriving anyclass instance IsTx tx => ToJSON (Message tx)
deriving anyclass instance IsTx tx => FromJSON (Message tx)

instance ArbitraryIsTx tx => Arbitrary (Message tx) where
  arbitrary :: Gen (Message tx)
arbitrary = Gen (Message tx)
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary

instance (ToCBOR tx, ToCBOR (UTxOType tx), ToCBOR (TxIdType tx)) => ToCBOR (Message tx) where
  toCBOR :: Message tx -> Encoding
toCBOR = \case
    ReqTx tx
tx -> Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"ReqTx" :: Text) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR tx
tx
    ReqSn SnapshotVersion
sv SnapshotNumber
sn [TxIdType tx]
txs Maybe tx
decommitTx Maybe (UTxOType tx)
incrementUTxO -> Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"ReqSn" :: Text) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapshotVersion -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SnapshotVersion
sv Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapshotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SnapshotNumber
sn Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [TxIdType tx] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR [TxIdType tx]
txs Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Maybe tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Maybe tx
decommitTx Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Maybe (UTxOType tx) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Maybe (UTxOType tx)
incrementUTxO
    AckSn Signature (Snapshot tx)
sig SnapshotNumber
sn -> Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"AckSn" :: Text) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Signature (Snapshot tx) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Signature (Snapshot tx)
sig Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapshotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SnapshotNumber
sn
    ReqDec tx
utxo -> Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Text
"ReqDec" :: Text) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> tx -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR tx
utxo

instance (FromCBOR tx, FromCBOR (UTxOType tx), FromCBOR (TxIdType tx)) => FromCBOR (Message tx) where
  fromCBOR :: forall s. Decoder s (Message tx)
fromCBOR =
    Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s Text
-> (Text -> Decoder s (Message tx)) -> Decoder s (Message tx)
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Text
"ReqTx" :: Text) -> tx -> Message tx
forall tx. tx -> Message tx
ReqTx (tx -> Message tx) -> Decoder s tx -> Decoder s (Message tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s tx
forall s. Decoder s tx
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Text
"ReqSn" -> SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (UTxOType tx)
-> Message tx
forall tx.
SnapshotVersion
-> SnapshotNumber
-> [TxIdType tx]
-> Maybe tx
-> Maybe (UTxOType tx)
-> Message tx
ReqSn (SnapshotVersion
 -> SnapshotNumber
 -> [TxIdType tx]
 -> Maybe tx
 -> Maybe (UTxOType tx)
 -> Message tx)
-> Decoder s SnapshotVersion
-> Decoder
     s
     (SnapshotNumber
      -> [TxIdType tx] -> Maybe tx -> Maybe (UTxOType tx) -> Message tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SnapshotVersion
forall s. Decoder s SnapshotVersion
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder
  s
  (SnapshotNumber
   -> [TxIdType tx] -> Maybe tx -> Maybe (UTxOType tx) -> Message tx)
-> Decoder s SnapshotNumber
-> Decoder
     s ([TxIdType tx] -> Maybe tx -> Maybe (UTxOType tx) -> Message tx)
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
<*> Decoder s SnapshotNumber
forall s. Decoder s SnapshotNumber
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder
  s ([TxIdType tx] -> Maybe tx -> Maybe (UTxOType tx) -> Message tx)
-> Decoder s [TxIdType tx]
-> Decoder s (Maybe tx -> Maybe (UTxOType tx) -> Message tx)
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
<*> Decoder s [TxIdType tx]
forall s. Decoder s [TxIdType tx]
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (Maybe tx -> Maybe (UTxOType tx) -> Message tx)
-> Decoder s (Maybe tx)
-> Decoder s (Maybe (UTxOType tx) -> Message tx)
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
<*> Decoder s (Maybe tx)
forall s. Decoder s (Maybe tx)
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (Maybe (UTxOType tx) -> Message tx)
-> Decoder s (Maybe (UTxOType tx)) -> Decoder s (Message tx)
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
<*> Decoder s (Maybe (UTxOType tx))
forall s. Decoder s (Maybe (UTxOType tx))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Text
"AckSn" -> Signature (Snapshot tx) -> SnapshotNumber -> Message tx
forall tx. Signature (Snapshot tx) -> SnapshotNumber -> Message tx
AckSn (Signature (Snapshot tx) -> SnapshotNumber -> Message tx)
-> Decoder s (Signature (Snapshot tx))
-> Decoder s (SnapshotNumber -> Message tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Signature (Snapshot tx))
forall s. Decoder s (Signature (Snapshot tx))
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s (SnapshotNumber -> Message tx)
-> Decoder s SnapshotNumber -> Decoder s (Message tx)
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
<*> Decoder s SnapshotNumber
forall s. Decoder s SnapshotNumber
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Text
"ReqDec" -> tx -> Message tx
forall tx. tx -> Message tx
ReqDec (tx -> Message tx) -> Decoder s tx -> Decoder s (Message tx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s tx
forall s. Decoder s tx
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Text
msg -> String -> Decoder s (Message tx)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (Message tx))
-> String -> Decoder s (Message tx)
forall a b. (a -> b) -> a -> b
$ Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a proper CBOR-encoded Message"

instance IsTx tx => SignableRepresentation (Message tx) where
  getSignableRepresentation :: Message tx -> ByteString
getSignableRepresentation = Message tx -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize'