Review Slotting As Primitive

cardano-wallet.cabal

@@ -71,7 +71,6 @@ library
       Cardano.Wallet.BlockSyncer
       Cardano.Wallet.Mnemonic
       Cardano.Wallet.Primitive
-      Cardano.Wallet.Slotting
       Servant.Extra.ContentTypes
   other-modules:
       Paths_cardano_wallet
@@ -161,5 +160,4 @@ test-suite unit
       Cardano.Wallet.BlockSyncerSpec
       Cardano.Wallet.MnemonicSpec
       Cardano.Wallet.PrimitiveSpec
-      Cardano.Wallet.SlottingSpec
       Cardano.WalletSpec

src/Cardano/ChainProducer.hs

@@ -10,9 +10,7 @@ module Cardano.ChainProducer
 import Prelude
 
 import Cardano.Wallet.Primitive
-    ( Block )
-import Cardano.Wallet.Slotting
-    ( SlotId )
+    ( Block, SlotId )
 import Control.Exception
     ( Exception )
 import Control.Monad.Except

src/Cardano/ChainProducer/RustHttpBridge.hs

@@ -22,13 +22,11 @@ import Cardano.ChainProducer
 import Cardano.ChainProducer.RustHttpBridge.NetworkLayer
     ( NetworkLayer (..), NetworkLayerError )
 import Cardano.Wallet.Primitive
-    ( Block (..), BlockHeader (..), Hash (..) )
-import Cardano.Wallet.Slotting
-    ( EpochIndex
-    , LocalSlotIndex (..)
+    ( Block (..)
+    , BlockHeader (..)
+    , Hash (..)
     , SlotId (..)
-    , addSlots
-    , slotNext
+    , slotIncr
     , slotsPerEpoch
     )
 import Control.Monad.Except
@@ -41,6 +39,8 @@ import Data.Bifunctor
     ( first )
 import Data.Maybe
     ( fromMaybe )
+import Data.Word
+    ( Word64 )
 import Numeric.Natural
     ( Natural )
 
@@ -74,12 +74,12 @@ rbNextBlocks
     -> ExceptT ErrGetNextBlocks RustBackend [Block]
 rbNextBlocks numBlocks start = do
     net <- lift getNetwork
-    (tipHash, tip) <- fmap headerSlot <$> runNetworkLayer (getNetworkTip net)
+    (tipHash, tip) <- fmap slotId <$> runNetworkLayer (getNetworkTip net)
     epochBlocks <- blocksFromPacks net tip
     lastBlocks <- unstableBlocks net tipHash tip epochBlocks
     pure (epochBlocks ++ lastBlocks)
   where
-    end = addSlots numBlocks start
+    end = slotIncr numBlocks start
 
     -- Grab blocks from epoch pack files
     blocksFromPacks network tip = do
@@ -89,7 +89,7 @@ rbNextBlocks numBlocks start = do
 
     -- The next slot after the last block.
     slotAfter [] = Nothing
-    slotAfter bs = Just . slotNext . headerSlot . header . last $ bs
+    slotAfter bs = Just . succ . slotId . header . last $ bs
 
     -- Grab the remaining blocks which aren't packed in epoch files,
     -- starting from the tip.
@@ -106,7 +106,7 @@ rbNextBlocks numBlocks start = do
 getEpochs
     :: Monad m
     => NetworkLayer m
-    -> [EpochIndex]
+    -> [Word64]
     -> ExceptT NetworkLayerError m [[Block]]
 getEpochs network = mapUntilError (getEpoch network)
 
@@ -158,11 +158,6 @@ mapUntilError _ [] = pure []
 
 -- * Slotting calculation utilities
 
--- | Gets the slot from a block header.
-headerSlot :: BlockHeader -> SlotId
-headerSlot bh = SlotId
-    (epochIndex (bh :: BlockHeader)) (slotNumber (bh :: BlockHeader))
-
 -- | Calculates which epochs to fetch, given a number of slots, and the start
 -- point. It takes into account the latest block available, and that the most
 -- recent epoch is never available in a pack file.
@@ -173,25 +168,25 @@ epochRange
         -- ^ Start point
     -> SlotId
         -- ^ Latest block available
-    -> [EpochIndex]
+    -> [Word64]
 epochRange
     numBlocks
-    (SlotId startEpoch (LocalSlotIndex startSlot)) (SlotId tipEpoch _)
+    (SlotId startEpoch startSlot) (SlotId tipEpoch _)
     = [startEpoch .. min (tipEpoch - 1) (startEpoch + fromIntegral numEpochs)]
     where
         numEpochs = (numBlocks + fromIntegral startSlot) `div` slotsPerEpoch
 
 -- | Predicate returns true iff the block is from the given slot or a later one.
 blockIsSameOrAfter :: SlotId -> Block -> Bool
-blockIsSameOrAfter s = (>= s) . headerSlot . header
+blockIsSameOrAfter s = (>= s) . slotId . header
 
 -- | Predicate returns true iff the block is after then given slot
 blockIsAfter :: SlotId -> Block -> Bool
-blockIsAfter s = (> s) . headerSlot . header
+blockIsAfter s = (> s) . slotId . header
 
 -- | Predicate returns true iff the block is before the given slot.
 blockIsBefore :: SlotId -> Block -> Bool
-blockIsBefore s = (< s) . headerSlot . header
+blockIsBefore s = (< s) . slotId . header
 
 -- | @blockIsBetween start end@ Returns true if the block is in within the
 -- interval @[start, end)@.

src/Cardano/ChainProducer/RustHttpBridge/Api.hs

@@ -23,14 +23,15 @@ import Data.Proxy
     ( Proxy (..) )
 import Data.Text
     ( Text )
+import Data.Word
+    ( Word64 )
 import Prelude
 import Servant.API
     ( (:<|>), (:>), Capture, Get, ToHttpApiData (..) )
 import Servant.Extra.ContentTypes
     ( CBOR, ComputeHash, FromCBOR (..), Hash, Packed, WithHash )
 
 import qualified Cardano.Wallet.Primitive as Primitive
-import qualified Cardano.Wallet.Slotting as Slotting
 
 api :: Proxy Api
 api = Proxy
@@ -78,11 +79,11 @@ instance FromCBOR BlockHeader where
 
 -- | Represents a unique epoch.
 newtype EpochIndex = EpochIndex
-    { getEpochIndex :: Slotting.EpochIndex
+    { getEpochIndex :: Word64
     } deriving (Eq, Show)
 
 instance ToHttpApiData (EpochIndex) where
-    toUrlPiece = toUrlPiece . Slotting.getEpochIndex . getEpochIndex
+    toUrlPiece = toUrlPiece . getEpochIndex
 
 -- | Represents the name of a Cardano network.
 newtype NetworkName = NetworkName

src/Cardano/ChainProducer/RustHttpBridge/NetworkLayer.hs

@@ -15,19 +15,19 @@ import Prelude
 
 import Cardano.Wallet.Primitive
     ( Block (..), BlockHeader (..), Hash (..) )
-import Cardano.Wallet.Slotting
-    ( EpochIndex )
 import Control.Exception
     ( Exception (..) )
 import Control.Monad.Except
     ( ExceptT )
+import Data.Word
+    ( Word64 )
 
 -- | Endpoints of the cardano-http-bridge API.
 data NetworkLayer m = NetworkLayer
     { getBlock
         :: Hash "BlockHeader" -> ExceptT NetworkLayerError m Block
     , getEpoch
-        :: EpochIndex -> ExceptT NetworkLayerError m [Block]
+        :: Word64 -> ExceptT NetworkLayerError m [Block]
     , getNetworkTip
         :: ExceptT NetworkLayerError m (Hash "BlockHeader", BlockHeader)
     }

src/Cardano/Wallet/Binary.hs

@@ -46,12 +46,11 @@ import Cardano.Wallet.Primitive
     , BlockHeader (..)
     , Coin (..)
     , Hash (..)
+    , SlotId (..)
     , Tx (..)
     , TxIn (..)
     , TxOut (..)
     )
-import Cardano.Wallet.Slotting
-    ( EpochIndex (..), LocalSlotIndex (..) )
 import Control.Monad
     ( void )
 import Crypto.Hash
@@ -201,7 +200,7 @@ decodeGenesisBlockHeader = do
     -- number of `0`. In practices, when parsing a full epoch, we can discard
     -- the genesis block entirely and we won't bother about modelling this
     -- extra complexity at the type-level. That's a bit dodgy though.
-    return $ BlockHeader (EpochIndex epoch) (LocalSlotIndex 0) previous
+    return $ BlockHeader (SlotId epoch 0) previous
 
 decodeGenesisConsensusData :: CBOR.Decoder s Word64
 decodeGenesisConsensusData = do
@@ -256,8 +255,7 @@ decodeMainBlockHeader = do
     _ <- decodeMainProof
     (epoch, slot) <- decodeMainConsensusData
     _ <- decodeMainExtraData
-    return $ BlockHeader (EpochIndex epoch)
-        (LocalSlotIndex slot) previous
+    return $ BlockHeader (SlotId epoch slot) previous
 
 decodeMainConsensusData :: CBOR.Decoder s (Word64, Word16)
 decodeMainConsensusData = do

src/Cardano/Wallet/Primitive.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -48,16 +49,21 @@ module Cardano.Wallet.Primitive
     , restrictedTo
     , Dom(..)
 
-    -- * Generic
+    -- * Slotting
+    , SlotId (..)
+    , isValidSlotId
+    , slotsPerEpoch
+    , slotDiff
+    , slotIncr
+
+    -- * Polymorphic
     , Hash (..)
     , ShowFmt (..)
     , invariant
     ) where
 
 import Prelude
 
-import Cardano.Wallet.Slotting
-    ( EpochIndex, LocalSlotIndex )
 import Control.DeepSeq
     ( NFData (..) )
 import Data.ByteArray.Encoding
@@ -71,7 +77,7 @@ import Data.Map.Strict
 import Data.Set
     ( Set )
 import Data.Word
-    ( Word32, Word64 )
+    ( Word16, Word32, Word64 )
 import Fmt
     ( Buildable (..)
     , blockListF
@@ -86,6 +92,8 @@ import GHC.Generics
     ( Generic )
 import GHC.TypeLits
     ( Symbol )
+import Numeric.Natural
+    ( Natural )
 
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -103,10 +111,8 @@ data Block = Block
 instance NFData Block
 
 data BlockHeader = BlockHeader
-    { epochIndex
-        :: !EpochIndex
-    , slotNumber
-        :: !LocalSlotIndex
+    { slotId
+        :: SlotId
     , prevBlockHash
         :: !(Hash "BlockHeader")
     } deriving (Show, Eq, Ord, Generic)
@@ -283,6 +289,51 @@ restrictedTo (UTxO utxo) outs =
     UTxO $ Map.filter (`Set.member` outs) utxo
 
 
+-- * Slotting
+
+-- | Hard-coded for the time being
+slotsPerEpoch :: Natural
+slotsPerEpoch = 21600
+
+-- | A slot identifier is the combination of an epoch and slot.
+data SlotId = SlotId
+  { epochIndex :: !Word64
+  , slotNumber :: !Word16
+  } deriving stock (Show, Eq, Ord, Generic)
+
+instance NFData SlotId
+
+instance Enum SlotId where
+    toEnum i
+        | i < 0 = error "SlotId.toEnum: bad argument"
+        | otherwise = slotIncr (fromIntegral i) (SlotId 0 0)
+    fromEnum (SlotId e s)
+        | n > fromIntegral (maxBound @Int) =
+            error "SlotId.fromEnum: arithmetic overflow"
+        | otherwise = fromIntegral n
+      where
+        n :: Natural
+        n = fromIntegral e * fromIntegral slotsPerEpoch + fromIntegral s
+
+-- | Add a number of slots to an (Epoch, LocalSlotIndex) pair, where the number
+-- of slots can be greater than one epoch.
+slotIncr :: Natural -> SlotId -> SlotId
+slotIncr n slot = SlotId e s
+  where
+    e = fromIntegral (fromIntegral n' `div` slotsPerEpoch)
+    s = fromIntegral (fromIntegral n' `mod` slotsPerEpoch)
+    n' = n + fromIntegral (fromEnum slot)
+
+-- | @slotDiff a b@ is the number of slots by which @a@ is greater than @b@.
+slotDiff :: SlotId -> SlotId -> Integer
+slotDiff s1 s2 = fromIntegral (fromEnum s1 - fromEnum s2)
+
+-- | Whether the epoch index and slot number are in range.
+isValidSlotId :: SlotId -> Bool
+isValidSlotId (SlotId e s) =
+    e >= 0 && s >= 0 && s < fromIntegral slotsPerEpoch
+
+
 -- * Polymorphic
 
 class Dom a where