Get epoch and slot lengths from HFC History Interpreter

Divide up network parameters further.

Remove slot length and epoch length from genesis parameters, because
we will be getting them with HFC queries.

Update all slotting parameter usages

lib/core/src/Cardano/Wallet.hs

@@ -587,7 +587,7 @@ createWallet ctx wid wname s = db & \DBLayer{..} -> do
         initializeWallet (PrimaryKey wid) cp meta hist pp $> wid
   where
     db = ctx ^. dbLayer @s @k
-    (block0, NetworkParameters gp pp, _) = ctx ^. genesisData
+    (block0, NetworkParameters gp _sp pp, _) = ctx ^. genesisData
 
 -- | Initialise and store a new legacy Icarus wallet. These wallets are
 -- intrinsically sequential, but, in the incentivized testnet, we only have
@@ -632,7 +632,7 @@ createIcarusWallet ctx wid wname credentials = db & \DBLayer{..} -> do
         initializeWallet pk (updateState s' cp) meta hist pp $> wid
   where
     db = ctx ^. dbLayer @s @k
-    (block0, NetworkParameters gp pp, _) = ctx ^. genesisData
+    (block0, NetworkParameters gp _sp pp, _) = ctx ^. genesisData
 
 -- | Check whether a wallet is in good shape when restarting a worker.
 checkWalletIntegrity

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -1776,8 +1776,11 @@ getNetworkParameters
     -> Handler ApiNetworkParameters
 getNetworkParameters (_block0, np, _st) nl = do
     pp <- liftIO $ NW.getProtocolParameters nl
-    let (apiNetworkParams, epochNoM) =
-            toApiNetworkParameters np { protocolParameters = pp }
+    let pastHorizon :: PastHorizonException -> IO W.SlottingParameters
+        pastHorizon _ = pure (slottingParameters np)
+    sp <- liftIO $ handle pastHorizon $ NW.getSlottingParametersForTip nl
+    let (apiNetworkParams, epochNoM) = toApiNetworkParameters np
+            { protocolParameters = pp, slottingParameters = sp }
     case epochNoM of
         Just epochNo -> do
             epochStartTime <-
@@ -2075,7 +2078,7 @@ registerWorker
 registerWorker ctx coworker wid =
     void $ Registry.register @_ @ctx re ctx wid config
   where
-    (_, NetworkParameters gp _, _) = ctx ^. genesisData
+    (_, NetworkParameters gp _ _, _) = ctx ^. genesisData
     re = ctx ^. workerRegistry
     df = ctx ^. dbFactory
     config = MkWorker

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -187,6 +187,7 @@ import Cardano.Wallet.Primitive.Types
     , SlotInEpoch (..)
     , SlotLength (..)
     , SlotNo (..)
+    , SlottingParameters (..)
     , StakePoolMetadata
     , StartTime (..)
     , TxIn (..)
@@ -594,18 +595,18 @@ data ApiNetworkParameters = ApiNetworkParameters
 toApiNetworkParameters
     :: NetworkParameters
     -> (ApiNetworkParameters, Maybe EpochNo)
-toApiNetworkParameters (NetworkParameters gp pp) = (np, view #hardforkEpochNo pp)
+toApiNetworkParameters (NetworkParameters gp sp pp) = (np, view #hardforkEpochNo pp)
   where
     np = ApiNetworkParameters
         { genesisBlockHash = ApiT $ getGenesisBlockHash gp
         , blockchainStartTime = ApiT $ getGenesisBlockDate gp
-        , slotLength = Quantity $ unSlotLength $ getSlotLength gp
-        , epochLength = Quantity $ unEpochLength $ getEpochLength gp
+        , slotLength = Quantity $ unSlotLength $ getSlotLength sp
+        , epochLength = Quantity $ unEpochLength $ getEpochLength sp
         , epochStability = getEpochStability gp
         , activeSlotCoefficient = Quantity
             $ (*100)
             $ unActiveSlotCoefficient
-            $ getActiveSlotCoefficient gp
+            $ getActiveSlotCoefficient sp
         , decentralizationLevel = Quantity
             $ unDecentralizationLevel
             $ view #decentralizationLevel pp

lib/core/src/Cardano/Wallet/DB/Sqlite.hs

@@ -156,7 +156,7 @@ import Data.Text.Class
 import Data.Typeable
     ( Typeable )
 import Data.Word
-    ( Word16, Word32, Word64 )
+    ( Word16, Word32 )
 import Database.Persist.Class
     ( toPersistValue )
 import Database.Persist.Sql
@@ -1079,11 +1079,10 @@ mkCheckpointEntity wid wal =
         , checkpointBlockHeight = bh
         , checkpointGenesisHash = BlockId (coerce (gp ^. #getGenesisBlockHash))
         , checkpointGenesisStart = coerce (gp ^. #getGenesisBlockDate)
-        , checkpointSlotLength = coerceSlotLength $ gp ^. #getSlotLength
-        , checkpointEpochLength = coerce (gp ^. #getEpochLength)
+        , checkpointSlotLength = 0
+        , checkpointEpochLength = 0
         , checkpointEpochStability = coerce (gp ^. #getEpochStability)
-        , checkpointActiveSlotCoeff =
-            W.unActiveSlotCoefficient (gp ^. #getActiveSlotCoefficient)
+        , checkpointActiveSlotCoeff = 0
         , checkpointFeePolicyUnused = ""
         , checkpointTxMaxSizeUnused = 0
         }
@@ -1093,9 +1092,6 @@ mkCheckpointEntity wid wal =
         ]
     utxoMap = Map.assocs (W.getUTxO (W.utxo wal))
 
-    coerceSlotLength :: W.SlotLength -> Word64
-    coerceSlotLength (W.SlotLength x) = toEnum (fromEnum x)
-
 -- note: TxIn records must already be sorted by order
 -- and TxOut records must already by sorted by index.
 checkpointFromEntity
@@ -1115,11 +1111,11 @@ checkpointFromEntity cp utxo s =
         (BlockId genesisHash)
         genesisStart
         _feePolicyUnused
-        slotLength
-        epochLength
+        _slotLengthUnused
+        _epochLengthUnused
         _txMaxSizeUnused
         epochStability
-        activeSlotCoeff
+        _activeSlotCoeffUnused
         ) = cp
     header = (W.BlockHeader slot (Quantity bh) headerHash parentHeaderHash)
     utxo' = W.UTxO . Map.fromList $
@@ -1129,10 +1125,7 @@ checkpointFromEntity cp utxo s =
     gp = W.GenesisParameters
         { getGenesisBlockHash = coerce genesisHash
         , getGenesisBlockDate = W.StartTime genesisStart
-        , getSlotLength = W.SlotLength (toEnum (fromEnum slotLength))
-        , getEpochLength = W.EpochLength epochLength
         , getEpochStability = Quantity epochStability
-        , getActiveSlotCoefficient = W.ActiveSlotCoefficient activeSlotCoeff
         }
 
 mkTxHistory

lib/core/src/Cardano/Wallet/Network.hs

@@ -20,6 +20,7 @@ module Cardano.Wallet.Network
     , FollowAction (..)
     , FollowExit (..)
     , GetStakeDistribution
+    , getSlottingParametersForTip
 
     -- * Errors
     , ErrNetworkUnavailable (..)
@@ -44,14 +45,16 @@ import Cardano.BM.Data.Severity
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Wallet.Primitive.Slotting
-    ( TimeInterpreter )
+    ( TimeInterpreter, queryEpochLength, querySlotLength )
 import Cardano.Wallet.Primitive.Types
-    ( BlockHeader (..)
+    ( ActiveSlotCoefficient (..)
+    , BlockHeader (..)
     , ChimericAccount (..)
     , Hash (..)
     , ProtocolParameters
     , SealedTx
-    , SlotNo
+    , SlotNo (..)
+    , SlottingParameters (..)
     )
 import Control.Concurrent
     ( threadDelay )
@@ -248,6 +251,26 @@ defaultRetryPolicy =
 
 type family GetStakeDistribution target (m :: * -> *) :: *
 
+-- | Use the HFC history interpreter to get the slot and epoch lengths current
+-- for the network tip.
+--
+-- This may throw a 'PastHorizonException' in some cases.
+getSlottingParametersForTip
+    :: Monad m
+    => NetworkLayer m target block
+    -> m SlottingParameters
+getSlottingParametersForTip nl = do
+    tip <- either (const 0) slotNo <$> runExceptT (currentNodeTip nl)
+
+    -- TODO: Query activeSlotCoeff. Where to get it from though? Need to be able
+    -- to query Globals from ledger.
+    let getActiveSlotCoeff = pure (ActiveSlotCoefficient 1.0)
+
+    SlottingParameters
+        <$> timeInterpreter nl (querySlotLength tip)
+        <*> timeInterpreter nl (queryEpochLength tip)
+        <*> getActiveSlotCoeff
+
 {-------------------------------------------------------------------------------
                                 Chain Sync
 -------------------------------------------------------------------------------}

lib/core/src/Cardano/Wallet/Primitive/Slotting.hs

@@ -27,6 +27,8 @@ module Cardano.Wallet.Primitive.Slotting
     , firstSlotInEpoch
     , ongoingSlotAt
     , endTimeOfEpoch
+    , querySlotLength
+    , queryEpochLength
 
     -- ** Running queries
     , TimeInterpreter
@@ -65,12 +67,12 @@ import Cardano.Wallet.Primitive.Types
     ( ActiveSlotCoefficient (..)
     , EpochLength (..)
     , EpochNo (..)
-    , GenesisParameters (..)
     , Range (..)
     , SlotId (..)
     , SlotInEpoch (..)
     , SlotLength (..)
     , SlotNo (..)
+    , SlottingParameters (..)
     , StartTime (..)
     , unsafeEpochNo
     , wholeRange
@@ -245,6 +247,22 @@ slotAtTimeDetailed t = do
         Just relTime -> fmap Just $ HardForkQry $ HF.wallclockToSlot relTime
         Nothing -> return Nothing
 
+querySlotLength :: SlotNo -> Qry SlotLength
+querySlotLength sl =
+    fmap (SlotLength . Cardano.getSlotLength) $
+    HardForkQry $
+    HF.qryFromExpr $
+    HF.ESlotLength $
+    HF.ELit sl
+
+queryEpochLength :: SlotNo -> Qry EpochLength
+queryEpochLength sl = fmap toEpochLength $ HardForkQry $ do
+    (e, _, _) <- HF.slotToEpoch sl
+    HF.epochToSize e
+  where
+    -- converting up from Word32 to Word64
+    toEpochLength = EpochLength . fromIntegral . Cardano.unEpochSize
+
 -- A @TimeInterpreter@ is a way for the wallet to run things of type @Qry a@.
 --
 -- NOTE:
@@ -264,21 +282,22 @@ type TimeInterpreter m = forall a. Qry a -> m a
 -- a 'PastHorizonException' if they do.
 singleEraInterpreter
     :: HasCallStack
-    => GenesisParameters
+    => StartTime
+    -> SlottingParameters
     -> TimeInterpreter Identity
-singleEraInterpreter gp = mkTimeInterpreterI (mkInterpreter summary)
+singleEraInterpreter genesisBlockTime sp = mkTimeInterpreterI (mkInterpreter summary)
   where
     summary = neverForksSummary sz len
-    sz = Cardano.EpochSize $ fromIntegral $ unEpochLength $ gp ^. #getEpochLength
-    len = Cardano.mkSlotLength $ unSlotLength $ gp ^. #getSlotLength
+    sz = Cardano.EpochSize $ fromIntegral $ unEpochLength $ sp ^. #getEpochLength
+    len = Cardano.mkSlotLength $ unSlotLength $ sp ^. #getSlotLength
 
     mkTimeInterpreterI
         :: HasCallStack
         => Interpreter xs
         -> TimeInterpreter Identity
     mkTimeInterpreterI int q = neverFails $ runQuery start int q
       where
-        start = coerce (gp ^. #getGenesisBlockDate)
+        start = coerce genesisBlockTime
 
         neverFails = either bomb pure
         bomb x = error $ "singleEraInterpreter: the impossible happened: " <> show x
@@ -348,12 +367,12 @@ data SlotParameters = SlotParameters
         :: ActiveSlotCoefficient
     } deriving (Eq, Generic, Show)
 
-slotParams :: GenesisParameters -> SlotParameters
-slotParams gp = SlotParameters
-    (gp ^. #getEpochLength)
-    (gp ^. #getSlotLength)
-    (gp ^. #getGenesisBlockDate)
-    (gp ^. #getActiveSlotCoefficient)
+slotParams :: StartTime -> SlottingParameters -> SlotParameters
+slotParams t0 sp = SlotParameters
+    (sp ^. #getEpochLength)
+    (sp ^. #getSlotLength)
+    t0
+    (sp ^. #getActiveSlotCoefficient)
 
 -- | Calculate the time at which an epoch begins.
 epochStartTime :: SlotParameters -> EpochNo -> UTCTime

lib/core/src/Cardano/Wallet/Primitive/Types.hs

@@ -102,6 +102,7 @@ module Cardano.Wallet.Primitive.Types
     -- * Network Parameters
     , NetworkParameters (..)
     , GenesisParameters (..)
+    , SlottingParameters (..)
     , ProtocolParameters (..)
     , TxParameters (..)
     , ActiveSlotCoefficient (..)
@@ -1431,14 +1432,16 @@ computeStatistics getCoins btype utxos =
 data NetworkParameters = NetworkParameters
     { genesisParameters :: GenesisParameters
        -- ^ See 'GenesisParameters'.
+    , slottingParameters :: SlottingParameters
+       -- ^ See 'SlottingParameters'.
     , protocolParameters :: ProtocolParameters
        -- ^ See 'ProtocolParameters'.
     } deriving (Generic, Show, Eq)
 
 instance NFData NetworkParameters
 
 instance Buildable NetworkParameters where
-    build (NetworkParameters gp pp) = build gp <> build pp
+    build (NetworkParameters gp sp pp) = build gp <> build sp <> build pp
 
 -- | Parameters defined by the __genesis block__.
 --
@@ -1451,15 +1454,8 @@ data GenesisParameters = GenesisParameters
         -- ^ Hash of the very first block
     , getGenesisBlockDate :: StartTime
         -- ^ Start time of the chain.
-    , getSlotLength :: SlotLength
-        -- ^ Length, in seconds, of a slot.
-    , getEpochLength :: EpochLength
-        -- ^ Number of slots in a single epoch.
     , getEpochStability :: Quantity "block" Word32
         -- ^ Length of the suffix of the chain considered unstable
-    , getActiveSlotCoefficient :: ActiveSlotCoefficient
-        -- ^ In Genesis/Praos, corresponds to the % of active slots
-        -- (i.e. slots for which someone can be elected as leader).
     } deriving (Generic, Show, Eq)
 
 instance NFData GenesisParameters
@@ -1469,19 +1465,36 @@ instance Buildable GenesisParameters where
         [ "Genesis block hash: " <> genesisF (getGenesisBlockHash gp)
         , "Genesis block date: " <> startTimeF (getGenesisBlockDate
             (gp :: GenesisParameters))
-        , "Slot length:        " <> slotLengthF (getSlotLength
-            (gp :: GenesisParameters))
-        , "Epoch length:       " <> epochLengthF (getEpochLength
-            (gp :: GenesisParameters))
         , "Epoch stability:    " <> epochStabilityF (getEpochStability gp)
-        , "Active slot coeff:  " <> build (gp ^. #getActiveSlotCoefficient)
         ]
       where
         genesisF = build . T.decodeUtf8 . convertToBase Base16 . getHash
         startTimeF (StartTime s) = build s
+        epochStabilityF (Quantity s) = build s
+
+data SlottingParameters = SlottingParameters
+    { getSlotLength :: SlotLength
+        -- ^ Length, in seconds, of a slot.
+    , getEpochLength :: EpochLength
+        -- ^ Number of slots in a single epoch.
+    , getActiveSlotCoefficient :: ActiveSlotCoefficient
+        -- ^ In Genesis/Praos, corresponds to the % of active slots
+        -- (i.e. slots for which someone can be elected as leader).
+    } deriving (Generic, Show, Eq)
+
+instance NFData SlottingParameters
+
+instance Buildable SlottingParameters where
+    build gp = blockListF' "" id
+        [ "Slot length:        " <> slotLengthF (getSlotLength
+            (gp :: SlottingParameters))
+        , "Epoch length:       " <> epochLengthF (getEpochLength
+            (gp :: SlottingParameters))
+        , "Active slot coeff:  " <> build (gp ^. #getActiveSlotCoefficient)
+        ]
+      where
         slotLengthF (SlotLength s) = build s
         epochLengthF (EpochLength s) = build s
-        epochStabilityF (Quantity s) = build s
 
 newtype ActiveSlotCoefficient
     = ActiveSlotCoefficient { unActiveSlotCoefficient :: Double }

lib/core/test/bench/db/Main.hs

@@ -107,11 +107,11 @@ import Cardano.Wallet.Primitive.Types
     , Coin (..)
     , Direction (..)
     , EpochLength (..)
-    , GenesisParameters (..)
     , Hash (..)
     , Range (..)
     , SlotLength (..)
     , SlotNo (..)
+    , SlottingParameters (..)
     , SortOrder (..)
     , StartTime (..)
     , TransactionInfo
@@ -598,12 +598,11 @@ setupDB tr = do
     (ctx, db) <- newDBLayer tr defaultFieldValues (Just f) ti
     pure (f, ctx, db)
   where
-    ti = pure . runIdentity . singleEraInterpreter (GenesisParameters
-        { getGenesisBlockHash = Hash $ BS.replicate 32 0
-        , getGenesisBlockDate = StartTime $ posixSecondsToUTCTime 0
-        , getSlotLength = SlotLength 1
+    ti = pure . runIdentity . singleEraInterpreter
+        (StartTime $ posixSecondsToUTCTime 0)
+        (SlottingParameters
+        { getSlotLength = SlotLength 1
         , getEpochLength = EpochLength 21600
-        , getEpochStability = Quantity 108
         , getActiveSlotCoefficient = ActiveSlotCoefficient 1
         })