{-# 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 Cardano.Binary (FromCBOR (..), ToCBOR (..))
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 Data.Typeable (Typeable)
import Data.Void (absurd)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
  ( ApplyTxErr
  , GenTxId
  )
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import qualified Ouroboros.Consensus.Peras.Cert.V1 as V1
import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1
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)

deriving newtype instance
  SerialiseNodeToNode blk (PerasVote blk) =>
  SerialiseNodeToNode blk (WrapPerasVote blk)

deriving newtype instance
  SerialiseNodeToNode blk (PerasCert blk) =>
  SerialiseNodeToNode blk (WrapPerasCert 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)) -> Decoder s (Point blk)
(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)) -> Decoder s (Tip blk)
(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 SerialiseNodeToNode blk PerasSeatIndex where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasSeatIndex -> Encoding
encodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = Word16 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word16 -> Encoding)
-> (PerasSeatIndex -> Word16) -> PerasSeatIndex -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasSeatIndex -> Word16
unPerasSeatIndex
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s PerasSeatIndex
decodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = Word16 -> PerasSeatIndex
PerasSeatIndex (Word16 -> PerasSeatIndex)
-> Decoder s Word16 -> Decoder s PerasSeatIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word16
forall s. Decoder s Word16
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance SerialiseNodeToNode blk PerasVoteId where
  -- Consistent with the 'Serialise' instance for 'PerasVoteId' defined in Ouroboros.Consensus.Block.SupportsPeras
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasVoteId -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version PerasVoteId{PerasRoundNo
PerasSeatIndex
pviRoundNo :: PerasRoundNo
pviSeatIndex :: PerasSeatIndex
pviRoundNo :: PerasVoteId -> PerasRoundNo
pviSeatIndex :: PerasVoteId -> PerasSeatIndex
..} =
    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
pviRoundNo
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasSeatIndex -> Encoding
forall blk a.
SerialiseNodeToNode blk a =>
CodecConfig blk -> BlockNodeToNodeVersion blk -> a -> Encoding
encodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version PerasSeatIndex
pviSeatIndex
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> forall s. Decoder s PerasVoteId
decodeNodeToNode CodecConfig blk
ccfg BlockNodeToNodeVersion blk
version = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
    pviRoundNo <- 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
    pviSeatIndex <- decodeNodeToNode ccfg version
    pure $ PerasVoteId pviRoundNo pviSeatIndex

instance SerialiseNodeToNode blk (VoidPerasVote blk) where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> VoidPerasVote blk -> Encoding
encodeNodeToNode CodecConfig blk
_ BlockNodeToNodeVersion blk
_ = Void -> Encoding
forall a. Void -> a
absurd (Void -> Encoding)
-> (VoidPerasVote blk -> Void) -> VoidPerasVote blk -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VoidPerasVote blk -> Void
forall blk. VoidPerasVote blk -> Void
unVoidPerasVote
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk
-> forall s. Decoder s (VoidPerasVote blk)
decodeNodeToNode CodecConfig blk
_ BlockNodeToNodeVersion blk
_ = String -> Decoder s (VoidPerasVote blk)
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"VoidPerasVote cannot be decoded"

instance SerialiseNodeToNode blk (VoidPerasCert blk) where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> VoidPerasCert blk -> Encoding
encodeNodeToNode CodecConfig blk
_ BlockNodeToNodeVersion blk
_ = Void -> Encoding
forall a. Void -> a
absurd (Void -> Encoding)
-> (VoidPerasCert blk -> Void) -> VoidPerasCert blk -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VoidPerasCert blk -> Void
forall blk. VoidPerasCert blk -> Void
unVoidPerasCert
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk
-> forall s. Decoder s (VoidPerasCert blk)
decodeNodeToNode CodecConfig blk
_ BlockNodeToNodeVersion blk
_ = String -> Decoder s (VoidPerasCert blk)
forall a. HasCallStack => String -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"VoidPerasCert cannot be decoded"

instance Typeable tag => SerialiseNodeToNode blk (V1.PerasVote tag) where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasVote tag -> Encoding
encodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = PerasVote tag -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk
-> forall s. Decoder s (PerasVote tag)
decodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = Decoder s (PerasVote tag)
forall s. Decoder s (PerasVote tag)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance Typeable tag => SerialiseNodeToNode blk (V1.PerasCert tag) where
  encodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk -> PerasCert tag -> Encoding
encodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = PerasCert tag -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
  decodeNodeToNode :: CodecConfig blk
-> BlockNodeToNodeVersion blk
-> forall s. Decoder s (PerasCert tag)
decodeNodeToNode CodecConfig blk
_ccfg BlockNodeToNodeVersion blk
_version = Decoder s (PerasCert tag)
forall s. Decoder s (PerasCert tag)
forall a s. FromCBOR a => Decoder s a
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)