Merge #2370

2370: Introduce QueryHardFork r=mrBliss a=mrBliss

Fixes #2365.

* Introduce `QueryHardFork` for queries specific to the hard fork combinator,
  unrelated to any specific era. Provide a query to ask for an `Interpreter`,
  which can convert a slot to an epoch or time, etc.

* Generalise `QueryAnytime` so that the first era can also be queried. We
  still require there to be more than one era. Add the `QueryAnytimeByron`
  pattern synonym.

* Rename the `EraStart` constructor of `QueryAnytime` to `GetEraStart` for
  consistency.

* Change the encoding format of hard fork queries. Since they are not part of
  the final Shelley release yet (right?!), this is fine.


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

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

@@ -44,7 +44,13 @@ module Ouroboros.Consensus.Cardano.Block (
   , OneEraTipInfo (TipInfoByron, TipInfoShelley)
     -- * Query
   , CardanoQuery
-  , Query (QueryIfCurrentByron, QueryIfCurrentShelley, QueryAnytimeShelley)
+  , Query (
+        QueryIfCurrentByron
+      , QueryIfCurrentShelley
+      , QueryAnytimeByron
+      , QueryAnytimeShelley
+      , QueryHardFork
+     )
   , CardanoQueryResult
   , Either (QueryResultSuccess, QueryResultEraMismatch)
     -- * CodecConfig
@@ -296,8 +302,8 @@ pattern TipInfoShelley ti = OneEraTipInfo (S (Z (WrapTipInfo ti)))
 -- | The 'Query' of Cardano chain.
 --
 -- Thanks to the pattern synonyms, you can treat this as a sum type with
--- constructors 'QueryIfCurrentByron', 'QueryIfCurerntShelley', and
--- 'QueryAnytimeShelley'.
+-- constructors 'QueryIfCurrentByron', 'QueryIfCurrentShelley',
+-- 'QueryAnytimeByron', 'QueryAnytimeShelley', and 'QueryHardFork'.
 type CardanoQuery sc = Query (CardanoBlock sc)
 
 -- | Byron-specific query that can only be answered when the ledger in the
@@ -314,6 +320,19 @@ pattern QueryIfCurrentShelley
   -> CardanoQuery sc (CardanoQueryResult sc result)
 pattern QueryIfCurrentShelley q = QueryIfCurrent (QS (QZ q))
 
+-- | Query about the Byron era that can be answered anytime, i.e.,
+-- independent from where the tip of the ledger is.
+--
+-- For example, to ask for the start of the Byron era (whether the tip of
+-- the ledger is in the Byron or Shelley era), use:
+--
+-- > QueryAnytimeByron EraStart
+--
+pattern QueryAnytimeByron
+  :: QueryAnytime result
+  -> CardanoQuery sc result
+pattern QueryAnytimeByron q = QueryAnytime q (EraIndex (Z (K ())))
+
 -- | Query about the Shelley era that can be answered anytime, i.e.,
 -- independent from where the tip of the ledger is.
 --
@@ -325,11 +344,13 @@ pattern QueryIfCurrentShelley q = QueryIfCurrent (QS (QZ q))
 pattern QueryAnytimeShelley
   :: QueryAnytime result
   -> CardanoQuery sc result
-pattern QueryAnytimeShelley q = QueryAnytime q (EraIndex (Z (K ())))
+pattern QueryAnytimeShelley q = QueryAnytime q (EraIndex (S (Z (K ()))))
 
 {-# COMPLETE QueryIfCurrentByron
            , QueryIfCurrentShelley
-           , QueryAnytimeShelley #-}
+           , QueryAnytimeByron
+           , QueryAnytimeShelley
+           , QueryHardFork #-}
 
 -- | The result of a 'CardanoQuery'
 --

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

@@ -37,6 +37,7 @@ import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr)
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Storage.ChainDB.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
+import           Ouroboros.Consensus.Util.Counting (exactlyTwo)
 
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
@@ -147,19 +148,34 @@ injExamplesShelley Golden.Examples {..} = Golden.Examples {
 byronEraParams :: History.EraParams
 byronEraParams = Byron.byronEraParams History.NoLowerBound Byron.dummyConfig
 
+shelleyEraParams :: History.EraParams
+shelleyEraParams = Shelley.shelleyEraParams Shelley.testShelleyGenesis
+
 transitionEpoch :: EpochNo
 transitionEpoch = 10
 
+byronStartBound :: History.Bound
+byronStartBound = History.initBound
+
 byronEndBound :: History.Bound
 byronEndBound =
     History.mkUpperBound
       byronEraParams
-      History.initBound
+      byronStartBound
       transitionEpoch
 
 shelleyStartBound :: History.Bound
 shelleyStartBound = byronEndBound
 
+summary :: History.Summary (CardanoEras Crypto)
+summary =
+    State.reconstructSummary
+      (History.Shape (exactlyTwo byronEraParams shelleyEraParams))
+      (State.TransitionKnown transitionEpoch)
+      (getHardForkLedgerState (ledgerStateByron byronLedger))
+  where
+    (_, byronLedger) = head $ Golden.exampleLedgerState Byron.examples
+
 eraInfoByron :: SingleEraInfo ByronBlock
 eraInfoByron = singleEraInfo (Proxy @ByronBlock)
 
@@ -321,12 +337,16 @@ multiEraExamples = mempty {
         , ("WrongEraShelley", exampleApplyTxErrWrongEraShelley)
         ]
     , Golden.exampleQuery = labelled [
-          ("AnytimeShelley", exampleQueryAnytimeShelley)
+          ("AnytimeByron",   exampleQueryAnytimeByron)
+        , ("AnytimeShelley", exampleQueryAnytimeShelley)
+        , ("HardFork",       exampleQueryHardFork)
         ]
     , Golden.exampleResult = labelled [
           ("EraMismatchByron",   exampleResultEraMismatchByron)
         , ("EraMismatchShelley", exampleResultEraMismatchShelley)
+        , ("AnytimeByron",       exampleResultAnytimeByron)
         , ("AnytimeShelley",     exampleResultAnytimeShelley)
+        , ("HardFork",           exampleResultHardFork)
         ]
     , Golden.exampleLedgerState = labelled [
           ("WithSnapshot", exampleLedgerStateWithSnapshot)
@@ -367,9 +387,17 @@ exampleQueryEraMismatchShelley :: SomeBlock Query (CardanoBlock Crypto)
 exampleQueryEraMismatchShelley =
     SomeBlock (QueryIfCurrentByron Byron.GetUpdateInterfaceState)
 
+exampleQueryAnytimeByron :: SomeBlock Query (CardanoBlock Crypto)
+exampleQueryAnytimeByron =
+    SomeBlock (QueryAnytimeByron GetEraStart)
+
 exampleQueryAnytimeShelley :: SomeBlock Query (CardanoBlock Crypto)
 exampleQueryAnytimeShelley =
-    SomeBlock (QueryAnytimeShelley EraStart)
+    SomeBlock (QueryAnytimeShelley GetEraStart)
+
+exampleQueryHardFork :: SomeBlock Query (CardanoBlock Crypto)
+exampleQueryHardFork =
+    SomeBlock (QueryHardFork GetInterpreter)
 
 exampleResultEraMismatchByron :: SomeResult (CardanoBlock Crypto)
 exampleResultEraMismatchByron =
@@ -383,9 +411,17 @@ exampleResultEraMismatchShelley =
       (QueryIfCurrentByron Byron.GetUpdateInterfaceState)
       (Left exampleEraMismatchShelley)
 
+exampleResultAnytimeByron :: SomeResult (CardanoBlock Crypto)
+exampleResultAnytimeByron =
+    SomeResult (QueryAnytimeByron GetEraStart) (Just byronStartBound)
+
 exampleResultAnytimeShelley :: SomeResult (CardanoBlock Crypto)
 exampleResultAnytimeShelley =
-    SomeResult (QueryAnytimeShelley EraStart) (Just shelleyStartBound)
+    SomeResult (QueryAnytimeShelley GetEraStart) (Just shelleyStartBound)
+
+exampleResultHardFork :: SomeResult (CardanoBlock Crypto)
+exampleResultHardFork =
+    SomeResult (QueryHardFork GetInterpreter) (History.mkInterpreter summary)
 
 exampleLedgerStateWithSnapshot :: LedgerState (CardanoBlock Crypto)
 exampleLedgerStateWithSnapshot =

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

@@ -19,19 +19,22 @@ module Test.Consensus.Cardano.Generators (
 import           Cardano.Crypto.Hash (Hash, HashAlgorithm)
 import           Data.Coerce
 import qualified Data.Map.Strict as Map
+import           Data.Maybe (fromMaybe)
 import           Data.Proxy
-import           Data.SOP.Strict (NP (..), NS (..))
+import           Data.SOP.Strict (NP (..), NS (..), SListI, lengthSList)
 
 import           Test.QuickCheck
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime (RelativeTime (..))
-import           Ouroboros.Consensus.HardFork.History (Bound (..))
+import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.Serialisation (Some (..))
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.TypeFamilyWrappers
+import           Ouroboros.Consensus.Util.Counting (NonEmpty (..),
+                     nonEmptyFromList)
 
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation
@@ -67,14 +70,14 @@ instance HashAlgorithm h => Arbitrary (CardanoBlock (TPraosMockCrypto h)) where
 instance HashAlgorithm h => Arbitrary (CardanoHeader (TPraosMockCrypto h)) where
   arbitrary = getHeader <$> arbitrary
 
--- TODO if we try to use arbitrary instances for `SlotNo` and `EpochNo` here, we
+-- TODO if we try to use arbitrary instances for 'SlotNo' and 'EpochNo' here, we
 -- hit a conflict, since they exist both in byron generators and shelley
 -- generators.
-instance Arbitrary Bound where
+instance Arbitrary History.Bound where
   arbitrary =
-    Bound <$> (RelativeTime <$> arbitrary)
-          <*> (SlotNo <$> arbitrary)
-          <*> (EpochNo <$> arbitrary)
+      History.Bound <$> (RelativeTime <$> arbitrary)
+                    <*> (SlotNo       <$> arbitrary)
+                    <*> (EpochNo      <$> arbitrary)
 
 arbitraryHardForkState
   :: forall f sc a.
@@ -292,33 +295,90 @@ instance (sc ~ TPraosMockCrypto h, HashAlgorithm h, forall a. Arbitrary (Hash h
       ]
 
 instance Arbitrary (Some QueryAnytime) where
-  arbitrary = return $ Some EraStart
+  arbitrary = return $ Some GetEraStart
+
+instance Arbitrary (Some (QueryHardFork (CardanoEras sc))) where
+  arbitrary = return $ Some GetInterpreter
 
 instance (sc ~ TPraosMockCrypto h, HashAlgorithm h)
       => Arbitrary (WithVersion (HardForkNodeToClientVersion (CardanoEras sc))
                                 (SomeBlock Query (CardanoBlock sc))) where
   arbitrary = frequency
-      [ (9, arbitraryNodeToClient injByron injShelley)
+      [ (1, arbitraryNodeToClient injByron injShelley)
+      , (1, WithVersion
+              <$> (getHardForkEnabledNodeToClientVersion <$> arbitrary)
+              <*> (injAnytimeByron <$> arbitrary))
       , (1, WithVersion
               <$> (getHardForkEnabledNodeToClientVersion <$> arbitrary)
               <*> (injAnytimeShelley <$> arbitrary))
+      , (1, WithVersion
+              <$> (getHardForkEnabledNodeToClientVersion <$> arbitrary)
+              <*> (injHardFork <$> arbitrary))
       ]
     where
       injByron          (SomeBlock query) = SomeBlock (QueryIfCurrentByron   query)
       injShelley        (SomeBlock query) = SomeBlock (QueryIfCurrentShelley query)
+      injAnytimeByron   (Some      query) = SomeBlock (QueryAnytimeByron     query)
       injAnytimeShelley (Some      query) = SomeBlock (QueryAnytimeShelley   query)
+      injHardFork       (Some      query) = SomeBlock (QueryHardFork         query)
+
+instance Arbitrary History.EraEnd where
+  arbitrary = oneof
+      [ History.EraEnd <$> arbitrary
+      , return History.EraUnbounded
+      ]
+
+instance Arbitrary History.SafeBeforeEpoch where
+  arbitrary = oneof
+      [ return History.NoLowerBound
+      , History.LowerBound . EpochNo <$> arbitrary
+      , return History.UnsafeUnbounded
+      ]
+
+instance Arbitrary History.SafeZone where
+  arbitrary = History.SafeZone
+      <$> arbitrary
+      <*> arbitrary
+
+instance Arbitrary History.EraParams where
+  arbitrary = History.EraParams
+      <$> (EpochSize <$> arbitrary)
+      <*> arbitrary
+      <*> arbitrary
+
+instance Arbitrary History.EraSummary where
+  arbitrary = History.EraSummary
+      <$> arbitrary
+      <*> arbitrary
+      <*> arbitrary
+
+instance (Arbitrary a, SListI xs) => Arbitrary (NonEmpty xs a) where
+  arbitrary = do
+      let nbXs = lengthSList (Proxy @xs)
+      len <- choose (1, nbXs)
+      xs  <- vectorOf len arbitrary
+      return $ fromMaybe (error "nonEmptyFromList failed") $ nonEmptyFromList xs
+
+instance Arbitrary (History.Interpreter (CardanoEras sc)) where
+  arbitrary = History.mkInterpreter . History.Summary <$> arbitrary
 
 instance (sc ~ TPraosMockCrypto h, HashAlgorithm h)
       => Arbitrary (WithVersion (HardForkNodeToClientVersion (CardanoEras sc))
                                 (SomeResult (CardanoBlock sc))) where
   arbitrary = frequency
-      [ (8, arbitraryNodeToClient injByron injShelley)
-      , (2, WithVersion
+      [ (1, arbitraryNodeToClient injByron injShelley)
+      , (1, WithVersion
               <$> (getHardForkEnabledNodeToClientVersion <$> arbitrary)
               <*> genQueryIfCurrentResultEraMismatch)
       , (1, WithVersion
               <$> (getHardForkEnabledNodeToClientVersion <$> arbitrary)
-              <*> genQueryAnytimeResult)
+              <*> genQueryAnytimeResultByron)
+      , (1, WithVersion
+              <$> (getHardForkEnabledNodeToClientVersion <$> arbitrary)
+              <*> genQueryAnytimeResultShelley)
+      , (1, WithVersion
+              <$> (getHardForkEnabledNodeToClientVersion <$> arbitrary)
+              <*> genQueryHardForkResult)
       ]
     where
       injByron   (SomeResult q r) = SomeResult (QueryIfCurrentByron   q) (QueryResultSuccess r)
@@ -339,9 +399,17 @@ instance (sc ~ TPraosMockCrypto h, HashAlgorithm h)
               <$> arbitrary <*> arbitrary
           ]
 
-      genQueryAnytimeResult :: Gen (SomeResult (CardanoBlock sc))
-      genQueryAnytimeResult =
-          SomeResult (QueryAnytimeShelley EraStart) <$> arbitrary
+      genQueryAnytimeResultByron :: Gen (SomeResult (CardanoBlock sc))
+      genQueryAnytimeResultByron =
+          SomeResult (QueryAnytimeByron GetEraStart) <$> arbitrary
+
+      genQueryAnytimeResultShelley :: Gen (SomeResult (CardanoBlock sc))
+      genQueryAnytimeResultShelley =
+          SomeResult (QueryAnytimeShelley GetEraStart) <$> arbitrary
+
+      genQueryHardForkResult :: Gen (SomeResult (CardanoBlock sc))
+      genQueryHardForkResult =
+          SomeResult (QueryHardFork GetInterpreter) <$> arbitrary
 
 instance (sc ~ TPraosMockCrypto h, HashAlgorithm h)
       => Arbitrary (MismatchEraInfo (CardanoEras sc)) where

ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs

@@ -142,3 +142,7 @@ instance Serialise RelativeTime where
     where
       fromPico :: Pico -> NominalDiffTime
       fromPico = realToFrac
+
+instance Serialise SlotLength where
+  encode = encode . slotLengthToMillisec
+  decode = slotLengthFromMillisec <$> decode

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs

@@ -202,7 +202,7 @@ getSameValue
   -> a
 getSameValue values =
     case isNonEmpty (Proxy @xs) of
-      ProofNonEmpty _ ->
+      ProofNonEmpty {} ->
         assertWithMsg allEqualCheck (unK (hd values))
   where
     allEqualCheck :: Either String ()

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Block.hs

@@ -206,11 +206,11 @@ instance CanHardFork xs => HasAnnTip (HardForkBlock xs) where
 instance CanHardFork xs => BasicEnvelopeValidation (HardForkBlock xs) where
   expectedFirstBlockNo _ =
       case isNonEmpty (Proxy @xs) of
-        ProofNonEmpty p -> expectedFirstBlockNo p
+        ProofNonEmpty p _ -> expectedFirstBlockNo p
 
   minimumPossibleSlotNo _ =
       case isNonEmpty (Proxy @xs) of
-        ProofNonEmpty p -> minimumPossibleSlotNo p
+        ProofNonEmpty p _ -> minimumPossibleSlotNo p
 
   -- TODO: If the block is from a different era as the current tip, we just
   -- expect @succ b@. This may not be sufficient: if we ever transition /to/

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -182,7 +183,7 @@ instance CanHardFork xs => UpdateLedger (HardForkBlock xs)
   HasHardForkHistory
 -------------------------------------------------------------------------------}
 
-instance CanHardFork xs => HasHardForkHistory (HardForkBlock xs) where
+instance All SingleEraBlock xs => HasHardForkHistory (HardForkBlock xs) where
   type HardForkIndices (HardForkBlock xs) = xs
 
   hardForkSummary cfg = State.reconstructSummaryLedger cfg