Serialization instances for PartialLedgerConfig

ouroboros-consensus-byron-test/ouroboros-consensus-byron-test.cabal

@@ -105,6 +105,7 @@ test-suite test
                      , ouroboros-network
                      , ouroboros-consensus
                      , ouroboros-consensus-test
+                     , ouroboros-consensus-cardano
                      , ouroboros-consensus-byron
                      , ouroboros-consensus-byron-test
                      , ouroboros-consensus-byronspec

ouroboros-consensus-byron-test/src/Ouroboros/Consensus/ByronDual/Node/Serialisation.hs

@@ -9,6 +9,7 @@ module Ouroboros.Consensus.ByronDual.Node.Serialisation () where
 import qualified Data.ByteString.Lazy as Lazy
 import           Data.Proxy
 
+import           Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import           Cardano.Chain.Slotting (EpochSlots)
 
 import           Ouroboros.Network.Block (Serialised, unwrapCBORinCBOR,
@@ -141,6 +142,10 @@ instance SerialiseNodeToNode DualByronBlock (GenTxId DualByronBlock) where
 
 instance SerialiseNodeToClientConstraints DualByronBlock
 
+instance SerialiseNodeToClient DualByronBlock (DualLedgerConfig ByronBlock ByronSpecBlock) where
+  encodeNodeToClient _ _ = encodeDualLedgerConfig toCBOR toCBOR
+  decodeNodeToClient _ _ = decodeDualLedgerConfig fromCBOR fromCBOR
+
 -- | CBOR-in-CBOR for the annotation. This also makes it compatible with the
 -- wrapped ('Serialised') variant.
 instance SerialiseNodeToClient DualByronBlock DualByronBlock where

ouroboros-consensus-byron-test/test/Test/Consensus/Byron/Golden.hs

@@ -4,6 +4,7 @@ module Test.Consensus.Byron.Golden (tests) where
 
 import           Ouroboros.Consensus.Byron.Ledger.NetworkProtocolVersion
 import           Ouroboros.Consensus.Byron.Node ()
+import           Ouroboros.Consensus.Cardano.CanHardFork ()
 
 import           Test.Tasty
 

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node.hs

@@ -1,13 +1,15 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Ouroboros.Consensus.Byron.Node (
-    PBftSignatureThreshold (..)
+module Ouroboros.Consensus.Byron.Node
+  ( PBftSignatureThreshold (..)
   , ProtocolParamsByron (..)
   , byronBlockForging
   , defaultPBftSignatureThreshold
@@ -284,4 +286,7 @@ instance NodeInitStorage ByronBlock where
 instance BlockSupportsMetrics ByronBlock where
   isSelfIssued = isSelfIssuedConstUnknown
 
+-- Note the use of the @SerialiseNodeToClientConstraints@ constraints even
+-- though there is no polymorphism. This is because the relevant instance is an
+-- orphan instance in the ouroboros-consensus-cardano package i.e. out of scope.
 instance RunNode ByronBlock

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node/Serialisation.hs

@@ -37,6 +37,7 @@ import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.Byron.Ledger
 import           Ouroboros.Consensus.Byron.Ledger.Conversions
 import           Ouroboros.Consensus.Byron.Protocol
+import qualified Cardano.Chain.Genesis as Genesis
 
 {-------------------------------------------------------------------------------
   EncodeDisk & DecodeDisk
@@ -177,6 +178,10 @@ instance SerialiseNodeToClient ByronBlock (SomeSecond BlockQuery ByronBlock) whe
   encodeNodeToClient _ _ (SomeSecond q) = encodeByronQuery q
   decodeNodeToClient _ _               = decodeByronQuery
 
+instance SerialiseNodeToClient ByronBlock (Genesis.Config) where
+  encodeNodeToClient _ _ = toCBOR
+  decodeNodeToClient _ _ = fromCBOR
+
 instance SerialiseResult ByronBlock (BlockQuery ByronBlock) where
   encodeResult _ _ = encodeByronResult
   decodeResult _ _ = decodeByronResult

ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Genesis.hs

@@ -1,15 +1,20 @@
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DerivingVia        #-}
-{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# OPTIONS_GHC -Wno-orphans  #-}
 
 -- | Genesis config for the spec
 --
 -- Intended for qualified import
 --
 -- > import           Ouroboros.Consensus.ByronSpec.Ledger.Genesis (ByronSpecGenesis)
 -- > import qualified Ouroboros.Consensus.ByronSpec.Ledger.Genesis as Genesis
-module Ouroboros.Consensus.ByronSpec.Ledger.Genesis (
-    ByronSpecGenesis (..)
+module Ouroboros.Consensus.ByronSpec.Ledger.Genesis
+  ( ByronSpecGenesis (..)
   , modFeeParams
   , modPBftThreshold
   , modPParams
@@ -20,11 +25,14 @@ module Ouroboros.Consensus.ByronSpec.Ledger.Genesis (
   , toChainEnv
   ) where
 
+import           Codec.Serialise (decode, encode)
 import           Data.Coerce (coerce)
 import           Data.Set (Set)
 import           NoThunks.Class (AllowThunk (..), NoThunks)
 import           Numeric.Natural (Natural)
 
+import           Cardano.Binary
+
 import qualified Byron.Spec.Chain.STS.Rule.Chain as Spec
 import qualified Byron.Spec.Ledger.Core as Spec
 import qualified Byron.Spec.Ledger.UTxO as Spec
@@ -55,6 +63,42 @@ data ByronSpecGenesis = ByronSpecGenesis {
   deriving stock (Show)
   deriving NoThunks via AllowThunk ByronSpecGenesis
 
+
+
+
+
+-- TODO serialisation tests!!!!!!
+
+
+
+
+instance FromCBOR ByronSpecGenesis where
+  fromCBOR = do
+    enforceSize "ByronSpecGenesis" 5
+    ByronSpecGenesis
+      <$> fromCBOR @(Set Spec.VKeyGenesis)
+      <*> decode @Spec.UTxO
+      <*> decode @Spec.PParams
+      <*> fromCBOR @Spec.BlockCount
+      <*> fromCBOR @Natural
+
+instance ToCBOR ByronSpecGenesis where
+  toCBOR (ByronSpecGenesis delegators utxo pparams k slotLength) = mconcat
+    [ encodeListLen 5
+    , toCBOR delegators
+    , encode utxo
+    , encode pparams
+    , toCBOR k
+    , toCBOR slotLength
+    ]
+
+-- TODO remove instances when they have been merged upstream
+deriving newtype instance FromCBOR Spec.BlockCount
+deriving newtype instance ToCBOR Spec.BlockCount
+deriving newtype instance FromCBOR Spec.VKeyGenesis
+deriving newtype instance FromCBOR Spec.VKey
+deriving newtype instance FromCBOR Spec.Owner
+
 modPBftThreshold :: (Double -> Double)
                  -> ByronSpecGenesis -> ByronSpecGenesis
 modPBftThreshold = modPParams . modPParamsPBftThreshold

ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/ByronCompatibility.hs

@@ -31,7 +31,7 @@ import           Ouroboros.Consensus.Node.Serialisation
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
 
-import           Ouroboros.Consensus.HardFork.Combinator (NestedCtxt_ (..))
+import           Ouroboros.Consensus.HardFork.Combinator (NestedCtxt_ (..), PartialLedgerConfig)
 
 import           Ouroboros.Consensus.Byron.Ledger
 import           Ouroboros.Consensus.Byron.Node ()
@@ -154,6 +154,9 @@ unNestedCtxt_B2C (NestedCtxt_B2C ctxt) = ctxt
 type instance HeaderHash ByronToCardano = HeaderHash ByronBlock
 type instance ApplyTxErr ByronToCardano = ApplyTxErr ByronBlock
 
+newtype ByronToCardanoLedgerConfig = LedgerConfigB2C ()
+type instance PartialLedgerConfig ByronToCardano = ByronToCardanoLedgerConfig
+
 instance HasNetworkProtocolVersion ByronToCardano
 
 instance ConvertRawHash ByronToCardano where
@@ -362,6 +365,10 @@ instance SerialiseNodeToClient ByronToCardano (SomeSecond BlockQuery ByronToCard
                          (Proxy @(SomeSecond BlockQuery))
                          (\(SomeSecond (QueryIfCurrentByron q)) -> SomeSecond (QueryB2C q))
 
+instance SerialiseNodeToClient ByronToCardano ByronToCardanoLedgerConfig where
+  encodeNodeToClient _ _ (LedgerConfigB2C ()) = mempty
+  decodeNodeToClient _ _ = return (LedgerConfigB2C ())
+
 instance SerialiseResult ByronToCardano (BlockQuery ByronToCardano) where
   encodeResult (CodecConfigB2C ccfg) () (QueryB2C q) r =
       encodeResult ccfg byronNodeToClientVersion q r
@@ -435,6 +442,9 @@ unNestedCtxt_C2B (NestedCtxt_C2B ctxt) = ctxt
 type instance HeaderHash CardanoToByron = HeaderHash ByronBlock
 type instance ApplyTxErr CardanoToByron = ApplyTxErr ByronBlock
 
+newtype CardanoToByronLedgerConfig = LedgerConfigC2B ()
+type instance PartialLedgerConfig CardanoToByron = CardanoToByronLedgerConfig
+
 instance HasNetworkProtocolVersion CardanoToByron
 
 instance ConvertRawHash CardanoToByron where
@@ -647,6 +657,10 @@ instance SerialiseNodeToClient CardanoToByron (SomeSecond BlockQuery CardanoToBy
         (Proxy @(SomeSecond BlockQuery))
         (\(SomeSecond q) -> SomeSecond (QueryC2B q))
 
+instance SerialiseNodeToClient CardanoToByron CardanoToByronLedgerConfig where
+  encodeNodeToClient _ _ (LedgerConfigC2B ()) = mempty
+  decodeNodeToClient _ _ = return (LedgerConfigC2B ())
+
 instance SerialiseResult CardanoToByron (BlockQuery CardanoToByron) where
   encodeResult (CodecConfigC2B ccfg) () (QueryC2B q) (r :: result) =
       encodeResult

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -18,8 +18,8 @@
 {-# LANGUAGE TypeOperators            #-}
 {-# LANGUAGE UndecidableInstances     #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
-module Ouroboros.Consensus.Cardano.CanHardFork (
-    ByronPartialLedgerConfig (..)
+module Ouroboros.Consensus.Cardano.CanHardFork
+  ( ByronPartialLedgerConfig (..)
   , CardanoHardForkConstraints
   , TriggerHardFork (..)
     -- * Re-exports of Shelley code
@@ -81,6 +81,8 @@ import           Cardano.Ledger.Mary.Translation ()
 import qualified Shelley.Spec.Ledger.API as SL
 
 import           Ouroboros.Consensus.Cardano.Block
+import           Ouroboros.Consensus.Node.Serialisation
+                     (SerialiseNodeToClient (..))
 
 {-------------------------------------------------------------------------------
   Figure out the transition point for Byron
@@ -252,12 +254,15 @@ instance FromCBOR ByronPartialLedgerConfig where
       <$> fromCBOR @(LedgerConfig ByronBlock)
       <*> fromCBOR @TriggerHardFork
 
-instance HasPartialLedgerConfig ByronBlock where
-
-  type PartialLedgerConfig ByronBlock = ByronPartialLedgerConfig
+type instance PartialLedgerConfig ByronBlock = ByronPartialLedgerConfig
 
+instance HasPartialLedgerConfig ByronBlock where
   completeLedgerConfig _ _ = byronLedgerConfig
 
+instance SerialiseNodeToClient ByronBlock ByronPartialLedgerConfig where
+  encodeNodeToClient _ _ = toCBOR
+  decodeNodeToClient _ _ = fromCBOR
+
 {-------------------------------------------------------------------------------
   CanHardFork
 -------------------------------------------------------------------------------}

ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs

@@ -100,6 +100,9 @@ import           Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE,
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.Orphans ()
 
+import           Ouroboros.Consensus.HardFork.Combinator
+                     (HasPartialLedgerConfig, PartialLedgerConfig)
+import           Ouroboros.Consensus.Node.Serialisation (SerialiseNodeToClient)
 import           Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..))
 
 {-------------------------------------------------------------------------------
@@ -340,6 +343,25 @@ deriving instance NoThunks (MockLedgerConfig c ext)
 
 type instance LedgerCfg (LedgerState (SimpleBlock c ext)) = SimpleLedgerConfig c ext
 
+type instance PartialLedgerConfig (SimpleBlock' c ext ext') = LedgerConfig (SimpleBlock' c ext ext')
+
+instance UpdateLedger (SimpleBlock' c ext ext') => HasPartialLedgerConfig (SimpleBlock' c ext ext')
+
+instance Serialise (MockLedgerConfig c ext) => Serialise (SimpleLedgerConfig c ext) where
+  encode (SimpleLedgerConfig cfg eraParams) = mconcat [
+        CBOR.encodeListLen 2
+      , encode cfg
+      , encode eraParams
+      ]
+  decode = do
+      CBOR.decodeListLenOf 2
+      cfg  <- decode
+      eraParams <- decode
+      return (SimpleLedgerConfig cfg eraParams)
+
+instance Serialise (MockLedgerConfig c ext)
+  => SerialiseNodeToClient (SimpleBlock c ext) (SimpleLedgerConfig c ext)
+
 instance GetTip (LedgerState (SimpleBlock c ext)) where
   getTip (SimpleLedgerState st) = castPoint $ mockTip st
 

ouroboros-consensus-shelley-test/test/Test/Consensus/Shelley/Golden.hs

@@ -4,6 +4,7 @@ module Test.Consensus.Shelley.Golden (tests) where
 
 import           Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion
 import           Ouroboros.Consensus.Shelley.Node ()
+import           Ouroboros.Consensus.Shelley.ShelleyHFC ()
 
 import           Test.Tasty
 

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs

@@ -17,8 +17,9 @@
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Ouroboros.Consensus.Shelley.Node (
-    MaxMajorProtVer (..)
+{-# LANGUAGE UndecidableInstances     #-}
+module Ouroboros.Consensus.Shelley.Node
+  ( MaxMajorProtVer (..)
   , ProtocolParamsAllegra (..)
   , ProtocolParamsMary (..)
   , ProtocolParamsShelley (..)
@@ -379,6 +380,10 @@ instance ShelleyBasedEra era => BlockSupportsMetrics (ShelleyBlock era) where
          SelfIssued    -> IsSelfIssued
          NotSelfIssued -> IsNotSelfIssued
 
+-- TODO It's annoying that I have to put a SerialiseNodeToClient constraint
+-- here.
+--
+-- Can I make this non-orphaned or put this instance next to PartialLedgerConfig?
 instance ShelleyBasedEra era => RunNode (ShelleyBlock era)
 
 {-------------------------------------------------------------------------------

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs

@@ -1,9 +1,13 @@
+{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
-module Ouroboros.Consensus.Shelley.Node.Serialisation () where
+module Ouroboros.Consensus.Shelley.Node.Serialisation
+  (
+  ) where
 
 import           Control.Exception (Exception, throw)
 import qualified Data.ByteString.Lazy as Lazy
@@ -128,6 +132,7 @@ data ShelleyEncoderException era =
 
 instance Typeable era => Exception (ShelleyEncoderException era)
 
+-- TODO why do I need the SerialiseNodeToClient constraint?
 instance ShelleyBasedEra era => SerialiseNodeToClientConstraints (ShelleyBlock era)
 
 -- | CBOR-in-CBOR for the annotation. This also makes it compatible with the

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -56,10 +56,13 @@ import qualified Cardano.Ledger.Era as SL
 import qualified Shelley.Spec.Ledger.API as SL
 import           Shelley.Spec.Ledger.BaseTypes
 
+import           Ouroboros.Consensus.Node.Serialisation
+                     (SerialiseNodeToClient (..))
 import           Ouroboros.Consensus.Shelley.Eras
 import           Ouroboros.Consensus.Shelley.Ledger
 import           Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect
 import           Ouroboros.Consensus.Shelley.Node ()
+import           Ouroboros.Consensus.Shelley.Node.Serialisation ()
 import           Ouroboros.Consensus.Shelley.Protocol
 
 {-------------------------------------------------------------------------------
@@ -198,8 +201,13 @@ data ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig {
     }
   deriving (Generic, NoThunks)
 
+instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (ShelleyPartialLedgerConfig era) where
+  encodeNodeToClient _ _ = toCBOR
+  decodeNodeToClient _ _ = fromCBOR
+
+type instance PartialLedgerConfig (ShelleyBlock era) = ShelleyPartialLedgerConfig era
+
 instance ShelleyBasedEra era => HasPartialLedgerConfig (ShelleyBlock era) where
-  type PartialLedgerConfig (ShelleyBlock era) = ShelleyPartialLedgerConfig era
 
   -- Replace the dummy 'EpochInfo' with the real one
   completeLedgerConfig _ epochInfo (ShelleyPartialLedgerConfig cfg _) =

ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs

@@ -257,9 +257,9 @@ instance LedgerSupportsProtocol BlockA where
 
 instance HasPartialConsensusConfig ProtocolA
 
-instance HasPartialLedgerConfig BlockA where
-  type PartialLedgerConfig BlockA = PartialLedgerConfigA
+type instance PartialLedgerConfig BlockA = PartialLedgerConfigA
 
+instance HasPartialLedgerConfig BlockA where
   completeLedgerConfig _ ei pcfg = (History.toPureEpochInfo ei, pcfg)
 
 data TxPayloadA = InitiateAtoB
@@ -576,6 +576,10 @@ instance SerialiseNodeToClient BlockA BlockA
 instance SerialiseNodeToClient BlockA (Serialised BlockA)
 instance SerialiseNodeToClient BlockA (GenTx BlockA)
 
+instance SerialiseNodeToClient blk PartialLedgerConfigA where
+  encodeNodeToClient _ _ = toCBOR
+  decodeNodeToClient _ _ = fromCBOR
+
 instance SerialiseNodeToClient BlockA Void where
   encodeNodeToClient _ _ = absurd
   decodeNodeToClient _ _ = fail "no ApplyTxErr to be decoded"