{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Serialisation for sending things across the network.
--
-- We separate @NodeToNode@ from @NodeToClient@ to be very explicit about what
-- gets sent where.
--
-- Unlike in "Ouroboros.Consensus.Storage.Serialisation", we don't separate the
-- encoder from the decoder, because the reasons don't apply: we always need
-- both directions and we don't have access to the bytestrings that could be
-- used for the annotations (we use CBOR-in-CBOR in those cases).
module Ouroboros.Consensus.Node.Serialisation
  ( SerialiseBlockQueryResult (..)
  , SerialiseNodeToClient (..)
  , SerialiseNodeToNode (..)
  , SerialiseResult (..)

    -- * Defaults
  , defaultDecodeCBORinCBOR
  , defaultEncodeCBORinCBOR

    -- * Re-exported for convenience
  , Some (..)
  ) where

import qualified Cardano.Binary as KeyHash
import Codec.CBOR.Decoding (Decoder, decodeListLenOf)
import Codec.CBOR.Encoding (Encoding, encodeListLen)
import Codec.Serialise (Serialise (decode, encode))
import Data.Kind
import Data.SOP.BasicFunctors
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
  ( ApplyTxErr
  , GenTxId
  )
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.TypeFamilyWrappers
import Ouroboros.Consensus.Util (Some (..))
import Ouroboros.Network.Block
  ( Tip
  , decodePoint
  , decodeTip
  , encodePoint
  , encodeTip
  , unwrapCBORinCBOR
  , wrapCBORinCBOR
  )

{-------------------------------------------------------------------------------
  NodeToNode
-------------------------------------------------------------------------------}

-- | Serialise a type @a@ so that it can be sent across network via a
-- node-to-node protocol.
class SerialiseNodeToNode blk a where
  encodeNodeToNode :: CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
  decodeNodeToNode :: CodecConfig blk -> BlockNodeToNodeVersion blk -> forall s. Decoder s a

  -- When the config is not needed, we provide a default, unversioned
  -- implementation using 'Serialise'

  default encodeNodeToNode ::
    Serialise a =>
    CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
  encodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = a -> Encoding
forall a. Serialise a => a -> Encoding
encode

  default decodeNodeToNode ::
    Serialise a =>
    CodecConfig blk -> BlockNodeToNodeVersion blk -> forall s. Decoder s a
  decodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = Decoder s a
forall s. Decoder s a
forall a s. Serialise a => Decoder s a
decode

{-------------------------------------------------------------------------------
  NodeToClient
-------------------------------------------------------------------------------}

-- | Serialise a type @a@ so that it can be sent across the network via
-- node-to-client protocol.
class SerialiseNodeToClient blk a where
  encodeNodeToClient :: CodecConfig blk -> BlockNodeToClientVersion blk -> a -> Encoding
  decodeNodeToClient :: CodecConfig blk -> BlockNodeToClientVersion blk -> forall s. Decoder s a

  -- When the config is not needed, we provide a default, unversioned
  -- implementation using 'Serialise'

  default encodeNodeToClient ::
    Serialise a =>
    CodecConfig blk -> BlockNodeToClientVersion blk -> a -> Encoding
  encodeNodeToClient CodecConfig blk
_ccfg BlockNodeToClientVersion blk
_version = a -> Encoding
forall a. Serialise a => a -> Encoding
encode

  default decodeNodeToClient ::
    Serialise a =>
    CodecConfig blk -> BlockNodeToClientVersion blk -> forall s. Decoder s a
  decodeNodeToClient CodecConfig blk
_ccfg BlockNodeToClientVersion blk
_version = Decoder s a
forall s. Decoder s a
forall a s. Serialise a => Decoder s a
decode

{-------------------------------------------------------------------------------
  NodeToClient - SerialiseResult
-------------------------------------------------------------------------------}

-- | How to serialise the @result@ of a query.
--
-- The @LocalStateQuery@ protocol is a node-to-client protocol, hence the
-- 'NodeToClientVersion' argument.
type SerialiseResult :: Type -> (Type -> Type -> Type) -> Constraint
class SerialiseResult blk query where
  encodeResult ::
    forall result.
    CodecConfig blk ->
    BlockNodeToClientVersion blk ->
    query blk result ->
    result ->
    Encoding
  decodeResult ::
    forall result.
    CodecConfig blk ->
    BlockNodeToClientVersion blk ->
    query blk result ->
    forall s.
    Decoder s result

-- | How to serialise the @result@ of a block query.
--
-- The @LocalStateQuery@ protocol is a node-to-client protocol, hence the
-- 'NodeToClientVersion' argument.
type SerialiseBlockQueryResult :: Type -> (Type -> k -> Type -> Type) -> Constraint
class SerialiseBlockQueryResult blk query where
  encodeBlockQueryResult ::
    forall fp result.
    CodecConfig blk ->
    BlockNodeToClientVersion blk ->
    query blk fp result ->
    result ->
    Encoding
  decodeBlockQueryResult ::
    forall fp result.
    CodecConfig blk ->
    BlockNodeToClientVersion blk ->
    query blk fp result ->
    forall s.
    Decoder s result

{-------------------------------------------------------------------------------
  Defaults
-------------------------------------------------------------------------------}

-- | Uses the 'Serialise' instance, but wraps it in CBOR-in-CBOR.
--
-- Use this for the 'SerialiseNodeToNode' and/or 'SerialiseNodeToClient'
-- instance of @blk@ and/or @'Header' blk@, which require CBOR-in-CBOR to be
-- compatible with the corresponding 'Serialised' instance.
defaultEncodeCBORinCBOR :: Serialise a => a -> Encoding
defaultEncodeCBORinCBOR :: forall a. Serialise a => a -> Encoding
defaultEncodeCBORinCBOR = (a -> Encoding) -> a -> Encoding
forall a. (a -> Encoding) -> a -> Encoding
wrapCBORinCBOR a -> Encoding
forall a. Serialise a => a -> Encoding
encode

-- | Inverse of 'defaultEncodeCBORinCBOR'
defaultDecodeCBORinCBOR :: Serialise a => Decoder s a
defaultDecodeCBORinCBOR :: forall a s. Serialise a => Decoder s a
defaultDecodeCBORinCBOR = (forall s. Decoder s (ByteString -> Either DecoderError a))
-> forall s. Decoder s a
forall a.
(forall s. Decoder s (ByteString -> Either DecoderError a))
-> forall s. Decoder s a
unwrapCBORinCBOR (Either DecoderError a -> ByteString -> Either DecoderError a
forall a b. a -> b -> a
const (Either DecoderError a -> ByteString -> Either DecoderError a)
-> (a -> Either DecoderError a)
-> a
-> ByteString
-> Either DecoderError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either DecoderError a
forall a b. b -> Either a b
Right (a -> ByteString -> Either DecoderError a)
-> Decoder s a -> Decoder s (ByteString -> Either DecoderError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
forall s. Decoder s a
forall a s. Serialise a => Decoder s a
decode)

{-------------------------------------------------------------------------------
  Forwarding instances
-------------------------------------------------------------------------------}

deriving newtype instance
  SerialiseNodeToNode blk blk =>
  SerialiseNodeToNode blk (I blk)

deriving newtype instance
  SerialiseNodeToClient blk blk =>
  SerialiseNodeToClient blk (I blk)

deriving newtype instance
  SerialiseNodeToNode blk (GenTxId blk) =>
  SerialiseNodeToNode blk (WrapGenTxId blk)

instance ConvertRawHash blk => SerialiseNodeToNode blk (Point blk) where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> Point blk -> Encoding
encodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = (HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall {k} (block :: k).
(HeaderHash block -> Encoding) -> Point block -> Encoding
encodePoint ((HeaderHash blk -> Encoding) -> Point blk -> Encoding)
-> (HeaderHash blk -> Encoding) -> Point blk -> Encoding
forall a b. (a -> b) -> a -> b
$ Proxy blk -> HeaderHash blk -> Encoding
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s (Point blk)
decodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall {k} (block :: k).
(forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Point block)
decodePoint ((forall s. Decoder s (HeaderHash blk))
 -> forall s. Decoder s (Point blk))
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Point blk)
forall a b. (a -> b) -> a -> b
$ Proxy blk -> forall s. Decoder s (HeaderHash blk)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

instance ConvertRawHash blk => SerialiseNodeToNode blk (Tip blk) where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> Tip blk -> Encoding
encodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = (HeaderHash blk -> Encoding) -> Tip blk -> Encoding
forall {k} (blk :: k).
(HeaderHash blk -> Encoding) -> Tip blk -> Encoding
encodeTip ((HeaderHash blk -> Encoding) -> Tip blk -> Encoding)
-> (HeaderHash blk -> Encoding) -> Tip blk -> Encoding
forall a b. (a -> b) -> a -> b
$ Proxy blk -> HeaderHash blk -> Encoding
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> Encoding
encodeRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s (Tip blk)
decodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
forall {k} (blk :: k).
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
decodeTip ((forall s. Decoder s (HeaderHash blk))
 -> forall s. Decoder s (Tip blk))
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
forall a b. (a -> b) -> a -> b
$ Proxy blk -> forall s. Decoder s (HeaderHash blk)
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> forall s. Decoder s (HeaderHash blk)
decodeRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

instance SerialiseNodeToNode blk PerasRoundNo where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasRoundNo -> Encoding
encodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = PerasRoundNo -> Encoding
forall a. Serialise a => a -> Encoding
encode
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s PerasRoundNo
decodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = Decoder s PerasRoundNo
forall s. Decoder s PerasRoundNo
forall a s. Serialise a => Decoder s a
decode

instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where
  -- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasCert blk -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version PerasCert{Point blk
PerasRoundNo
pcCertRound :: PerasRoundNo
pcCertBoostedBlock :: Point blk
pcCertBoostedBlock :: forall blk. PerasCert blk -> Point blk
pcCertRound :: forall blk. PerasCert blk -> PerasRoundNo
..} =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasRoundNo -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version PerasRoundNo
pcCertRound
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecConfig blk
-> BlockNodeToNodeVersion blk -> Point blk -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version Point blk
pcCertBoostedBlock
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk
-> forall s. Decoder s (PerasCert blk)
decodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
    pcCertRound <- CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s PerasRoundNo
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s a
decodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version
    pcCertBoostedBlock <- decodeNodeToNode ccfg version
    pure $ PerasCert pcCertRound pcCertBoostedBlock

instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasVote blk) where
  -- Consistent with the 'Serialise' instance for 'PerasVote' defined in Ouroboros.Consensus.Block.SupportsPeras
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasVote blk -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version PerasVote{Point blk
PerasVoterId
PerasRoundNo
pvVoteRound :: PerasRoundNo
pvVoteBlock :: Point blk
pvVoteVoterId :: PerasVoterId
pvVoteVoterId :: forall blk. PerasVote blk -> PerasVoterId
pvVoteBlock :: forall blk. PerasVote blk -> Point blk
pvVoteRound :: forall blk. PerasVote blk -> PerasRoundNo
..} =
    Word -> Encoding
encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasRoundNo -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version PerasRoundNo
pvVoteRound
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecConfig blk
-> BlockNodeToNodeVersion blk -> Point blk -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version Point blk
pvVoteBlock
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasVoterId -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version PerasVoterId
pvVoteVoterId
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk
-> forall s. Decoder s (PerasVote blk)
decodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
3
    pvVoteRound <- CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s PerasRoundNo
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s a
decodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version
    pvVoteBlock <- decodeNodeToNode ccfg version
    pvVoteVoterId <- decodeNodeToNode ccfg version
    pure $ PerasVote pvVoteRound pvVoteBlock pvVoteVoterId

instance SerialiseNodeToNode blk PerasVoterId where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasVoterId -> Encoding
encodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = KeyHash StakePool -> Encoding
forall a. ToCBOR a => a -> Encoding
KeyHash.toCBOR (KeyHash StakePool -> Encoding)
-> (PerasVoterId -> KeyHash StakePool) -> PerasVoterId -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasVoterId -> KeyHash StakePool
unPerasVoterId
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s PerasVoterId
decodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = KeyHash StakePool -> PerasVoterId
PerasVoterId (KeyHash StakePool -> PerasVoterId)
-> Decoder s (KeyHash StakePool) -> Decoder s PerasVoterId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (KeyHash StakePool)
forall s. Decoder s (KeyHash StakePool)
forall a s. FromCBOR a => Decoder s a
KeyHash.fromCBOR

deriving newtype instance
  SerialiseNodeToClient blk (GenTxId blk) =>
  SerialiseNodeToClient blk (WrapGenTxId blk)

deriving newtype instance
  SerialiseNodeToClient blk (ApplyTxErr blk) =>
  SerialiseNodeToClient blk (WrapApplyTxErr blk)

deriving newtype instance
  SerialiseNodeToClient blk (LedgerConfig blk) =>
  SerialiseNodeToClient blk (WrapLedgerConfig blk)