From 06282fc42023c70b71ccfcf536cc603a967c500f Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Thu, 7 Mar 2019 14:48:30 +1000 Subject: [PATCH] Add nextBlocks function This is a member of the MonadChainProducer class. The interface will need tweaking to work efficiently. There is also a NetworkLayer type (copied from prototype) which the RustCardano backend uses. Some slotting functions needed to be added to deal with fetching the correct range of blocks. --- cardano-wallet.cabal | 19 +- src/Cardano/ChainProducer.hs | 32 +++ src/Cardano/ChainProducer/RustHttpBridge.hs | 184 ++++++++++++++++++ .../ChainProducer/RustHttpBridge/Api.hs | 14 +- .../ChainProducer/RustHttpBridge/Client.hs | 69 ++++++- .../RustHttpBridge/NetworkLayer.hs | 30 +++ src/Cardano/Wallet/Binary.hs | 9 +- src/Cardano/Wallet/Primitive.hs | 26 +-- src/Cardano/Wallet/Slotting.hs | 89 +++++++++ src/Servant/Extra/ContentTypes.hs | 10 +- .../RustHttpBridge/MockNetworkLayer.hs | 74 +++++++ .../ChainProducer/RustHttpBridgeSpec.hs | 74 +++++++ test/unit/Cardano/Wallet/BlockSyncerSpec.hs | 6 +- test/unit/Cardano/Wallet/PrimitiveSpec.hs | 10 +- test/unit/Cardano/Wallet/SlottingOrphans.hs | 21 ++ test/unit/Cardano/Wallet/SlottingSpec.hs | 67 +++++++ 16 files changed, 677 insertions(+), 57 deletions(-) create mode 100644 src/Cardano/ChainProducer.hs create mode 100644 src/Cardano/ChainProducer/RustHttpBridge.hs create mode 100644 src/Cardano/ChainProducer/RustHttpBridge/NetworkLayer.hs create mode 100644 src/Cardano/Wallet/Slotting.hs create mode 100644 test/unit/Cardano/ChainProducer/RustHttpBridge/MockNetworkLayer.hs create mode 100644 test/unit/Cardano/ChainProducer/RustHttpBridgeSpec.hs create mode 100644 test/unit/Cardano/Wallet/SlottingOrphans.hs create mode 100644 test/unit/Cardano/Wallet/SlottingSpec.hs diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 20b7ee5fa7f..e178e32b3c1 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -39,9 +39,12 @@ library , cryptonite , deepseq , digest + , exceptions , http-api-data + , http-client , http-media , memory + , mtl , servant , servant-client , text @@ -50,12 +53,16 @@ library hs-source-dirs: src exposed-modules: - Cardano.ChainProducer.RustHttpBridge.Api + Cardano.ChainProducer + , Cardano.ChainProducer.RustHttpBridge + , Cardano.ChainProducer.RustHttpBridge.Api , Cardano.ChainProducer.RustHttpBridge.Client + , Cardano.ChainProducer.RustHttpBridge.NetworkLayer , Cardano.Wallet.Binary , Cardano.Wallet.Binary.Packfile , Cardano.Wallet.BlockSyncer , Cardano.Wallet.Primitive + , Cardano.Wallet.Slotting , Servant.Extra.ContentTypes other-modules: Paths_cardano_wallet @@ -98,9 +105,11 @@ test-suite unit , bytestring , cborg , containers + , exceptions , hspec - , memory , hspec-expectations + , memory + , mtl , QuickCheck , time-units type: @@ -112,5 +121,9 @@ test-suite unit other-modules: Cardano.Wallet.BinarySpec , Cardano.Wallet.Binary.PackfileSpec - , Cardano.Wallet.PrimitiveSpec , Cardano.Wallet.BlockSyncerSpec + , Cardano.Wallet.PrimitiveSpec + , Cardano.Wallet.SlottingOrphans + , Cardano.Wallet.SlottingSpec + , Cardano.ChainProducer.RustHttpBridge.MockNetworkLayer + , Cardano.ChainProducer.RustHttpBridgeSpec diff --git a/src/Cardano/ChainProducer.hs b/src/Cardano/ChainProducer.hs new file mode 100644 index 00000000000..73851ed66c1 --- /dev/null +++ b/src/Cardano/ChainProducer.hs @@ -0,0 +1,32 @@ +module Cardano.ChainProducer + ( MonadChainProducer (..) + , ErrGetNextBlocks (..) + ) where + +import Prelude + +import Cardano.Wallet.Primitive + ( Block ) +import Cardano.Wallet.Slotting + ( SlotCount, SlotId ) +import Control.Exception + ( Exception ) +import Control.Monad.Except + ( ExceptT ) + +class MonadChainProducer m where + -- | Get some blocks from the chain producer. + -- + -- This may retrieve less than the requested number of blocks. + -- It might return no blocks at all. + nextBlocks + :: SlotCount -- ^ Number of blocks to retrieve + -> SlotId -- ^ Starting point + -> ExceptT ErrGetNextBlocks m [Block] + +-- | The things that can go wrong when retrieving blocks. +data ErrGetNextBlocks + = GetNextBlocksError String + deriving (Show, Eq) + +instance Exception ErrGetNextBlocks diff --git a/src/Cardano/ChainProducer/RustHttpBridge.hs b/src/Cardano/ChainProducer/RustHttpBridge.hs new file mode 100644 index 00000000000..28e1430880d --- /dev/null +++ b/src/Cardano/ChainProducer/RustHttpBridge.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.ChainProducer.RustHttpBridge + ( RustBackend + , runRustBackend + ) where + +import Control.Monad.Except + ( ExceptT (..), mapExceptT, runExceptT ) +import Control.Monad.IO.Class + ( MonadIO, liftIO ) +import Control.Monad.Reader + ( MonadReader, ReaderT (..), ask, lift ) +import Data.Bifunctor + ( first ) +import Data.Maybe + ( fromMaybe ) +import Prelude + +import Cardano.ChainProducer +import Cardano.ChainProducer.RustHttpBridge.NetworkLayer + ( NetworkLayer (..), NetworkLayerError ) +import Cardano.Wallet.Primitive + ( Block (..), BlockHeader (..), Hash (..) ) +import Cardano.Wallet.Slotting + ( EpochIndex + , LocalSlotIndex (..) + , SlotCount + , SlotId (..) + , addSlots + , slotNext + , slotsPerEpoch + ) + +newtype RustBackend a = RustBackend { + runRB :: ReaderT (NetworkLayer IO) IO a + } deriving (Monad, Applicative, Functor, MonadReader (NetworkLayer IO), MonadIO) + +runRustBackend :: NetworkLayer IO -> RustBackend a -> IO a +runRustBackend network action = runReaderT (runRB action) network + +getNetwork :: RustBackend (NetworkLayer IO) +getNetwork = ask + +instance MonadChainProducer RustBackend where + nextBlocks = rbNextBlocks + +runNetworkLayer + :: ExceptT NetworkLayerError IO a + -> ExceptT ErrGetNextBlocks RustBackend a +runNetworkLayer = mapExceptT (fmap handle . liftIO) + where + handle = first (GetNextBlocksError . show) + +-- Note: This will be quite inefficient for at least two reasons. +-- 1. If the number of blocks requested is small, it will fetch the same epoch +-- pack file repeatedly. +-- 2. Fetching the tip block and working backwards is not ideal. +-- We will keep it for now, and it can be improved later. +rbNextBlocks + :: SlotCount -- ^ Number of blocks to retrieve + -> SlotId -- ^ Starting point + -> ExceptT ErrGetNextBlocks RustBackend [Block] +rbNextBlocks numBlocks start = do + network <- lift getNetwork + (tipHash, tip) <- fmap headerSlot <$> runNetworkLayer (getNetworkTip network) + epochBlocks <- blocksFromPacks network tip + lastBlocks <- unstableBlocks network tipHash tip epochBlocks + pure (epochBlocks ++ lastBlocks) + + where + end = addSlots numBlocks start + + -- Grab blocks from epoch pack files + blocksFromPacks network tip = do + let epochs = epochRange numBlocks start tip + epochBlocks <- runNetworkLayer (getEpochs network epochs) + pure $ filter (blockIsBetween start end) (concat epochBlocks) + + -- The next slot after the last block. + slotAfter [] = Nothing + slotAfter bs = Just . slotNext . headerSlot . header . last $ bs + + -- Grab the remaining blocks which aren't packed in epoch files, + -- starting from the tip. + unstableBlocks network tipHash tip epochBlocks = do + let start' = fromMaybe start (slotAfter epochBlocks) + + lastBlocks <- if end > start' && start' <= tip + then runNetworkLayer $ fetchBlocksFromTip network start' tipHash + else pure [] + + pure $ filter (blockIsBefore end) lastBlocks + +-- | Fetch epoch blocks until one fails. +getEpochs + :: Monad m + => NetworkLayer m + -> [EpochIndex] + -> ExceptT NetworkLayerError m [[Block]] +getEpochs network = mapUntilError (getEpoch network) + +-- Fetch blocks which are not in epoch pack files. +fetchBlocksFromTip + :: Monad m + => NetworkLayer m + -> SlotId + -> Hash "BlockHeader" + -> ExceptT NetworkLayerError m [Block] +fetchBlocksFromTip network start tipHash = reverse <$> workBackwards tipHash + where + workBackwards headerHash = do + block <- getBlock network headerHash + if blockIsAfter start block + then do + blocks <- workBackwards $ prevBlockHash $ header block + pure (block:blocks) + else pure [block] + +-- * Utility functions for monadic loops + +-- | Apply an action to each element of a list, until an action fails, or there +-- are no more elements. This is like mapM, except that it always succeeds and +-- the resulting list might be smaller than the given list. +mapUntilError + :: Monad m + => (a -> ExceptT e m b) + -- ^ Action to run + -> [a] + -- ^ Elements + -> ExceptT e m [b] + -- ^ Results +mapUntilError action (x:xs) = ExceptT $ runExceptT (action x) >>= \case + Left _ -> pure $ Right [] + Right r -> runExceptT $ do + rs <- mapUntilError action xs + pure (r:rs) +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. +epochRange + :: SlotCount + -- ^ Number of slots + -> SlotId + -- ^ Start point + -> SlotId + -- ^ Latest block available + -> [EpochIndex] +epochRange numBlocks (SlotId startEpoch (LocalSlotIndex 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 + +-- | Predicate returns true iff the block is after then given slot +blockIsAfter :: SlotId -> Block -> Bool +blockIsAfter s = (> s) . headerSlot . header + +-- | Predicate returns true iff the block is before the given slot. +blockIsBefore :: SlotId -> Block -> Bool +blockIsBefore s = (< s) . headerSlot . header + +-- | @blockIsBetween start end@ Returns true if the block is in within the +-- interval @[start, end)@. +blockIsBetween :: SlotId -> SlotId -> Block -> Bool +blockIsBetween start end b = blockIsSameOrAfter start b && blockIsBefore end b diff --git a/src/Cardano/ChainProducer/RustHttpBridge/Api.hs b/src/Cardano/ChainProducer/RustHttpBridge/Api.hs index 941a027cf2a..411f307cadc 100644 --- a/src/Cardano/ChainProducer/RustHttpBridge/Api.hs +++ b/src/Cardano/ChainProducer/RustHttpBridge/Api.hs @@ -7,7 +7,7 @@ module Cardano.ChainProducer.RustHttpBridge.Api , api , Block (..) , BlockHeader (..) - , EpochId (..) + , EpochIndex (..) , NetworkName (..) ) where @@ -26,6 +26,7 @@ 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 @@ -46,7 +47,7 @@ type GetBlockByHash type GetEpochById = Capture "networkName" NetworkName :> "epoch" - :> Capture "epochId" EpochId + :> Capture "epochId" EpochIndex :> Get '[Packed CBOR] [Block] -- | Retrieve the header of the latest known block. @@ -75,12 +76,12 @@ instance FromCBOR BlockHeader where -- | Represents a unique epoch. -- -newtype EpochId = EpochId - { getEpochId :: Primitive.EpochId +newtype EpochIndex = EpochIndex + { getEpochIndex :: Slotting.EpochIndex } deriving (Eq, Show) -instance ToHttpApiData (EpochId) where - toUrlPiece = toUrlPiece . Primitive.getEpochId . getEpochId +instance ToHttpApiData (EpochIndex) where + toUrlPiece = toUrlPiece . Slotting.getEpochIndex . getEpochIndex -- | Represents the name of a Cardano network. -- @@ -90,4 +91,3 @@ newtype NetworkName = NetworkName instance ToHttpApiData NetworkName where toUrlPiece = getNetworkName - diff --git a/src/Cardano/ChainProducer/RustHttpBridge/Client.hs b/src/Cardano/ChainProducer/RustHttpBridge/Client.hs index faaac46f0db..49240a66069 100644 --- a/src/Cardano/ChainProducer/RustHttpBridge/Client.hs +++ b/src/Cardano/ChainProducer/RustHttpBridge/Client.hs @@ -4,27 +4,45 @@ -- | An API client for the Cardano HTTP Bridge. module Cardano.ChainProducer.RustHttpBridge.Client - ( getBlockByHash - , getEpochById - , getTipBlockHeader + ( mkNetworkLayer + , newNetworkLayer ) where +import Prelude + import Cardano.ChainProducer.RustHttpBridge.Api - ( Block, BlockHeader, EpochId, NetworkName, api ) + ( Block, BlockHeader, EpochIndex, NetworkName, api ) +import Cardano.ChainProducer.RustHttpBridge.NetworkLayer + ( NetworkLayer (..), NetworkLayerError (..) ) +import Control.Monad.Except + ( ExceptT (..), throwError ) +import Crypto.Hash + ( HashAlgorithm, digestFromByteString ) import Crypto.Hash.Algorithms ( Blake2b_256 ) +import Data.Bifunctor + ( first ) +import Data.ByteArray + ( convert ) +import Data.Text + ( Text ) +import Network.HTTP.Client + ( Manager, defaultManagerSettings, newManager ) import Servant.API ( (:<|>) (..) ) import Servant.Client - ( ClientM, client ) + ( BaseUrl, ClientM, client, mkClientEnv, parseBaseUrl, runClientM ) import Servant.Extra.ContentTypes - ( Hash, WithHash ) + ( Hash (..), WithHash (..) ) + +import qualified Cardano.ChainProducer.RustHttpBridge.Api as Api +import qualified Cardano.Wallet.Primitive as Primitive -- | Retrieve a block identified by the unique hash of its header. getBlockByHash :: NetworkName -> Hash Blake2b_256 BlockHeader -> ClientM Block -- | Retrieve all the blocks for the epoch identified by the given integer ID. -getEpochById :: NetworkName -> EpochId -> ClientM [Block] +getEpochById :: NetworkName -> EpochIndex -> ClientM [Block] -- | Retrieve the header of the latest known block. getTipBlockHeader :: NetworkName -> ClientM (WithHash Blake2b_256 BlockHeader) @@ -34,3 +52,40 @@ getBlockByHash :<|> getTipBlockHeader = client api +mkNetworkLayer :: Manager -> BaseUrl -> NetworkName -> NetworkLayer IO +mkNetworkLayer mgr baseUrl network = NetworkLayer + { getBlock = \hash -> do + hash' <- hashToApi' hash + run (Api.getBlock <$> getBlockByHash network hash') + , getEpoch = \ep -> run (map Api.getBlock + <$> getEpochById network (Api.EpochIndex ep)) + , getNetworkTip = run (blockHeaderHash <$> getTipBlockHeader network) + } + where + run query = ExceptT $ (first convertError) <$> runClientM query env + env = mkClientEnv mgr baseUrl + convertError = NetworkLayerError . show + +newNetworkLayer :: Text -> IO (NetworkLayer IO) +newNetworkLayer network = do + mgr <- newManager defaultManagerSettings + baseUrl <- parseBaseUrl "http://localhost:1337/" + pure $ mkNetworkLayer mgr baseUrl (Api.NetworkName network) + +blockHeaderHash + :: WithHash algorithm BlockHeader + -> (Primitive.Hash "BlockHeader", Primitive.BlockHeader) +blockHeaderHash (WithHash h (Api.BlockHeader bh)) + = (Primitive.Hash (convert h), bh) + +hashToApi :: HashAlgorithm algorithm => Primitive.Hash a -> Maybe (Hash algorithm b) +hashToApi (Primitive.Hash h) = Hash <$> digestFromByteString h + +-- | Converts a Hash to the Digest type that the Api module requires. +hashToApi' + :: (Monad m, HashAlgorithm algorithm) + => Primitive.Hash a + -> ExceptT NetworkLayerError m (Hash algorithm b) +hashToApi' h = case hashToApi h of + Just h' -> pure h' + Nothing -> throwError $ NetworkLayerError "hashToApi: Digest was of the wrong length" diff --git a/src/Cardano/ChainProducer/RustHttpBridge/NetworkLayer.hs b/src/Cardano/ChainProducer/RustHttpBridge/NetworkLayer.hs new file mode 100644 index 00000000000..cc0cf86d0bd --- /dev/null +++ b/src/Cardano/ChainProducer/RustHttpBridge/NetworkLayer.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds #-} + +module Cardano.ChainProducer.RustHttpBridge.NetworkLayer + ( NetworkLayer (..) + , NetworkLayerError(..) + ) where + +import Prelude + +import Cardano.Wallet.Primitive + ( Block (..), BlockHeader (..), Hash (..) ) +import Cardano.Wallet.Slotting + ( EpochIndex ) +import Control.Exception + ( Exception (..) ) +import Control.Monad.Except + ( ExceptT ) + +-- | Endpoints of the cardano-http-bridge API. +data NetworkLayer m = NetworkLayer + { getBlock :: Hash "BlockHeader" -> ExceptT NetworkLayerError m Block + , getEpoch :: EpochIndex -> ExceptT NetworkLayerError m [Block] + , getNetworkTip :: ExceptT NetworkLayerError m (Hash "BlockHeader", BlockHeader) + } + +data NetworkLayerError + = NetworkLayerError String + deriving (Show, Eq) + +instance Exception NetworkLayerError diff --git a/src/Cardano/Wallet/Binary.hs b/src/Cardano/Wallet/Binary.hs index 5c7ba831cce..9817ee5399d 100644 --- a/src/Cardano/Wallet/Binary.hs +++ b/src/Cardano/Wallet/Binary.hs @@ -42,13 +42,13 @@ import Cardano.Wallet.Primitive , Block (..) , BlockHeader (..) , Coin (..) - , EpochId (..) , Hash (..) - , SlotId (..) , Tx (..) , TxIn (..) , TxOut (..) ) +import Cardano.Wallet.Slotting + ( EpochIndex (..), LocalSlotIndex (..) ) import Control.Monad ( void ) import Crypto.Hash @@ -193,7 +193,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 (EpochId epoch) (SlotId 0) previous + return $ BlockHeader (EpochIndex epoch) (LocalSlotIndex 0) previous decodeGenesisConsensusData :: CBOR.Decoder s Word64 decodeGenesisConsensusData = do @@ -248,7 +248,8 @@ decodeMainBlockHeader = do _ <- decodeMainProof (epoch, slot) <- decodeMainConsensusData _ <- decodeMainExtraData - return $ BlockHeader (EpochId epoch) (SlotId slot) previous + return $ BlockHeader (EpochIndex epoch) + (LocalSlotIndex slot) previous decodeMainConsensusData :: CBOR.Decoder s (Word64, Word16) decodeMainConsensusData = do diff --git a/src/Cardano/Wallet/Primitive.hs b/src/Cardano/Wallet/Primitive.hs index bd273800610..faaf684d9b9 100644 --- a/src/Cardano/Wallet/Primitive.hs +++ b/src/Cardano/Wallet/Primitive.hs @@ -23,12 +23,6 @@ module Cardano.Wallet.Primitive Block(..) , BlockHeader(..) - -- * Epoch - , EpochId (..) - - -- * Slot - , SlotId (..) - -- * Tx , Tx(..) , TxIn(..) @@ -60,6 +54,8 @@ module Cardano.Wallet.Primitive import Prelude +import Cardano.Wallet.Slotting + ( EpochIndex, LocalSlotIndex ) import Control.DeepSeq ( NFData (..) ) import Control.Monad.Trans.State.Strict @@ -75,7 +71,7 @@ import Data.Set import Data.Traversable ( for ) import Data.Word - ( Word16, Word32, Word64 ) + ( Word32, Word64 ) import GHC.Generics ( Generic ) import GHC.TypeLits @@ -84,18 +80,6 @@ import GHC.TypeLits import qualified Data.Map.Strict as Map import qualified Data.Set as Set --- * Epoch - -newtype EpochId = EpochId - { getEpochId :: Word64 - } deriving (Eq, Generic, NFData, Num, Ord, Show) - --- * Slot - -newtype SlotId = SlotId - { getSlotId :: Word16 - } deriving (Eq, Generic, NFData, Num, Ord, Show) - -- * Block data Block = Block @@ -109,9 +93,9 @@ instance NFData Block data BlockHeader = BlockHeader { epochIndex - :: !EpochId + :: !EpochIndex , slotNumber - :: !SlotId + :: !LocalSlotIndex , prevBlockHash :: !(Hash "BlockHeader") } deriving (Show, Eq, Ord, Generic) diff --git a/src/Cardano/Wallet/Slotting.hs b/src/Cardano/Wallet/Slotting.hs new file mode 100644 index 00000000000..8faebbead2d --- /dev/null +++ b/src/Cardano/Wallet/Slotting.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Cardano.Wallet.Slotting + ( SlotId (..) + , EpochIndex (..) + , LocalSlotIndex (..) + , SlotCount + , slotsPerEpoch + , addSlots + , slotDiff + , slotNext + , slotPrev + , isValidSlotId + ) where + +import Prelude + +import Control.DeepSeq + ( NFData (..) ) +import Data.Word + ( Word16, Word64 ) +import GHC.Generics + ( Generic ) +import Numeric.Natural + ( Natural ) + +-- | Denotes a chain epoch, which contains a certain number of slots. +newtype EpochIndex = EpochIndex + { getEpochIndex :: Word64 } + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Num, Enum, NFData) + +-- | Denotes the slot number within an epoch. +newtype LocalSlotIndex = LocalSlotIndex + { getLocalSlotIndex :: Word16 } + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Num, Enum, NFData) + +-- | A slot identifier is the combination of an epoch and slot. +data SlotId = SlotId + { epochIndex :: !EpochIndex + , slotNumber :: !LocalSlotIndex + } deriving stock (Show, Eq, Ord, Generic) + +type SlotCount = Natural + +-- | Hard-coded for the time being +slotsPerEpoch :: SlotCount +slotsPerEpoch = 21600 + +instance Bounded LocalSlotIndex where + minBound = LocalSlotIndex 0 + maxBound = LocalSlotIndex (fromIntegral slotsPerEpoch - 1) + +-- | Add a number of slots to an (Epoch, LocalSlotIndex) pair, where the number +-- of slots can be greater than one epoch. +addSlots :: SlotCount -> SlotId -> SlotId +addSlots n (SlotId (EpochIndex e) (LocalSlotIndex sl)) + = SlotId (EpochIndex (e + fromIntegral e')) + (LocalSlotIndex (fromIntegral sl')) + where + e' = n' `div` slotsPerEpoch + sl' = n' `mod` slotsPerEpoch + n' = fromIntegral sl + n + +-- | @slotDiff a b@ is the number of slots by which @a@ is greater than @b@. +slotDiff :: SlotId -> SlotId -> Integer +slotDiff s1 s2 = fromIntegral (flattenSlotId s1) - fromIntegral (flattenSlotId s2) + +-- | Convert SlotId into number of slots since genesis. +flattenSlotId :: SlotId -> SlotCount +flattenSlotId (SlotId (EpochIndex e) (LocalSlotIndex sl)) + = fromIntegral e * slotsPerEpoch + fromIntegral sl + +-- | The slot after. +slotNext :: SlotId -> SlotId +slotNext = addSlots 1 + +-- | The slot before. +slotPrev :: SlotId -> SlotId +slotPrev (SlotId ep 0) = SlotId (ep - 1) (fromIntegral slotsPerEpoch - 1) +slotPrev (SlotId ep sl) = SlotId ep (sl - 1) + +-- | Whether the epoch index and slot number are in range. +isValidSlotId :: SlotId -> Bool +isValidSlotId (SlotId ep (LocalSlotIndex sl)) = ep >= 0 && sl >= 0 + && sl < fromIntegral slotsPerEpoch diff --git a/src/Servant/Extra/ContentTypes.hs b/src/Servant/Extra/ContentTypes.hs index 9526788d3fb..38a579624cd 100644 --- a/src/Servant/Extra/ContentTypes.hs +++ b/src/Servant/Extra/ContentTypes.hs @@ -20,6 +20,8 @@ import Crypto.Hash ( Digest, hashWith ) import Crypto.Hash.IO ( HashAlgorithm (..) ) +import Data.ByteArray.Encoding + ( Base (Base16), convertToBase ) import Data.Proxy ( Proxy (..) ) import Data.Text.Encoding @@ -32,7 +34,6 @@ import Servant.API import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Read as CBOR -import qualified Data.ByteArray as BA import qualified Data.ByteString.Lazy as BL -- | Represents a CBOR (Concise Binary Object Representation) object. @@ -47,7 +48,7 @@ class FromCBOR a where fromCBOR :: CBOR.Decoder s a instance Accept CBOR where - contentType _ = "application" // "cbor" + contentType _ = "text" // "plain" instance FromCBOR a => MimeUnrender CBOR a where mimeUnrender _ bl = either @@ -65,7 +66,7 @@ data ComputeHash algorithm a newtype Hash algorithm a = Hash (Digest algorithm) instance ToHttpApiData (Hash algorithm a) where - toUrlPiece (Hash digest) = decodeUtf8 $ BA.convert digest + toUrlPiece (Hash digest) = decodeUtf8 $ convertToBase Base16 digest -- | Represents a piece of data with an accompanying hash value. data WithHash algorithm a = WithHash @@ -87,11 +88,10 @@ instance forall a b alg . (MimeUnrender a b, HashAlgorithm alg) => data Packed a instance Accept a => Accept (Packed a) where - contentType _ = "application" // "cardano-pack" + contentType _ = "text" // "plain" instance forall a b . MimeUnrender a b => MimeUnrender (Packed a) [b] where mimeUnrender _ bs = either (Left . show) (traverse $ mimeUnrender (Proxy :: Proxy a) . BL.fromStrict) (decodePackfile bs) - diff --git a/test/unit/Cardano/ChainProducer/RustHttpBridge/MockNetworkLayer.hs b/test/unit/Cardano/ChainProducer/RustHttpBridge/MockNetworkLayer.hs new file mode 100644 index 00000000000..2747fe00509 --- /dev/null +++ b/test/unit/Cardano/ChainProducer/RustHttpBridge/MockNetworkLayer.hs @@ -0,0 +1,74 @@ +module Cardano.ChainProducer.RustHttpBridge.MockNetworkLayer + ( mockNetworkLayer + ) where + +import Prelude + +import Control.Monad.Catch + ( MonadThrow (..) ) +import Control.Monad.Except + ( throwError ) +import qualified Data.ByteString.Char8 as B8 + +import Cardano.ChainProducer.RustHttpBridge.NetworkLayer + ( NetworkLayer (..), NetworkLayerError (..) ) +import Cardano.Wallet.Primitive + ( Block (..), BlockHeader (..), Hash (..) ) +import Cardano.Wallet.Slotting + ( EpochIndex (..) + , LocalSlotIndex (..) + , SlotId (..) + , slotPrev + , slotsPerEpoch + ) + +-- | Embed an epoch index and slot number into a hash. +mockHash :: SlotId -> Hash a +mockHash (SlotId (EpochIndex ep) (LocalSlotIndex sl)) + = Hash $ B8.pack ("Hash " <> show ep <> "." <> show sl) + +-- | Extract the epoch index and slot number from a hash. +unMockHash :: Hash a -> SlotId +unMockHash (Hash h) = parse . map B8.unpack . B8.split '.' . B8.drop 5 $ h + where + parse [ep, sl] = + SlotId (EpochIndex (read ep)) (LocalSlotIndex (read sl)) + parse _ = error $ "Could not read mock hash: " ++ B8.unpack h + +-- | Create a block header from its hash, assuming that the hash was created +-- with 'mockHash'. +mockHeaderFromHash :: Hash a -> BlockHeader +mockHeaderFromHash h = BlockHeader ep sl prevHash + where + slotId@(SlotId ep sl) = unMockHash h + prevHash = mockHash (slotPrev slotId) + +-- | Generate an entire epoch's worth of mock blocks. There are no transactions +-- generated. +mockEpoch :: EpochIndex -> [Block] +mockEpoch ep = [ Block (mockHeaderFromHash (mockHash sl)) mempty + | sl <- [ SlotId ep i | i <- epochs ] ] + where epochs = [ 0 .. fromIntegral (slotsPerEpoch - 1) ] + +-- | A network layer which returns mock blocks. +mockNetworkLayer + :: MonadThrow m + => EpochIndex -- ^ make getEpoch fail for epochs after this + -> SlotId -- ^ the tip block + -> NetworkLayer m +mockNetworkLayer firstUnstableEpoch tip = NetworkLayer + { getBlock = \hash -> do + -- putStrLn $ "mock getBlock " ++ show hash + pure $ Block (mockHeaderFromHash hash) mempty + , getEpoch = \ep -> do + -- putStrLn $ "mock getEpoch " ++ show ep + if ep < firstUnstableEpoch + then pure $ mockEpoch ep + else throwError $ NetworkLayerError + $ "mock epoch " ++ show ep ++ " > firstUnstableEpoch " + ++ show firstUnstableEpoch + , getNetworkTip = do + -- putStrLn $ "mock getNetworkTip" + let hash = mockHash tip + pure (hash, mockHeaderFromHash hash) + } diff --git a/test/unit/Cardano/ChainProducer/RustHttpBridgeSpec.hs b/test/unit/Cardano/ChainProducer/RustHttpBridgeSpec.hs new file mode 100644 index 00000000000..c6deeb13620 --- /dev/null +++ b/test/unit/Cardano/ChainProducer/RustHttpBridgeSpec.hs @@ -0,0 +1,74 @@ +module Cardano.ChainProducer.RustHttpBridgeSpec (spec) where + +import Prelude + +import Control.Exception + ( Exception, throwIO ) +import Control.Monad + ( (<=<) ) +import Control.Monad.Except + ( ExceptT, runExceptT ) +import Control.Monad.IO.Class + ( MonadIO, liftIO ) +import Test.Hspec + ( Spec, SpecWith, beforeAll, describe, it, shouldBe, shouldSatisfy ) + +import Cardano.ChainProducer + ( nextBlocks ) +import Cardano.ChainProducer.RustHttpBridge +-- import Cardano.ChainProducer.RustHttpBridge.Client +-- ( newNetworkLayer ) +import Cardano.ChainProducer.RustHttpBridge.MockNetworkLayer + ( mockNetworkLayer ) +import Cardano.ChainProducer.RustHttpBridge.NetworkLayer + ( NetworkLayer ) +import Cardano.Wallet.Primitive + ( BlockHeader (..), header ) +import Cardano.Wallet.Slotting + ( SlotId (SlotId) ) + +spec :: Spec +spec = do + describe "Getting next blocks with a mock backend" $ do + beforeAll (pure $ mockNetworkLayer 105 (SlotId 106 1492)) $ do + getNextBlocksSpec + + {- Uncomment to run with actual backend. + Some tests will fail because the tip has moved. + describe "Getting next blocks with a real backend" $ do + beforeAll (newNetworkLayer "mainnet") $ do + getNextBlocksSpec + -} + +getNextBlocksSpec :: SpecWith (NetworkLayer IO) +getNextBlocksSpec = do + it "should get something from the latest epoch" $ \network -> do + blocks <- runBackend network $ nextBlocks 1000 (SlotId 106 1000) + -- the number of blocks between slots 1000 and 1492 inclusive + length blocks `shouldBe` 493 + let hdrs = map header blocks + map slotNumber hdrs `shouldBe` [1000 .. 1492] + map epochIndex hdrs `shouldSatisfy` all (== 106) + + it "should get something from an unstable epoch" $ \network -> do + blocks <- runBackend network $ nextBlocks 1000 (SlotId 105 17000) + length blocks `shouldBe` 1000 + + it "should get from old epochs" $ \network -> do + blocks <- runBackend network $ nextBlocks 1000 (SlotId 104 10000) + length blocks `shouldBe` 1000 + map (epochIndex . header) blocks `shouldSatisfy` all (== 104) + + it "should produce no blocks if start slot is after tip" $ \network -> do + blocks <- runBackend network $ nextBlocks 1000 (SlotId 107 0) + blocks `shouldBe` [] + + it "should work for zero blocks" $ \network -> do + blocks <- runBackend network $ nextBlocks 0 (SlotId 106 1000) + blocks `shouldBe` [] + +unsafeRunExceptT :: (Exception e, MonadIO m) => ExceptT e m a -> m a +unsafeRunExceptT = either (liftIO . throwIO) pure <=< runExceptT + +runBackend :: Exception e => NetworkLayer IO -> ExceptT e RustBackend a -> IO a +runBackend network = runRustBackend network . unsafeRunExceptT diff --git a/test/unit/Cardano/Wallet/BlockSyncerSpec.hs b/test/unit/Cardano/Wallet/BlockSyncerSpec.hs index 2ff782940eb..1e25111dfef 100644 --- a/test/unit/Cardano/Wallet/BlockSyncerSpec.hs +++ b/test/unit/Cardano/Wallet/BlockSyncerSpec.hs @@ -13,7 +13,9 @@ import Prelude import Cardano.Wallet.BlockSyncer ( BlockHeadersConsumed (..), tickingFunction ) import Cardano.Wallet.Primitive - ( Block (..), BlockHeader (..), EpochId (..), Hash (..), SlotId (..) ) + ( Block (..), BlockHeader (..), Hash (..) ) +import Cardano.Wallet.Slotting + ( EpochIndex (..), LocalSlotIndex (..) ) import Control.Concurrent ( forkIO, killThread ) import Control.Concurrent.MVar @@ -133,7 +135,7 @@ instance Arbitrary Blocks where blockHeaderHash = Hash . CBOR.toStrictByteString . encodeBlockHeader where - encodeBlockHeader (BlockHeader (EpochId epoch) (SlotId slot) prev) = mempty + encodeBlockHeader (BlockHeader (EpochIndex epoch) (LocalSlotIndex slot) prev) = mempty <> CBOR.encodeListLen 3 <> CBOR.encodeWord64 epoch <> CBOR.encodeWord16 slot diff --git a/test/unit/Cardano/Wallet/PrimitiveSpec.hs b/test/unit/Cardano/Wallet/PrimitiveSpec.hs index 1c22da5704c..e47f9d4c6e4 100644 --- a/test/unit/Cardano/Wallet/PrimitiveSpec.hs +++ b/test/unit/Cardano/Wallet/PrimitiveSpec.hs @@ -14,9 +14,7 @@ import Cardano.Wallet.Primitive , BlockHeader (..) , Coin (..) , Dom (..) - , EpochId (..) , Hash (..) - , SlotId (..) , Tx (..) , TxIn (..) , TxOut (..) @@ -29,6 +27,8 @@ import Cardano.Wallet.Primitive , restrictedTo , updatePending ) +import Cardano.Wallet.SlottingOrphans + () import Data.Set ( Set, (\\) ) import Test.Hspec @@ -242,12 +242,6 @@ instance Arbitrary Coin where -- No Shrinking arbitrary = Coin <$> choose (0, 3) -instance Arbitrary EpochId where - arbitrary = EpochId <$> arbitrary - -instance Arbitrary SlotId where - arbitrary = SlotId <$> arbitrary - instance Arbitrary TxOut where -- No Shrinking arbitrary = TxOut diff --git a/test/unit/Cardano/Wallet/SlottingOrphans.hs b/test/unit/Cardano/Wallet/SlottingOrphans.hs new file mode 100644 index 00000000000..b208f13c9ae --- /dev/null +++ b/test/unit/Cardano/Wallet/SlottingOrphans.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Wallet.SlottingOrphans + where + +import Prelude + +import Test.QuickCheck + ( Arbitrary (..), choose ) + +import Cardano.Wallet.Slotting + ( EpochIndex (..), LocalSlotIndex (..), SlotId (..), slotsPerEpoch ) + +instance Arbitrary SlotId where + arbitrary = SlotId <$> arbitrary <*> arbitrary + +instance Arbitrary EpochIndex where + arbitrary = EpochIndex <$> arbitrary + +instance Arbitrary LocalSlotIndex where + arbitrary = LocalSlotIndex <$> choose (0, fromIntegral slotsPerEpoch - 1) diff --git a/test/unit/Cardano/Wallet/SlottingSpec.hs b/test/unit/Cardano/Wallet/SlottingSpec.hs new file mode 100644 index 00000000000..21711414ee2 --- /dev/null +++ b/test/unit/Cardano/Wallet/SlottingSpec.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Wallet.SlottingSpec + ( spec + ) where + +import Prelude + +import Cardano.Wallet.Slotting + ( SlotCount + , SlotId (..) + , addSlots + , isValidSlotId + , slotDiff + , slotNext + , slotPrev + , slotsPerEpoch + ) +import Cardano.Wallet.SlottingOrphans + () + +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( Arbitrary (..), Property, checkCoverage, choose, property ) + +spec :: Spec +spec = do + describe "Generators are valid" $ do + it "Arbitrary SlotId" $ property isValidSlotId + + describe "Basic slot arithmetic" $ do + it "slotNext . slotPrev = id" + (checkCoverage propNextSlotPrevSlot) + + it "slotNext always increments the SlotId" + (checkCoverage propNextIncrements) + + it "slotPrev decrements the SlotId" + (checkCoverage propPrevDecrements) + + it "addSlots results in correct difference" + (checkCoverage propAddSlotsDiff) + + it "addSlots 0 == id" + (checkCoverage propAddSlotsId) + +propNextSlotPrevSlot :: SlotId -> Property +propNextSlotPrevSlot sl = property $ slotPrev (slotNext sl) == sl + +propNextIncrements :: SlotId -> Property +propNextIncrements sl = property $ slotDiff (slotNext sl) sl == 1 + +propPrevDecrements :: SlotId -> Property +propPrevDecrements sl = property $ slotDiff (slotPrev sl) sl == (-1) + +instance Arbitrary SlotCount where + arbitrary = fromIntegral <$> choose (0 :: Int, 4 * (fromIntegral slotsPerEpoch)) + +propAddSlotsDiff :: (SlotCount, SlotId) -> Property +propAddSlotsDiff (n, sl) = property $ + slotDiff (addSlots n sl) sl == fromIntegral n + +propAddSlotsId :: SlotId -> Property +propAddSlotsId sl = property $ addSlots 0 sl == sl