Bump deps to get slot-to-time conversion in EpochInfo

Most of the content that this commit removes from `Ouroboros.Consensus.BlockchainTime.WallClock.Types` was recently upstreamed in PR IntersectMBO/cardano-base#212. This PR updates `ouroboros-network` in turn. Combined with PR IntersectMBO/cardano-ledger#2223, this commit will discharge CAD-2713 via the new `EpochInfo` field `epochInfoSlotToRelativeTime_` et al.
IntersectMBO · Apr 26, 2021 · 410c8b6 · 410c8b6
1 parent e39bfc4
commit 410c8b6
Show file tree

Hide file tree

Showing 9 changed files with 60 additions and 130 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,16 +174,18 @@ 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:
+    alonzo/impl
     byron/chain/executable-spec
-    byron/crypto
-    byron/crypto/test
     byron/ledger/executable-spec
     byron/ledger/impl
     byron/ledger/impl/test
+    byron/crypto
+    byron/crypto/test
     cardano-ledger-core
+    cardano-ledger-test
     semantics/executable-spec
     semantics/small-steps-test
     shelley/chain-and-ledger/dependencies/non-integer
@@ -204,10 +206,17 @@ source-repository-package
   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
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/plutus
+  tag: 1578ab92f9ac389c68aa915370bf38ad7b4a75e9
+  --sha256: 1fnpv2l7zs1in1hgdpb85zv8l37kjcclz0zjzqmll391gbdsb99f
+  subdir:
+    plutus-ledger-api
+    plutus-tx
+    plutus-core
+    prettyprinter-configurable
+
+allow-newer:
+  monoidal-containers:aeson,
+  size-based:template-haskell
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/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-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
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs
@@ -41,4 +41,10 @@ class SingleEraBlock blk => NoHardForks blk where
 
 noHardForksEpochInfo :: NoHardForks blk
                      => TopLevelConfig blk -> EpochInfo Identity
-noHardForksEpochInfo = fixedSizeEpochInfo . History.eraEpochSize . getEraParams
+noHardForksEpochInfo cfg =
+    fixedEpochInfo
+      (History.eraEpochSize  params)
+      (History.eraSlotLength params)
+  where
+    params :: EraParams
+    params = getEraParams cfg
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/EpochInfo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/EpochInfo.hs
@@ -39,6 +39,9 @@ summaryToEpochInfo =
           epochInfoSize_  = \e -> cachedRunQueryThrow run (epochToSize  e)
         , epochInfoFirst_ = \e -> cachedRunQueryThrow run (epochToSlot' e)
         , epochInfoEpoch_ = \s -> cachedRunQueryThrow run (fst <$> slotToEpoch' s)
+
+        , epochInfoSlotToRelativeTime_ = \s ->
+            cachedRunQueryThrow run (fst <$> slotToWallclock s)
         }
 
 -- | Construct an 'EpochInfo' for a /snapshot/ of the ledger state
@@ -50,6 +53,9 @@ snapshotEpochInfo summary = EpochInfo {
       epochInfoSize_  = \e -> runQueryPure' (epochToSize  e)
     , epochInfoFirst_ = \e -> runQueryPure' (epochToSlot' e)
     , epochInfoEpoch_ = \s -> runQueryPure' (fst <$> slotToEpoch' s)
+
+    , epochInfoSlotToRelativeTime_ = \s ->
+        runQueryPure' (fst <$> slotToWallclock s)
     }
   where
     runQueryPure' :: HasCallStack => Qry a -> Identity a
@@ -60,7 +66,8 @@ snapshotEpochInfo summary = EpochInfo {
 -- To be used as a placeholder before a summary is available.
 dummyEpochInfo :: EpochInfo Identity
 dummyEpochInfo = EpochInfo {
-      epochInfoSize_  = \_ -> error "dummyEpochInfo used"
-    , epochInfoFirst_ = \_ -> error "dummyEpochInfo used"
-    , epochInfoEpoch_ = \_ -> error "dummyEpochInfo used"
+      epochInfoSize_               = \_ -> error "dummyEpochInfo used"
+    , epochInfoFirst_              = \_ -> error "dummyEpochInfo used"
+    , epochInfoEpoch_              = \_ -> error "dummyEpochInfo used"
+    , epochInfoSlotToRelativeTime_ = \_ -> error "dummyEpochInfo used"
     }