Merge #2385

2385: Test & fix backwards compatibility between Byron and Cardano r=mrBliss a=mrBliss

Test backwards compatibility between Byron and Cardano

Fixes #2361.

A node running `CardanoBlock` can communicate with older nodes that run
`ByronBlock`, until the hard fork happens (as the other nodes won't support
Shelley). Test that we're actually backwards compatible.

This test did exactly what it was supposed to do: it found a bug!

Some idiot broke backwards compatibility in #2349. We were no longer able to exchange queries via the `LocalStateQuery` protocol
with a Byron-only node. Fix it.


Co-authored-by: Thomas Winant <thomas@well-typed.com>

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Block.hs

@@ -121,24 +121,24 @@ annotateByronBlock es = mkByronBlock es . CC.ABOBBlock . CC.reAnnotateBlock es
   Header
 -------------------------------------------------------------------------------}
 
-instance GetHeader ByronBlock where
-  -- | Byron header
-  --
-  -- See 'ByronBlock' for comments on why we cache certain values.
-  data Header ByronBlock = ByronHeader {
-        byronHeaderRaw    :: !(CC.ABlockOrBoundaryHdr ByteString)
-      , byronHeaderSlotNo :: !SlotNo
-      , byronHeaderHash   :: !ByronHash
-
-        -- | Hint about the block size
-        --
-        -- This is used only for the block fetch client. When this value is
-        -- wrong, block fetch might make suboptimal decisions, but it shouldn't
-        -- /break/ anything
-      , byronHeaderBlockSizeHint :: !SizeInBytes
-      }
-    deriving (Eq, Show, Generic)
+-- | Byron header
+--
+-- See 'ByronBlock' for comments on why we cache certain values.
+data instance Header ByronBlock = ByronHeader {
+      byronHeaderRaw    :: !(CC.ABlockOrBoundaryHdr ByteString)
+    , byronHeaderSlotNo :: !SlotNo
+    , byronHeaderHash   :: !ByronHash
+
+      -- | Hint about the block size
+      --
+      -- This is used only for the block fetch client. When this value is
+      -- wrong, block fetch might make suboptimal decisions, but it shouldn't
+      -- /break/ anything
+    , byronHeaderBlockSizeHint :: !SizeInBytes
+    }
+  deriving (Eq, Show, Generic)
 
+instance GetHeader ByronBlock where
   getHeader ByronBlock{..} = ByronHeader {
         byronHeaderRaw           = CC.abobHdrFromBlock byronBlockRaw
       , byronHeaderSlotNo        = byronBlockSlotNo

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

@@ -171,14 +171,15 @@ instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
     where
       validationMode = CC.fromBlockValidationMode CC.NoBlockValidation
 
-instance QueryLedger ByronBlock where
-  data Query ByronBlock :: * -> * where
-    GetUpdateInterfaceState :: Query ByronBlock UPI.State
+data instance Query ByronBlock :: * -> * where
+  GetUpdateInterfaceState :: Query ByronBlock UPI.State
 
+instance QueryLedger ByronBlock where
   answerQuery _cfg GetUpdateInterfaceState ledgerState =
     CC.cvsUpdateState (byronLedgerState ledgerState)
 
-  eqQuery GetUpdateInterfaceState GetUpdateInterfaceState = Just Refl
+instance SameDepIndex (Query ByronBlock) where
+  sameDepIndex GetUpdateInterfaceState GetUpdateInterfaceState = Just Refl
 
 deriving instance Eq (Query ByronBlock result)
 deriving instance Show (Query ByronBlock result)

ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Mempool.hs

@@ -80,28 +80,28 @@ import           Ouroboros.Consensus.Byron.Ledger.Serialisation
   Transactions
 -------------------------------------------------------------------------------}
 
-instance LedgerSupportsMempool ByronBlock where
-  -- | Generalized transactions in Byron
-  --
-  -- This is effectively the same as 'CC.AMempoolPayload' but we cache the
-  -- transaction ID (a hash).
-  data GenTx ByronBlock
-    = ByronTx             !Utxo.TxId                !(Utxo.ATxAux             ByteString)
-    | ByronDlg            !Delegation.CertificateId !(Delegation.ACertificate ByteString)
-    | ByronUpdateProposal !Update.UpId              !(Update.AProposal        ByteString)
-    | ByronUpdateVote     !Update.VoteId            !(Update.AVote            ByteString)
-    deriving (Eq, Generic)
-    deriving NoUnexpectedThunks via UseIsNormalForm (GenTx ByronBlock)
+-- | Generalized transactions in Byron
+--
+-- This is effectively the same as 'CC.AMempoolPayload' but we cache the
+-- transaction ID (a hash).
+data instance GenTx ByronBlock
+  = ByronTx             !Utxo.TxId                !(Utxo.ATxAux             ByteString)
+  | ByronDlg            !Delegation.CertificateId !(Delegation.ACertificate ByteString)
+  | ByronUpdateProposal !Update.UpId              !(Update.AProposal        ByteString)
+  | ByronUpdateVote     !Update.VoteId            !(Update.AVote            ByteString)
+  deriving (Eq, Generic)
+  deriving NoUnexpectedThunks via UseIsNormalForm (GenTx ByronBlock)
+
+type instance ApplyTxErr ByronBlock = CC.ApplyMempoolPayloadErr
 
+instance LedgerSupportsMempool ByronBlock where
   -- Check that the annotation is the canonical encoding. This is currently
   -- enforced by 'decodeByronGenTx', see its docstring for more context.
   txInvariant tx =
       CC.mempoolPayloadRecoverBytes tx' == CC.mempoolPayloadReencode tx'
     where
       tx' = toMempoolPayload tx
 
-  type ApplyTxErr ByronBlock = CC.ApplyMempoolPayloadErr
-
   applyTx = applyByronGenTx validationMode
     where
       validationMode = CC.ValidationMode CC.BlockValidation Utxo.TxValidation
@@ -119,15 +119,15 @@ instance LedgerSupportsMempool ByronBlock where
     . CC.mempoolPayloadRecoverBytes
     . toMempoolPayload
 
-instance HasTxId (GenTx ByronBlock) where
-  data TxId (GenTx ByronBlock)
-    = ByronTxId             !Utxo.TxId
-    | ByronDlgId            !Delegation.CertificateId
-    | ByronUpdateProposalId !Update.UpId
-    | ByronUpdateVoteId     !Update.VoteId
-    deriving (Eq, Ord)
-    deriving NoUnexpectedThunks via UseIsNormalForm (TxId (GenTx ByronBlock))
+data instance TxId (GenTx ByronBlock)
+  = ByronTxId             !Utxo.TxId
+  | ByronDlgId            !Delegation.CertificateId
+  | ByronUpdateProposalId !Update.UpId
+  | ByronUpdateVoteId     !Update.VoteId
+  deriving (Eq, Ord)
+  deriving NoUnexpectedThunks via UseIsNormalForm (TxId (GenTx ByronBlock))
 
+instance HasTxId (GenTx ByronBlock) where
   txId (ByronTx             i _) = ByronTxId             i
   txId (ByronDlg            i _) = ByronDlgId            i
   txId (ByronUpdateProposal i _) = ByronUpdateProposalId i

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

@@ -48,14 +48,14 @@ data ByronSpecBlock = ByronSpecBlock {
   GetHeader
 -------------------------------------------------------------------------------}
 
-instance GetHeader ByronSpecBlock where
-  data Header ByronSpecBlock = ByronSpecHeader {
-        byronSpecHeader     :: Spec.BlockHeader
-      , byronSpecHeaderNo   :: BlockNo
-      , byronSpecHeaderHash :: Spec.Hash
-      }
-    deriving (Show, Eq, Generic, Serialise)
+data instance Header ByronSpecBlock = ByronSpecHeader {
+      byronSpecHeader     :: Spec.BlockHeader
+    , byronSpecHeaderNo   :: BlockNo
+    , byronSpecHeaderHash :: Spec.Hash
+    }
+  deriving (Show, Eq, Generic, Serialise)
 
+instance GetHeader ByronSpecBlock where
   getHeader ByronSpecBlock{..} = ByronSpecHeader {
         byronSpecHeader     = Spec._bHeader byronSpecBlock
       , byronSpecHeaderNo   = byronSpecBlockNo

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

@@ -24,16 +24,16 @@ import qualified Ouroboros.Consensus.ByronSpec.Ledger.GenTx as GenTx
 import           Ouroboros.Consensus.ByronSpec.Ledger.Ledger
 import           Ouroboros.Consensus.ByronSpec.Ledger.Orphans ()
 
-instance LedgerSupportsMempool ByronSpecBlock where
-  newtype GenTx ByronSpecBlock = ByronSpecGenTx {
-        unByronSpecGenTx :: ByronSpecGenTx
-      }
-    deriving stock (Show, Generic)
-    deriving anyclass (Serialise)
-    deriving NoUnexpectedThunks via AllowThunk (GenTx ByronSpecBlock)
+newtype instance GenTx ByronSpecBlock = ByronSpecGenTx {
+      unByronSpecGenTx :: ByronSpecGenTx
+    }
+  deriving stock (Show, Generic)
+  deriving anyclass (Serialise)
+  deriving NoUnexpectedThunks via AllowThunk (GenTx ByronSpecBlock)
 
-  type ApplyTxErr ByronSpecBlock = ByronSpecGenTxErr
+type instance ApplyTxErr ByronSpecBlock = ByronSpecGenTxErr
 
+instance LedgerSupportsMempool ByronSpecBlock where
   applyTx cfg _slot tx (TickedByronSpecLedgerState tip st) =
       TickedByronSpecLedgerState tip <$>
         GenTx.apply cfg (unByronSpecGenTx tx) st

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -72,6 +72,7 @@ test-suite test
   hs-source-dirs:      test
   main-is:             Main.hs
   other-modules:
+                       Test.Consensus.Cardano.ByronCompatibility
                        Test.Consensus.Cardano.Generators
                        Test.Consensus.Cardano.Golden
                        Test.Consensus.Cardano.Examples
@@ -93,6 +94,7 @@ test-suite test
                      , containers
                      , mtl
                      , QuickCheck
+                     , sop-core
                      , tasty
                      , tasty-quickcheck
                      , time

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

@@ -309,15 +309,19 @@ type CardanoQuery sc = Query (CardanoBlock sc)
 -- | Byron-specific query that can only be answered when the ledger in the
 -- Byron era.
 pattern QueryIfCurrentByron
-  :: Query ByronBlock result
-  -> CardanoQuery sc (CardanoQueryResult sc result)
+  :: ()
+  => CardanoQueryResult sc result ~ a
+  => Query ByronBlock result
+  -> CardanoQuery sc a
 pattern QueryIfCurrentByron q = QueryIfCurrent (QZ q)
 
 -- | Shelley-specific query that can only be answered when the ledger in the
 -- Shelley era.
 pattern QueryIfCurrentShelley
-  :: Query (ShelleyBlock sc) result
-  -> CardanoQuery sc (CardanoQueryResult sc result)
+  :: ()
+  => CardanoQueryResult sc result ~ a
+  => Query (ShelleyBlock sc) result
+  -> CardanoQuery sc a
 pattern QueryIfCurrentShelley q = QueryIfCurrent (QS (QZ q))
 
 -- | Query about the Byron era that can be answered anytime, i.e.,

ouroboros-consensus-cardano/test/Main.hs

@@ -2,6 +2,7 @@ module Main (main) where
 
 import           Test.Tasty
 
+import qualified Test.Consensus.Cardano.ByronCompatibility (tests)
 import qualified Test.Consensus.Cardano.Golden (tests)
 import qualified Test.Consensus.Cardano.Serialisation (tests)
 import qualified Test.ThreadNet.Cardano (tests)
@@ -12,7 +13,8 @@ main = defaultMain tests
 tests :: TestTree
 tests =
   testGroup "cardano"
-  [ Test.Consensus.Cardano.Golden.tests
+  [ Test.Consensus.Cardano.ByronCompatibility.tests
+  , Test.Consensus.Cardano.Golden.tests
   , Test.Consensus.Cardano.Serialisation.tests
   , Test.ThreadNet.Cardano.tests
   ]