Merge pull request #1321 from IntersectMBO/parse-dijkstra-hard-fork-trigger

Honour TestDijkstraHardForkAtEpoch when parsing the node configuration

Author: palas

.changes/20260825_161536_cardano-api_palas_dijkstra_hard_fork_trigger.yml

@@ -0,0 +1,6 @@
+description: |
+  `foldBlocks` and the rest of the ledger-state machinery now honour `TestDijkstraHardForkAtEpoch` in the node configuration file, so they can follow a chain into the Dijkstra era.
+kind:
+  - bugfix
+pr: 1321
+project: cardano-api

cardano-api/cardano-api.cabal

@@ -398,7 +398,7 @@ test-suite cardano-api-test
     hedgehog-quickcheck,
     microlens,
     mtl,
-    ouroboros-consensus:{ouroboros-consensus, protocol},
+    ouroboros-consensus:{cardano, ouroboros-consensus, protocol},
     raw-strings-qq,
     tasty,
     tasty-hedgehog,
@@ -427,6 +427,7 @@ test-suite cardano-api-test
     Test.Cardano.Api.Ledger
     Test.Cardano.Api.Leios
     Test.Cardano.Api.Metadata
+    Test.Cardano.Api.NodeConfig
     Test.Cardano.Api.Ord
     Test.Cardano.Api.Orphans
     Test.Cardano.Api.RawBytes

cardano-api/src/Cardano/Api/LedgerState.hs

@@ -1173,7 +1173,7 @@ instance FromJSON NodeConfig where
         <*> parseAlonzoHardForkEpoch o
         <*> parseBabbageHardForkEpoch o
         <*> parseConwayHardForkEpoch o
-        <*> pure Consensus.CardanoTriggerHardForkAtDefaultVersion -- TODO Dijkstra
+        <*> parseDijkstraHardForkEpoch o
     parseShelleyHardForkEpoch :: Object -> Parser (Consensus.CardanoHardForkTrigger blk)
     parseShelleyHardForkEpoch o =
       asum
@@ -1215,6 +1215,13 @@ instance FromJSON NodeConfig where
         , pure Consensus.CardanoTriggerHardForkAtDefaultVersion
         ]
 
+    parseDijkstraHardForkEpoch :: Object -> Parser (Consensus.CardanoHardForkTrigger blk)
+    parseDijkstraHardForkEpoch o =
+      asum
+        [ Consensus.CardanoTriggerHardForkAtEpoch <$> o .: "TestDijkstraHardForkAtEpoch"
+        , pure Consensus.CardanoTriggerHardForkAtDefaultVersion
+        ]
+
 ----------------------------------------------------------------------
 -- WARNING When adding new entries above, be aware that if there is an
 -- intra-era fork, then the numbering is not consecutive.

cardano-api/test/cardano-api-test/Test/Cardano/Api/NodeConfig.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.Cardano.Api.NodeConfig
+  ( tests
+  )
+where
+
+import Cardano.Api (EpochNo (..))
+import Cardano.Api.LedgerState (NodeConfig (..))
+
+import Ouroboros.Consensus.Cardano.Node qualified as Consensus
+
+import Data.Aeson qualified as Aeson
+import GHC.Stack
+
+import Hedgehog as H
+import Hedgehog.Extras (propertyOnce)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Hedgehog (testProperty)
+
+-- | A minimal node configuration with the given extra keys.
+nodeConfigWith :: [(Aeson.Key, Aeson.Value)] -> Aeson.Value
+nodeConfigWith extras =
+  Aeson.object $
+    [ "ByronGenesisFile" Aeson..= ("byron-genesis.json" :: String)
+    , "ShelleyGenesisFile" Aeson..= ("shelley-genesis.json" :: String)
+    , "AlonzoGenesisFile" Aeson..= ("alonzo-genesis.json" :: String)
+    , "ConwayGenesisFile" Aeson..= ("conway-genesis.json" :: String)
+    , "RequiresNetworkMagic" Aeson..= ("RequiresNoMagic" :: String)
+    , "LastKnownBlockVersion-Major" Aeson..= (3 :: Int)
+    , "LastKnownBlockVersion-Minor" Aeson..= (0 :: Int)
+    , "LastKnownBlockVersion-Alt" Aeson..= (0 :: Int)
+    ]
+      <> map (uncurry (Aeson..=)) extras
+
+parseTriggers
+  :: (HasCallStack, MonadTest m)
+  => [(Aeson.Key, Aeson.Value)]
+  -> m Consensus.CardanoHardForkTriggers
+parseTriggers extras =
+  case Aeson.fromJSON $ nodeConfigWith extras of
+    Aeson.Error e -> withFrozenCallStack $ H.annotate e >> H.failure
+    Aeson.Success nc -> pure $ ncHardForkTriggers nc
+
+prop_parse_dijkstra_hard_fork_at_epoch :: Property
+prop_parse_dijkstra_hard_fork_at_epoch = propertyOnce $ do
+  triggers <- parseTriggers [("TestDijkstraHardForkAtEpoch", Aeson.toJSON (5 :: Int))]
+  case triggers of
+    Consensus.CardanoHardForkTriggers'{Consensus.triggerHardForkDijkstra = trigger} ->
+      case trigger of
+        Consensus.CardanoTriggerHardForkAtEpoch (EpochNo 5) -> H.success
+        other -> H.annotateShow other >> H.failure
+
+prop_parse_dijkstra_hard_fork_default :: Property
+prop_parse_dijkstra_hard_fork_default = propertyOnce $ do
+  triggers <- parseTriggers []
+  case triggers of
+    Consensus.CardanoHardForkTriggers'{Consensus.triggerHardForkDijkstra = trigger} ->
+      case trigger of
+        Consensus.CardanoTriggerHardForkAtDefaultVersion -> H.success
+        other -> H.annotateShow other >> H.failure
+
+tests :: TestTree
+tests =
+  testGroup
+    "Test.Cardano.Api.NodeConfig"
+    [ testProperty "parse TestDijkstraHardForkAtEpoch" prop_parse_dijkstra_hard_fork_at_epoch
+    , testProperty "parse Dijkstra hard fork default" prop_parse_dijkstra_hard_fork_default
+    ]

cardano-api/test/cardano-api-test/cardano-api-test.hs

@@ -25,6 +25,7 @@ import Test.Cardano.Api.KeysByron qualified
 import Test.Cardano.Api.Ledger qualified
 import Test.Cardano.Api.Leios qualified
 import Test.Cardano.Api.Metadata qualified
+import Test.Cardano.Api.NodeConfig qualified
 import Test.Cardano.Api.Ord qualified
 import Test.Cardano.Api.RawBytes qualified
 import Test.Cardano.Api.Transaction.Autobalance qualified
@@ -67,6 +68,7 @@ tests =
     , Test.Cardano.Api.Ledger.tests
     , Test.Cardano.Api.Leios.tests
     , Test.Cardano.Api.Metadata.tests
+    , Test.Cardano.Api.NodeConfig.tests
     , Test.Cardano.Api.Ord.tests
     , Test.Cardano.Api.RawBytes.tests
     , Test.Cardano.Api.Transaction.Body.Plutus.Scripts.tests