Add support for querying systemStart

IntersectMBO · May 13, 2021 · b9eebc0 · b9eebc0
1 parent cf10843
commit b9eebc0
Show file tree

Hide file tree

Showing 5 changed files with 41 additions and 15 deletions.
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs
@@ -25,10 +25,13 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types (
   , SlotLength
   ) where
 
-import           Data.Time.Clock (NominalDiffTime)
+import           Cardano.Slotting.Time
+import           Data.Time (NominalDiffTime)
 import           NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
 
-import           Cardano.Slotting.Time
+{-------------------------------------------------------------------------------
+  Relative time
+-------------------------------------------------------------------------------}
 
 addRelTime :: NominalDiffTime -> RelativeTime -> RelativeTime
 addRelTime = addRelativeTime

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Compat.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Compat.hs
@@ -26,6 +26,8 @@ import           Ouroboros.Consensus.HardFork.History.Summary (Bound, Summary,
                      initBound, neverForksSummary)
 import           Ouroboros.Consensus.Util.SOP
 
+import           Ouroboros.Consensus.Config (TopLevelConfig, configBlock)
+import qualified Ouroboros.Consensus.Config.SupportsNode as SN
 import           Ouroboros.Consensus.HardFork.Abstract
 import           Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
 import           Ouroboros.Consensus.HardFork.Combinator.Basics
@@ -97,12 +99,14 @@ forwardCompatQuery f = go
 -- is using the HFC but with a single era only.
 singleEraCompatQuery ::
        forall m blk era. (Monad m, HardForkIndices blk ~ '[era])
-    => EpochSize
+    => SN.ConfigSupportsNode blk
+    => TopLevelConfig blk
+    -> EpochSize
     -> SlotLength
     -> (forall result. BlockQuery blk result -> m result)
     -- ^ Submit a query through the LocalStateQuery protocol.
     -> (forall result. HardForkCompatQuery blk result -> m result)
-singleEraCompatQuery epochSize slotLen f = go
+singleEraCompatQuery cfg epochSize slotLen f = go
   where
     go :: HardForkCompatQuery blk result -> m result
     go (CompatIfCurrent qry)    = f qry
@@ -115,6 +119,7 @@ singleEraCompatQuery epochSize slotLen f = go
     goHardFork :: QueryHardFork '[era] result -> m result
     goHardFork GetInterpreter = return $ Qry.mkInterpreter summary
     goHardFork GetCurrentEra  = return $ eraIndexZero
+    goHardFork GetSystemStart = return $ SN.getSystemStart (configBlock cfg)
 
     summary :: Summary '[era]
     summary = neverForksSummary epochSize slotLen

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs
@@ -62,6 +62,8 @@ import           Ouroboros.Consensus.TypeFamilyWrappers (WrapChainDepState (..))
 import           Ouroboros.Consensus.Util (ShowProxy)
 import           Ouroboros.Consensus.Util.Counting (getExactly)
 
+import           Ouroboros.Consensus.BlockchainTime.WallClock.Types
+                     (SystemStart)
 import           Ouroboros.Consensus.HardFork.Combinator.Abstract
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
 import           Ouroboros.Consensus.HardFork.Combinator.Basics
@@ -74,6 +76,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.State (Current (..),
 import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
 import           Ouroboros.Consensus.HardFork.Combinator.Util.Match
                      (Mismatch (..), mustMatchNS)
+import qualified Ouroboros.Consensus.Config.SupportsNode as SN
 
 instance Typeable xs => ShowProxy (BlockQuery (HardForkBlock xs)) where
 
@@ -112,11 +115,10 @@ data instance BlockQuery (HardForkBlock xs) :: Type -> Type where
     => QueryHardFork (x ': xs) result
     -> BlockQuery (HardForkBlock (x ': xs)) result
 
-instance All SingleEraBlock xs => QueryLedger (HardForkBlock xs) where
-  answerBlockQuery
-    (ExtLedgerCfg cfg)
-    query
-    ext@(ExtLedgerState st@(HardForkLedgerState hardForkState) _) =
+instance (All SingleEraBlock xs, SN.ConfigSupportsNode (HardForkBlock xs)) => QueryLedger (HardForkBlock xs) where
+  answerBlockQuery (ExtLedgerCfg cfg)
+              query
+              ext@(ExtLedgerState st@(HardForkLedgerState hardForkState) _) =
       case query of
         QueryIfCurrent queryIfCurrent ->
           interpretQueryIfCurrent
@@ -131,7 +133,7 @@ instance All SingleEraBlock xs => QueryLedger (HardForkBlock xs) where
             hardForkState
         QueryHardFork queryHardFork ->
           interpretQueryHardFork
-            lcfg
+            cfg
             queryHardFork
             st
     where
@@ -312,12 +314,14 @@ answerQueryAnytime HardForkLedgerConfig{..} =
 data QueryHardFork xs result where
   GetInterpreter :: QueryHardFork xs (History.Interpreter xs)
   GetCurrentEra  :: QueryHardFork xs (EraIndex xs)
+  GetSystemStart :: QueryHardFork xs SystemStart
 
 deriving instance Show (QueryHardFork xs result)
 
 instance All SingleEraBlock xs => ShowQuery (QueryHardFork xs) where
   showResult GetInterpreter = show
   showResult GetCurrentEra  = show
+  showResult GetSystemStart = show
 
 instance SameDepIndex (QueryHardFork xs) where
   sameDepIndex GetInterpreter GetInterpreter =
@@ -328,19 +332,26 @@ instance SameDepIndex (QueryHardFork xs) where
       Just Refl
   sameDepIndex GetCurrentEra _ =
       Nothing
+  sameDepIndex GetSystemStart GetSystemStart =
+      Just Refl
+  sameDepIndex GetSystemStart _ =
+      Nothing
 
 interpretQueryHardFork ::
      All SingleEraBlock xs
-  => HardForkLedgerConfig xs
+  => SN.ConfigSupportsNode (HardForkBlock xs)
+  => TopLevelConfig (HardForkBlock xs)
   -> QueryHardFork xs result
   -> LedgerState (HardForkBlock xs)
   -> result
 interpretQueryHardFork cfg query st =
     case query of
       GetInterpreter ->
-        History.mkInterpreter $ hardForkSummary cfg st
+        History.mkInterpreter $ hardForkSummary (configLedger cfg) st
       GetCurrentEra  ->
         eraIndexFromNS $ State.tip $ hardForkLedgerStatePerEra st
+      GetSystemStart  ->
+        SN.getSystemStart (configBlock cfg)
 
 {-------------------------------------------------------------------------------
   Serialisation
@@ -371,13 +382,15 @@ encodeQueryHardForkResult ::
 encodeQueryHardForkResult = \case
     GetInterpreter -> encode
     GetCurrentEra  -> encode
+    GetSystemStart -> encode
 
 decodeQueryHardForkResult ::
      SListI xs
   => QueryHardFork xs result -> forall s. Decoder s result
 decodeQueryHardForkResult = \case
     GetInterpreter -> decode
     GetCurrentEra  -> decode
+    GetSystemStart -> decode
 
 {-------------------------------------------------------------------------------
   Auxiliary

diff --git a/...sensus/src/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseNodeToClient.hs b/...sensus/src/Ouroboros/Consensus/HardFork/Combinator/Serialisation/SerialiseNodeToClient.hs
@@ -188,6 +188,10 @@ encodeQueryHardFork vHfc = \case
         Enc.encodeListLen 1
       , Enc.encodeWord8 1
       ]
+    Some GetSystemStart -> mconcat [
+        Enc.encodeListLen 1
+      , Enc.encodeWord8 2
+      ]
 
 decodeQueryHardFork :: Decoder s (Some (QueryHardFork xs))
 decodeQueryHardFork = do
@@ -196,6 +200,7 @@ decodeQueryHardFork = do
     case tag of
       0 -> return $ Some GetInterpreter
       1 -> return $ Some GetCurrentEra
+      2 -> return $ Some GetSystemStart
       _ -> fail $ "QueryHardFork: invalid tag " ++ show tag
 
 instance SerialiseHFC xs

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Query.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Query.hs
@@ -24,9 +24,6 @@ module Ouroboros.Consensus.Ledger.Query (
 import           Data.Kind (Type)
 import           Data.Maybe (isJust)
 
-import           Ouroboros.Network.Protocol.LocalStateQuery.Type
-                     (ShowQuery (..))
-
 import           Cardano.Binary
 import           Ouroboros.Consensus.Block.Abstract (CodecConfig)
 import           Ouroboros.Consensus.Config (topLevelConfigLedger)
@@ -39,6 +36,9 @@ import           Ouroboros.Consensus.Node.Serialisation
 import           Ouroboros.Consensus.Util (ShowProxy (..), SomeSecond (..))
 import           Ouroboros.Consensus.Util.DepPair
 
+import           Ouroboros.Network.Protocol.LocalStateQuery.Type
+                     (ShowQuery (..))
+
 {-------------------------------------------------------------------------------
   Queries
 -------------------------------------------------------------------------------}