Merge #3036

3036: Provide slot-to-time conversion to ledger r=nfrisby a=nfrisby Fixes #3052. Addresses CAD-2713. The ledger needs to be able to convert slots to UTC times, so as of this PR, the HFC now provides that to the ledger. See the commit message for more details. Co-authored-by: Nicolas Frisby <nick.frisby@iohk.io>
IntersectMBO · Apr 27, 2021 · 9b279c7 · 9b279c7
2 parents b4baec8 + 7cea373
commit 9b279c7
Show file tree

Hide file tree

Showing 11 changed files with 64 additions and 146 deletions.
diff --git a/cabal.project b/cabal.project
@@ -161,8 +161,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-base
-  tag: 4b4c866436fc9ad345f3d6badb02ff65b7fe5579
-  --sha256: 1w8qpfkrl64mvn4ga5pqavljk2bm5rh52f1hr56vlvl35q5ja5hv
+  tag: 47db5b818ca4fa051f2e44cdf5e7c5c18c1fb0bf
+  --sha256: 0fr0r5dwfmsp15j19xh20js8nzsqyhwx4q797rxsvpyjfabb2y11
   subdir:
     binary
     binary/test
@@ -174,8 +174,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: 7a24a6e752a24ccbca30a0f16af8fd868d3b6933
-  --sha256: 1xss7a3q9yznb1qq5rm8w2j1jsa5rmr96pnplrg1ixy55jqsdhly
+  tag: e8f19bcc9c8f405131cb95ca6ada26b2b4eac638
+  --sha256: 1v36d3lyhmadzj0abdfsppjna7n7llzqzp9ikx5yq28l2kda2f1p
   subdir:
     byron/chain/executable-spec
     byron/crypto
@@ -203,11 +203,3 @@ source-repository-package
   location: https://github.com/input-output-hk/cardano-crypto/
   tag: f73079303f663e028288f9f4a9e08bcca39a923e
   --sha256: 1n87i15x54s0cjkh3nsxs4r1x016cdw1fypwmr68936n3xxsjn6q
-
--- The r0 revision of this quickcheck-state-machine-0.7 on Hackage adds a lower
--- bound on the text package: >=1.2.4.0. However, 1.2.4.0 doesn't support GHC
--- 8.10, 1.2.4.1 will, but that hasn't been released yet. GHC 8.10 is bundled
--- with 1.2.3.2, so override quickcheck-state-machine's lower bound to support
--- an "older" version of text. See
--- https://github.com/advancedtelematic/quickcheck-state-machine/issues/371
-allow-older: quickcheck-state-machine:text
diff --git a/ouroboros-consensus-cardano-test/src/Test/ThreadNet/Infra/TwoEras.hs b/ouroboros-consensus-cardano-test/src/Test/ThreadNet/Infra/TwoEras.hs
@@ -33,7 +33,6 @@ module Test.ThreadNet.Infra.TwoEras (
   ) where
 
 import           Control.Exception (assert)
-import           Control.Monad.Identity (Identity (runIdentity))
 import           Data.Functor ((<&>))
 import qualified Data.Map as Map
 import           Data.Maybe (isJust)
@@ -305,15 +304,12 @@ secondEraOverlaySlots numSlots (NumSlots numFirstEraSlots) d secondEraEpochSize
         Set.fromList $
         -- Note: this is only correct if each epoch uses the same value for @d@
         SL.overlaySlots
-          (runIdentity $ epochInfoFirst epochInfo (EpochNo i))
+          -- Suitable only for this narrow context
+          (fixedEpochInfoFirst secondEraEpochSize (EpochNo i))
           -- notably contains setupD
           d
             -- NB 0 <-> the first epoch of the second era
-          (runIdentity $ epochInfoSize epochInfo (EpochNo i))
-
-    -- Suitable only for this narrow context
-    epochInfo :: EpochInfo Identity
-    epochInfo = fixedSizeEpochInfo secondEraEpochSize
+          secondEraEpochSize
 
 tabulatePartitionPosition ::
      NumSlots -> Partition -> Bool -> Property -> Property

diff --git a/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Protocol/Praos.hs b/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Protocol/Praos.hs
@@ -48,7 +48,6 @@ import           Codec.CBOR.Encoding (encodeListLen)
 import           Codec.Serialise (Serialise (..))
 import           Control.Monad (unless)
 import           Control.Monad.Except (throwError)
-import           Control.Monad.Identity (runIdentity)
 import           Data.Kind (Type)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -381,16 +380,15 @@ data instance ConsensusConfig (Praos c) = PraosConfig
 instance PraosCrypto c => NoThunks (ConsensusConfig (Praos c))
 
 slotEpoch :: ConsensusConfig (Praos c) -> SlotNo -> EpochNo
-slotEpoch PraosConfig{praosParams = PraosParams{..}} s =
-    runIdentity $ epochInfoEpoch epochInfo s
+slotEpoch PraosConfig{..} s =
+    fixedEpochInfoEpoch (EpochSize praosSlotsPerEpoch) s
   where
-    epochInfo = fixedSizeEpochInfo (EpochSize praosSlotsPerEpoch)
+    PraosParams{..} = praosParams
 
 epochFirst :: ConsensusConfig (Praos c) -> EpochNo -> SlotNo
 epochFirst PraosConfig{..} e =
-    runIdentity $ epochInfoFirst epochInfo e
+    fixedEpochInfoFirst (EpochSize praosSlotsPerEpoch) e
   where
-    epochInfo = fixedSizeEpochInfo (EpochSize praosSlotsPerEpoch)
     PraosParams{..} = praosParams
 
 -- |The chain dependent state, in this case as it is a mock, we just will store

diff --git a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs
@@ -95,8 +95,6 @@ import qualified Shelley.Spec.Ledger.STS.Delegs as SL
                      (DelegsPredicateFailure (..))
 import qualified Shelley.Spec.Ledger.STS.Ledger as SL
                      (LedgerPredicateFailure (..))
-import qualified Shelley.Spec.Ledger.STS.Ledgers as SL
-                     (LedgersPredicateFailure (..))
 import qualified Shelley.Spec.Ledger.Tx as SL (addrWits)
 import qualified Shelley.Spec.Ledger.UTxO as SL (makeWitnessesVKey)
 import qualified Test.Shelley.Spec.Ledger.Generator.Core as SL
@@ -211,8 +209,6 @@ keyToCredential = SL.KeyHashObj . SL.hashKey . SL.vKey
 examples ::
      forall era.
      ( ShelleyBasedEra era
-     ,   SL.PredicateFailure (Core.EraRule "LEDGER" era)
-       ~ SL.LedgerPredicateFailure era
      ,   SL.PredicateFailure (Core.EraRule "DELEGS" era)
        ~ SL.DelegsPredicateFailure era
      , Core.PParams era ~ SL.PParams era
@@ -513,16 +509,13 @@ exampleTx txBody auxiliaryData = SL.Tx txBody witnessSet (SJust auxiliaryData)
 exampleApplyTxErr ::
      forall era.
      ( ShelleyBasedEra era
-     ,   SL.PredicateFailure (Core.EraRule "LEDGER" era)
-       ~ SL.LedgerPredicateFailure era
      ,   SL.PredicateFailure (Core.EraRule "DELEGS" era)
        ~ SL.DelegsPredicateFailure era
      )
   => ApplyTxErr (ShelleyBlock era)
 exampleApplyTxErr =
       ApplyTxError
     $ pure
-    $ SL.LedgerFailure
     $ SL.DelegsFailure
     $ SL.DelegateeNotRegisteredDELEG @era (mkKeyHash 1)
 

diff --git a/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs b/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs
@@ -12,7 +12,7 @@ import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
 import           Cardano.Crypto.Hash (ShortHash)
-import           Cardano.Slotting.EpochInfo (fixedSizeEpochInfo)
+import           Cardano.Slotting.EpochInfo (fixedEpochInfo)
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config.SecurityParam
@@ -369,5 +369,5 @@ prop_simple_real_tpraos_convergence TestSetup
         ledgerConfig :: LedgerConfig (ShelleyBlock Era)
         ledgerConfig = Shelley.mkShelleyLedgerConfig
             genesisConfig
-            (fixedSizeEpochInfo epochSize)
+            (fixedEpochInfo epochSize tpraosSlotLength)
             (MaxMajorProtVer 1000) -- TODO
diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs
@@ -51,6 +51,7 @@ import           GHC.Stack (HasCallStack)
 
 import qualified Cardano.Crypto.VRF as VRF
 import           Cardano.Slotting.EpochInfo
+import           Cardano.Slotting.Time (mkSlotLength)
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
@@ -294,7 +295,10 @@ protocolInfoShelleyBased ProtocolParamsShelleyBased {
     ledgerConfig = mkShelleyLedgerConfig genesis epochInfo maxMajorProtVer
 
     epochInfo :: EpochInfo Identity
-    epochInfo = fixedSizeEpochInfo $ SL.sgEpochLength genesis
+    epochInfo =
+        fixedEpochInfo
+          (SL.sgEpochLength genesis)
+          (mkSlotLength $ SL.sgSlotLength genesis)
 
     tpraosParams :: TPraosParams
     tpraosParams = mkTPraosParams maxMajorProtVer initialNonce genesis

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs
@@ -56,6 +56,7 @@ import           Numeric.Natural (Natural)
 import           Cardano.Binary (enforceSize, fromCBOR, toCBOR)
 import qualified Cardano.Crypto.VRF as VRF
 import           Cardano.Slotting.EpochInfo
+import           Cardano.Slotting.Time (SystemStart (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Protocol.Abstract
@@ -197,6 +198,8 @@ data TPraosParams = TPraosParams {
       -- the Shelley 'ChainDepState', at which point we'll need access to the
       -- initial nonce at runtime. TODO #2326.
     , tpraosInitialNonce      :: !SL.Nonce
+      -- | The system start, as projected from the chain's genesis block.
+    , tpraosSystemStart       :: !SystemStart
     }
   deriving (Generic, NoThunks)
 
@@ -215,9 +218,11 @@ mkTPraosParams maxMajorPV initialNonce genesis = TPraosParams {
     , tpraosSecurityParam     = securityParam
     , tpraosMaxMajorPV        = maxMajorPV
     , tpraosInitialNonce      = initialNonce
+    , tpraosSystemStart       = systemStart
     }
   where
     securityParam = SecurityParam $ SL.sgSecurityParam genesis
+    systemStart   = SystemStart   $ SL.sgSystemStart   genesis
 
 data TPraosCanBeLeader c = TPraosCanBeLeader {
       -- | Certificate delegating rights from the stake pool cold key (or
@@ -248,6 +253,11 @@ instance PraosCrypto c => NoThunks (TPraosIsLeader c)
 data instance ConsensusConfig (TPraos c) = TPraosConfig {
       tpraosParams    :: !TPraosParams
     , tpraosEpochInfo :: !(EpochInfo Identity)
+
+      -- it's useful for this record to be EpochInfo and one other thing,
+      -- because the one other thing can then be used as the
+      -- PartialConsensConfig in the HFC instance.
+
     }
   deriving (Generic)
 
@@ -414,7 +424,7 @@ instance PraosCrypto c => ConsensusProtocol (TPraos c) where
 
       SL.GenDelegs dlgMap = SL.lvGenDelegs lv
 
-  tickChainDepState TPraosConfig{..}
+  tickChainDepState cfg@TPraosConfig{..}
                     (TickedPraosLedgerView lv)
                     slot
                     (TPraosState lastSlot st) =
@@ -428,33 +438,33 @@ instance PraosCrypto c => ConsensusProtocol (TPraos c) where
               lv
               (isNewEpoch tpraosEpochInfo lastSlot slot)
               st
-      shelleyGlobals = mkShelleyGlobals tpraosEpochInfo tpraosParams
+      shelleyGlobals = mkShelleyGlobals cfg
 
-  updateChainDepState TPraosConfig{..} b slot cs =
+  updateChainDepState cfg b slot cs =
       TPraosState (NotOrigin slot) <$>
         SL.updateChainDepState
           shelleyGlobals
           lv
           b
           (tickedTPraosStateChainDepState cs)
     where
-      shelleyGlobals = mkShelleyGlobals tpraosEpochInfo tpraosParams
+      shelleyGlobals = mkShelleyGlobals cfg
       lv = getTickedPraosLedgerView (tickedTPraosStateLedgerView cs)
 
-  reupdateChainDepState TPraosConfig{..} b slot cs =
+  reupdateChainDepState cfg b slot cs =
       TPraosState (NotOrigin slot) $
         SL.reupdateChainDepState
           shelleyGlobals
           lv
           b
           (tickedTPraosStateChainDepState cs)
     where
-      shelleyGlobals = mkShelleyGlobals tpraosEpochInfo tpraosParams
+      shelleyGlobals = mkShelleyGlobals cfg
       lv = getTickedPraosLedgerView (tickedTPraosStateLedgerView cs)
 
-mkShelleyGlobals :: EpochInfo Identity -> TPraosParams -> SL.Globals
-mkShelleyGlobals epochInfo TPraosParams {..} = SL.Globals {
-      epochInfo                     = epochInfo
+mkShelleyGlobals :: ConsensusConfig (TPraos c) -> SL.Globals
+mkShelleyGlobals TPraosConfig{..} = SL.Globals {
+      epochInfo                     = tpraosEpochInfo
     , slotsPerKESPeriod             = tpraosSlotsPerKESPeriod
     , stabilityWindow               = SL.computeStabilityWindow               k tpraosLeaderF
     , randomnessStabilisationWindow = SL.computeRandomnessStabilisationWindow k tpraosLeaderF
@@ -465,9 +475,11 @@ mkShelleyGlobals epochInfo TPraosParams {..} = SL.Globals {
     , maxLovelaceSupply             = tpraosMaxLovelaceSupply
     , activeSlotCoeff               = tpraosLeaderF
     , networkId                     = tpraosNetworkId
+    , systemStart                   = tpraosSystemStart
     }
   where
-    SecurityParam k = tpraosSecurityParam
+    SecurityParam k  = tpraosSecurityParam
+    TPraosParams{..} = tpraosParams
 
 -- | Check whether this node meets the leader threshold to issue a block.
 meetsLeaderThreshold ::

diff --git a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/History.hs b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/History.hs
@@ -802,6 +802,8 @@ hardForkEpochInfo ArbitraryChain{..} for =
                  epochInfoSize_  = \_ -> throw err
                , epochInfoFirst_ = \_ -> throw err
                , epochInfoEpoch_ = \_ -> throw err
+
+               , epochInfoSlotToRelativeTime_ = \_ -> throw err
                }
            , "<out of range>"
            , "<out of range>"

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
@@ -26,49 +25,16 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types (
   , SlotLength
   ) where
 
-import           Codec.Serialise
-import           Control.Exception (assert)
-import           Data.Fixed
-import           Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)
-import           GHC.Generics (Generic)
-import           NoThunks.Class (InspectHeap (..), NoThunks,
-                     OnlyCheckWhnfNamed (..))
-import           Quiet
+import           Data.Time.Clock (NominalDiffTime)
+import           NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
 
-{-------------------------------------------------------------------------------
-  System start
--------------------------------------------------------------------------------}
-
--- | System start
---
--- Slots are counted from the system start.
-newtype SystemStart = SystemStart { getSystemStart :: UTCTime }
-  deriving (Eq, Generic)
-  deriving NoThunks via InspectHeap SystemStart
-  deriving Show via Quiet SystemStart
-
-{-------------------------------------------------------------------------------
-  Relative time
--------------------------------------------------------------------------------}
-
--- | 'RelativeTime' is time relative to the 'SystemStart'
-newtype RelativeTime = RelativeTime { getRelativeTime :: NominalDiffTime }
-  deriving stock   (Eq, Ord, Generic)
-  deriving newtype (NoThunks)
-  deriving Show via Quiet RelativeTime
+import           Cardano.Slotting.Time
 
 addRelTime :: NominalDiffTime -> RelativeTime -> RelativeTime
-addRelTime delta (RelativeTime t) = RelativeTime (t + delta)
+addRelTime = addRelativeTime
 
 diffRelTime :: RelativeTime -> RelativeTime -> NominalDiffTime
-diffRelTime (RelativeTime t) (RelativeTime t') = t - t'
-
-toRelativeTime :: SystemStart -> UTCTime -> RelativeTime
-toRelativeTime (SystemStart t) t' = assert (t' >= t) $
-                                      RelativeTime (diffUTCTime t' t)
-
-fromRelativeTime :: SystemStart -> RelativeTime -> UTCTime
-fromRelativeTime (SystemStart t) (RelativeTime t') = addUTCTime t' t
+diffRelTime = diffRelativeTime
 
 {-------------------------------------------------------------------------------
   Get current time (as RelativeTime)
@@ -92,61 +58,3 @@ data SystemTime m = SystemTime {
     , systemTimeWait    :: m ()
     }
   deriving NoThunks via OnlyCheckWhnfNamed "SystemTime" (SystemTime m)
-
-{-------------------------------------------------------------------------------
-  SlotLength
--------------------------------------------------------------------------------}
-
--- | Slot length
-newtype SlotLength = SlotLength { getSlotLength :: NominalDiffTime }
-  deriving (Eq, Generic, NoThunks)
-  deriving Show via Quiet SlotLength
-
--- | Constructor for 'SlotLength'
-mkSlotLength :: NominalDiffTime -> SlotLength
-mkSlotLength = SlotLength
-
-slotLengthFromSec :: Integer -> SlotLength
-slotLengthFromSec = slotLengthFromMillisec . (* 1000)
-
-slotLengthToSec :: SlotLength -> Integer
-slotLengthToSec = (`div` 1000) . slotLengthToMillisec
-
-slotLengthFromMillisec :: Integer -> SlotLength
-slotLengthFromMillisec = mkSlotLength . conv
-  where
-    -- Explicit type annotation here means that /if/ we change the precision,
-    -- we are forced to reconsider this code.
-    conv :: Integer -> NominalDiffTime
-    conv = (realToFrac :: Pico -> NominalDiffTime)
-         . (/ 1000)
-         . (fromInteger :: Integer -> Pico)
-
-slotLengthToMillisec :: SlotLength -> Integer
-slotLengthToMillisec = conv . getSlotLength
-  where
-    -- Explicit type annotation here means that /if/ we change the precision,
-    -- we are forced to reconsider this code.
-    conv :: NominalDiffTime -> Integer
-    conv = truncate
-         . (* 1000)
-         . (realToFrac :: NominalDiffTime -> Pico)
-
-{-------------------------------------------------------------------------------
-  Serialisation
--------------------------------------------------------------------------------}
-
-instance Serialise RelativeTime where
-  encode = encode . toPico . getRelativeTime
-    where
-      toPico :: NominalDiffTime -> Pico
-      toPico = realToFrac
-
-  decode = (RelativeTime . fromPico) <$> decode
-    where
-      fromPico :: Pico -> NominalDiffTime
-      fromPico = realToFrac
-
-instance Serialise SlotLength where
-  encode = encode . slotLengthToMillisec
-  decode = slotLengthFromMillisec <$> decode