cardano-test: factor out TwoEras infra; intro ShelleyShelley test

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

@@ -24,6 +24,9 @@ library
                        Test.Consensus.Cardano.Generators
                        Test.Consensus.Cardano.MockCrypto
 
+                       Test.ThreadNet.Infra.ShelleyShelley
+                       Test.ThreadNet.Infra.TwoEras
+
                        Test.ThreadNet.TxGen.Cardano
 
   build-depends:       base
@@ -77,6 +80,7 @@ test-suite test
                        Test.Consensus.Cardano.Golden
                        Test.Consensus.Cardano.Serialisation
                        Test.ThreadNet.Cardano
+                       Test.ThreadNet.ShelleyShelley
 
   build-depends:       base
                      , bytestring

ouroboros-consensus-cardano-test/src/Test/ThreadNet/Infra/ShelleyShelley.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE PatternSynonyms     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.ThreadNet.Infra.ShelleyShelley (
+    -- * Blocks
+    ShelleyShelleyEras
+  , ShelleyShelleyBlock
+    -- * Transactions
+  , pattern GenTxShelley1
+  , pattern GenTxShelley2
+    -- * Node
+  , protocolInfoShelleyShelley
+  ) where
+
+import qualified Data.Map as Map
+import           Data.SOP.Strict (NP (..), NS (..))
+
+import           Cardano.Crypto.Hash (HashAlgorithm)
+
+import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
+import           Ouroboros.Consensus.Node
+import           Ouroboros.Consensus.Node.NetworkProtocolVersion
+import           Ouroboros.Consensus.TypeFamilyWrappers
+import           Ouroboros.Consensus.Util.IOLike (IOLike)
+
+import           Ouroboros.Consensus.HardFork.Combinator
+import           Ouroboros.Consensus.HardFork.Combinator.Binary
+import           Ouroboros.Consensus.HardFork.Combinator.Serialisation
+import qualified Ouroboros.Consensus.HardFork.Combinator.State.Types as HFC
+import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs
+import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Tails as Tails
+import qualified Ouroboros.Consensus.HardFork.History as History
+
+import           Ouroboros.Consensus.Shelley.Ledger
+import           Ouroboros.Consensus.Shelley.Node
+import           Ouroboros.Consensus.Shelley.Protocol
+
+import           Ouroboros.Consensus.Cardano.Block (ShelleyEra)
+import           Ouroboros.Consensus.Cardano.CanHardFork
+                     (ShelleyPartialLedgerConfig (..), forecastAcrossShelley)
+import           Ouroboros.Consensus.Cardano.Node
+                     (ProtocolParamsTransition (..), TriggerHardFork (..))
+
+import           Test.Consensus.Shelley.MockCrypto (MockCrypto)
+import           Test.ThreadNet.TxGen
+import           Test.ThreadNet.TxGen.Shelley ()
+
+{-------------------------------------------------------------------------------
+  Block type
+-------------------------------------------------------------------------------}
+
+-- | Two eras, both Shelley and 100% compatible.
+type ShelleyShelleyEras c =
+    '[ShelleyBlock (ShelleyEra c), ShelleyBlock (ShelleyEra c)]
+
+type ShelleyShelleyBlock c = HardForkBlock (ShelleyShelleyEras c)
+
+{-------------------------------------------------------------------------------
+  Pattern synonyms, for encapsulation and legibility
+-------------------------------------------------------------------------------}
+
+type ShelleyShelleyGenTx c = GenTx (ShelleyShelleyBlock c)
+
+pattern GenTxShelley1 ::
+    GenTx (ShelleyBlock (ShelleyEra c)) -> ShelleyShelleyGenTx c
+pattern GenTxShelley1 tx = HardForkGenTx (OneEraGenTx (Z tx))
+
+pattern GenTxShelley2 ::
+    GenTx (ShelleyBlock (ShelleyEra c)) -> ShelleyShelleyGenTx c
+pattern GenTxShelley2 tx = HardForkGenTx (OneEraGenTx (S (Z tx)))
+
+{-# COMPLETE GenTxShelley1, GenTxShelley2 #-}
+
+pattern ShelleyShelleyNodeToNodeVersion1 ::
+    BlockNodeToNodeVersion (ShelleyShelleyBlock c)
+pattern ShelleyShelleyNodeToNodeVersion1 =
+    HardForkNodeToNodeEnabled
+      HardForkSpecificNodeToNodeVersion1
+      (  EraNodeToNodeEnabled ShelleyNodeToNodeVersion1
+      :* EraNodeToNodeEnabled ShelleyNodeToNodeVersion1
+      :* Nil
+      )
+
+pattern ShelleyShelleyNodeToClientVersion1 ::
+    BlockNodeToClientVersion (ShelleyShelleyBlock c)
+pattern ShelleyShelleyNodeToClientVersion1 =
+    HardForkNodeToClientEnabled
+      HardForkSpecificNodeToClientVersion2
+      (  EraNodeToClientEnabled ShelleyNodeToClientVersion1
+      :* EraNodeToClientEnabled ShelleyNodeToClientVersion1
+      :* Nil
+      )
+
+{-------------------------------------------------------------------------------
+  Consensus instances
+-------------------------------------------------------------------------------}
+
+instance TPraosCrypto c => SerialiseHFC (ShelleyShelleyEras c)
+   -- use defaults
+
+instance TPraosCrypto c => CanHardFork (ShelleyShelleyEras c) where
+  hardForkEraTranslation = EraTranslation {
+        translateLedgerState   = PCons idTranslation PNil
+      , translateChainDepState = PCons idTranslation PNil
+      , translateLedgerView    = PCons ledgerViewTranslation PNil
+      }
+    where
+      idTranslation ::
+           forall from to a.
+           InPairs.RequiringBoth from (HFC.Translate to) a a
+      idTranslation = InPairs.ignoringBoth $ HFC.Translate $ \_epochNo -> id
+
+      ledgerViewTranslation ::
+          InPairs.RequiringBoth
+            WrapLedgerConfig
+            (HFC.TranslateForecast LedgerState WrapLedgerView)
+            (ShelleyBlock (ShelleyEra c))
+            (ShelleyBlock (ShelleyEra c))
+      ledgerViewTranslation =
+          InPairs.RequireBoth $ \(WrapLedgerConfig cfg1) (WrapLedgerConfig cfg2) ->
+            HFC.TranslateForecast $ forecastAcrossShelley cfg1 cfg2
+
+  hardForkChainSel = Tails.mk2 SelectSameProtocol
+
+  hardForkInjectTxs = InPairs.mk2 $ InPairs.ignoringBoth (InjectTx Just)
+
+instance TPraosCrypto c
+      => SupportedNetworkProtocolVersion (ShelleyShelleyBlock c) where
+  supportedNodeToNodeVersions _ = Map.fromList $
+      [ (maxBound, ShelleyShelleyNodeToNodeVersion1)
+      ]
+
+  supportedNodeToClientVersions _ = Map.fromList $
+      [ (maxBound, ShelleyShelleyNodeToClientVersion1)
+      ]
+
+{-------------------------------------------------------------------------------
+  Protocol info
+-------------------------------------------------------------------------------}
+
+protocolInfoShelleyShelley ::
+     forall c m. (IOLike m, TPraosCrypto c)
+  => ProtocolParamsShelley c Identity
+  -> ProtocolParamsShelley c Identity
+  -> ProtocolParamsTransition (ShelleyBlock (ShelleyEra c)) (ShelleyBlock (ShelleyEra c))
+  -> ProtocolInfo m (HardForkBlock '[ShelleyBlock (ShelleyEra c), ShelleyBlock (ShelleyEra c)])
+protocolInfoShelleyShelley protocolParamsShelley1 protocolParamsShelley2 protocolParamsTransition =
+    protocolInfoBinary
+      -- A
+      protocolInfoShelley1
+      eraParamsShelley1
+      tpraosParams
+      toPartialLedgerConfig1
+      -- B
+      protocolInfoShelley2
+      eraParamsShelley2
+      tpraosParams
+      toPartialLedgerConfig2
+  where
+    protocolInfoShelley1 = protocolInfoShelley protocolParamsShelley1
+    protocolInfoShelley2 = protocolInfoShelley protocolParamsShelley2
+
+    ProtocolParamsTransition {
+        transitionLowerBound = mbLowerBound
+      , transitionTrigger    = triggerHardFork
+      } = protocolParamsTransition
+
+    eraParamsShelley1, eraParamsShelley2 :: History.EraParams
+    (eraParamsShelley1, eraParamsShelley2) =
+        ( shelleyEraParams (safeBefore mbLowerBound) (shelleyGenesis protocolParamsShelley1)
+        , shelleyEraParams (safeBefore Nothing)      (shelleyGenesis protocolParamsShelley2)
+        )
+      where
+        safeBefore :: Maybe EpochNo -> History.SafeBeforeEpoch
+        safeBefore = maybe History.NoLowerBound History.LowerBound
+
+    toPartialLedgerConfig1, toPartialLedgerConfig2 ::
+         LedgerConfig (ShelleyBlock (ShelleyEra c))
+      -> PartialLedgerConfig (ShelleyBlock (ShelleyEra c))
+    toPartialLedgerConfig1 cfg = ShelleyPartialLedgerConfig {
+          shelleyLedgerConfig    = cfg
+        , shelleyTriggerHardFork = triggerHardFork
+        }
+    toPartialLedgerConfig2 cfg = ShelleyPartialLedgerConfig {
+          shelleyLedgerConfig    = cfg
+        , shelleyTriggerHardFork = TriggerHardForkNever
+        }
+
+{-------------------------------------------------------------------------------
+  TxGen instance
+-------------------------------------------------------------------------------}
+
+-- | Use a generic implementation for 'TxGen'
+instance HashAlgorithm h => TxGen (ShelleyShelleyBlock (MockCrypto h)) where
+  type TxGenExtra (ShelleyShelleyBlock (MockCrypto h)) =
+    NP WrapTxGenExtra (ShelleyShelleyEras (MockCrypto h))
+  testGenTxs = testGenTxsHfc