From 736c80c6164584b563427c2d1cdcda9fcfb9b800 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 13 Mar 2019 18:29:00 +0100 Subject: [PATCH 1/3] Review modules organization and folder architecture for Network Layer There was a bit of confusion IMO about where the network layer sits (understandable because there's no clear layout of what the architecture should / could be anywhere ...). Also, I took the opportunity to remove the 'Rust' part of the module names since this is quite irrelevant. We are programming to an interface (a.k.a the http-bridge API, and the implementation of that interface shouldn't really matter). Doing so, I've remove the unnecessary abstraction of the chain producer Monad. We won't be instantiating multiple network layer at once, so for now, this adds an extra layer of complexity that isn't needed. In practice we can just fallback to a plain data type that we instantiate using one service (e.g. the cardano-http-bridge) or another (e.g. the Haskell shelley node). --- cardano-wallet.cabal | 6 + src/Cardano/NetworkLayer.hs | 21 ++ src/Cardano/NetworkLayer/HttpBridge.hs | 286 ++++++++++++++++++ src/Cardano/NetworkLayer/HttpBridge/Api.hs | 88 ++++++ .../NetworkLayer/HttpBridge/ApiSpec.hs | 12 + .../Cardano/NetworkLayer/HttpBridgeSpec.hs | 135 +++++++++ test/unit/Cardano/NetworkLayerSpec.hs | 14 + 7 files changed, 562 insertions(+) create mode 100644 src/Cardano/NetworkLayer.hs create mode 100644 src/Cardano/NetworkLayer/HttpBridge.hs create mode 100644 src/Cardano/NetworkLayer/HttpBridge/Api.hs create mode 100644 test/unit/Cardano/NetworkLayer/HttpBridge/ApiSpec.hs create mode 100644 test/unit/Cardano/NetworkLayer/HttpBridgeSpec.hs create mode 100644 test/unit/Cardano/NetworkLayerSpec.hs diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 686e69eb5bc..1842a840f00 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -63,6 +63,9 @@ library Cardano.ChainProducer.RustHttpBridge.Api Cardano.ChainProducer.RustHttpBridge.Client Cardano.ChainProducer.RustHttpBridge.NetworkLayer + Cardano.NetworkLayer + Cardano.NetworkLayer.HttpBridge + Cardano.NetworkLayer.HttpBridge.Api Cardano.Wallet Cardano.Wallet.AddressDerivation Cardano.Wallet.AddressDiscovery @@ -161,3 +164,6 @@ test-suite unit Cardano.Wallet.MnemonicSpec Cardano.Wallet.PrimitiveSpec Cardano.WalletSpec + Cardano.NetworkLayerSpec + Cardano.NetworkLayer.HttpBridgeSpec + Cardano.NetworkLayer.HttpBridge.ApiSpec diff --git a/src/Cardano/NetworkLayer.hs b/src/Cardano/NetworkLayer.hs new file mode 100644 index 00000000000..0c9a2718313 --- /dev/null +++ b/src/Cardano/NetworkLayer.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} + +module Cardano.NetworkLayer where + +import Cardano.Wallet.Primitive + ( Block, BlockHeader (..), Hash (..), SlotId ) +import Control.Monad.Except + ( ExceptT ) +import Numeric.Natural + ( Natural ) + + +data NetworkLayer m e0 e1 = NetworkLayer + { nextBlocks + :: Natural -- ^ Number of blocks to retrieve + -> SlotId -- ^ Starting Point + -> ExceptT e0 m [Block] + + , networkTip + :: ExceptT e1 m (Hash "BlockHeader", BlockHeader) + } diff --git a/src/Cardano/NetworkLayer/HttpBridge.hs b/src/Cardano/NetworkLayer/HttpBridge.hs new file mode 100644 index 00000000000..baafe0e1ae9 --- /dev/null +++ b/src/Cardano/NetworkLayer/HttpBridge.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.NetworkLayer.HttpBridge where + +-- | +-- Copyright: © 2018-2019 IOHK +-- License: MIT +-- +-- This module contains the necessary logic to talk to implement the network +-- layer using the cardano-http-bridge as a chain producer. + +import Prelude + +import Cardano.NetworkLayer.HttpBridge.Api + ( ApiT (..), EpochIndex (..), NetworkName, api ) +import Cardano.Wallet.Primitive + ( Block (..) + , BlockHeader (..) + , Hash (..) + , Hash (..) + , SlotId (..) + , slotIncr + , slotsPerEpoch + ) +import Control.Exception + ( Exception ) +import Control.Monad.Except + ( ExceptT (..), mapExceptT, runExceptT, throwError ) +import Control.Monad.IO.Class + ( MonadIO, liftIO ) +import Control.Monad.Reader + ( MonadReader, ReaderT (..), ask, lift ) +import Crypto.Hash + ( HashAlgorithm, digestFromByteString ) +import Crypto.Hash.Algorithms + ( Blake2b_256 ) +import Data.Bifunctor + ( first ) +import Data.ByteArray + ( convert ) +import Data.Maybe + ( fromMaybe ) +import Data.Word + ( Word64 ) +import Network.HTTP.Client + ( Manager ) +import Numeric.Natural + ( Natural ) +import Servant.API + ( (:<|>) (..) ) +import Servant.Client + ( BaseUrl, ClientM, client, mkClientEnv, runClientM ) +import Servant.Extra.ContentTypes + ( WithHash (..) ) + +import qualified Servant.Extra.ContentTypes as Api + + +newtype RustBackend a = RustBackend + { runRB :: ReaderT (HttpBridge IO) IO a + } deriving + ( Monad + , Applicative + , Functor + , MonadReader (HttpBridge IO) + , MonadIO + ) + +runRustBackend :: HttpBridge IO -> RustBackend a -> IO a +runRustBackend network action = runReaderT (runRB action) network + +getNetwork :: RustBackend (HttpBridge IO) +getNetwork = ask + +-- | The things that can go wrong when retrieving blocks. +newtype ErrGetNextBlocks + = GetNextBlocksError String + deriving (Show, Eq) + +instance Exception ErrGetNextBlocks + +-- 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. +nextBlocks + :: Natural -- ^ Number of blocks to retrieve + -> SlotId -- ^ Starting point + -> ExceptT ErrGetNextBlocks RustBackend [Block] +nextBlocks numBlocks start = do + net <- lift getNetwork + (tipHash, tip) <- fmap slotId <$> runHttpBridge (getNetworkTip net) + epochBlocks <- blocksFromPacks net tip + lastBlocks <- unstableBlocks net tipHash tip epochBlocks + pure (epochBlocks ++ lastBlocks) + where + end = slotIncr numBlocks start + + -- Grab blocks from epoch pack files + blocksFromPacks network tip = do + let epochs = epochRange numBlocks start tip + epochBlocks <- runHttpBridge (getEpochs network epochs) + pure $ filter (blockIsBetween start end) (concat epochBlocks) + + -- The next slot after the last block. + slotAfter [] = Nothing + slotAfter bs = Just . succ . slotId . 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 runHttpBridge $ fetchBlocksFromTip network start' tipHash + else pure [] + + pure $ filter (blockIsBefore end) lastBlocks + +-- | Fetch epoch blocks until one fails. +getEpochs + :: Monad m + => HttpBridge m + -> [Word64] + -> ExceptT HttpBridgeError m [[Block]] +getEpochs network = mapUntilError (getEpoch network) + +-- Fetch blocks which are not in epoch pack files. +fetchBlocksFromTip + :: Monad m + => HttpBridge m + -> SlotId + -> Hash "BlockHeader" + -> ExceptT HttpBridgeError 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] + +runHttpBridge + :: ExceptT HttpBridgeError IO a + -> ExceptT ErrGetNextBlocks RustBackend a +runHttpBridge = + mapExceptT (fmap handle . liftIO) + where + handle = first (GetNextBlocksError . show) + + +-- * 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 (TODO: Move in the wallet primitives) + +-- | 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 + :: Natural + -- ^ Number of slots + -> SlotId + -- ^ Start point + -> SlotId + -- ^ Latest block available + -> [Word64] +epochRange numBlocks (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) . slotId . header + +-- | Predicate returns true iff the block is after then given slot +blockIsAfter :: SlotId -> Block -> Bool +blockIsAfter s = (> s) . slotId . header + +-- | Predicate returns true iff the block is before the given slot. +blockIsBefore :: SlotId -> Block -> Bool +blockIsBefore s = (< s) . slotId . 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 + + +{------------------------------------------------------------------------------- + HTTP-Bridge Client +-------------------------------------------------------------------------------} + +-- | Endpoints of the cardano-http-bridge API. +data HttpBridge m = HttpBridge + { getBlock + :: Hash "BlockHeader" -> ExceptT HttpBridgeError m Block + , getEpoch + :: Word64 -> ExceptT HttpBridgeError m [Block] + , getNetworkTip + :: ExceptT HttpBridgeError m (Hash "BlockHeader", BlockHeader) + } + +newtype HttpBridgeError + = HttpBridgeError String + deriving (Show, Eq) + +instance Exception HttpBridgeError + +-- | Retrieve a block identified by the unique hash of its header. +getBlockByHash :: NetworkName -> Api.Hash Blake2b_256 (ApiT BlockHeader) -> ClientM (ApiT Block) + +-- | Retrieve all the blocks for the epoch identified by the given integer ID. +getEpochById :: NetworkName -> EpochIndex -> ClientM [ApiT Block] + +-- | Retrieve the header of the latest known block. +getTipBlockHeader :: NetworkName -> ClientM (WithHash Blake2b_256 (ApiT BlockHeader)) + +getBlockByHash + :<|> getEpochById + :<|> getTipBlockHeader + = client api + +-- | Construct a new network layer +mkHttpBridge :: Manager -> BaseUrl -> NetworkName -> HttpBridge IO +mkHttpBridge mgr baseUrl network = HttpBridge + { getBlock = \hash -> do + hash' <- hashToApi' hash + run (getApiT <$> getBlockByHash network hash') + , getEpoch = \ep -> run (map getApiT <$> + getEpochById network (EpochIndex ep)) + , getNetworkTip = run (blockHeaderHash <$> getTipBlockHeader network) + } + where + run :: ClientM a -> ExceptT HttpBridgeError IO a + run query = ExceptT $ (first convertError) <$> runClientM query env + env = mkClientEnv mgr baseUrl + convertError = HttpBridgeError . show + +blockHeaderHash + :: WithHash algorithm (ApiT BlockHeader) + -> (Hash "BlockHeader", BlockHeader) +blockHeaderHash (WithHash h (ApiT bh)) = + (Hash (convert h), bh) + +hashToApi :: HashAlgorithm a => Hash h -> Maybe (Api.Hash a b) +hashToApi (Hash h) = Api.Hash <$> digestFromByteString h + +-- | Converts a Hash to the Digest type that the Api module requires. +hashToApi' + :: (Monad m, HashAlgorithm algorithm) + => Hash a + -> ExceptT HttpBridgeError m (Api.Hash algorithm b) +hashToApi' h = case hashToApi h of + Just h' -> pure h' + Nothing -> throwError + $ HttpBridgeError "hashToApi: Digest was of the wrong length" diff --git a/src/Cardano/NetworkLayer/HttpBridge/Api.hs b/src/Cardano/NetworkLayer/HttpBridge/Api.hs new file mode 100644 index 00000000000..b70103b17d8 --- /dev/null +++ b/src/Cardano/NetworkLayer/HttpBridge/Api.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Copyright: © 2018-2019 IOHK +-- License: MIT +-- +-- An API specification for the Cardano HTTP Bridge. +module Cardano.NetworkLayer.HttpBridge.Api + ( Api + , api + , ApiT(..) + , EpochIndex (..) + , NetworkName (..) + ) where + +import Prelude + +import Cardano.Wallet.Binary + ( decodeBlock, decodeBlockHeader ) +import Cardano.Wallet.Primitive + ( Block, BlockHeader ) +import Crypto.Hash.Algorithms + ( Blake2b_256 ) +import Data.Proxy + ( Proxy (..) ) +import Data.Text + ( Text ) +import Data.Word + ( Word64 ) +import Servant.API + ( (:<|>), (:>), Capture, Get, ToHttpApiData (..) ) +import Servant.Extra.ContentTypes + ( CBOR, ComputeHash, FromCBOR (..), Hash, Packed, WithHash ) + + +api :: Proxy Api +api = Proxy + +type Api + = GetBlockByHash + :<|> GetEpochById + :<|> GetTipBlockHeader + +-- | Retrieve a block identified by the unique hash of its header. +type GetBlockByHash + = Capture "networkName" NetworkName + :> "block" + :> Capture "blockHeaderHash" (Hash Blake2b_256 (ApiT BlockHeader)) + :> Get '[CBOR] (ApiT Block) + +-- | Retrieve all the blocks for the epoch identified by the given integer ID. +type GetEpochById + = Capture "networkName" NetworkName + :> "epoch" + :> Capture "epochId" EpochIndex + :> Get '[Packed CBOR] [ApiT Block] + +-- | Retrieve the header of the latest known block. +type GetTipBlockHeader + = Capture "networkName" NetworkName + :> "tip" + :> Get '[ComputeHash Blake2b_256 CBOR] (WithHash Blake2b_256 (ApiT BlockHeader)) + +newtype ApiT a = ApiT { getApiT :: a } deriving (Show) + +instance FromCBOR (ApiT Block) where + fromCBOR = ApiT <$> decodeBlock + +instance FromCBOR (ApiT BlockHeader) where + fromCBOR = ApiT <$> decodeBlockHeader + +-- | Represents a unique epoch. +newtype EpochIndex = EpochIndex + { getEpochIndex :: Word64 + } deriving (Eq, Show) + +instance ToHttpApiData (EpochIndex) where + toUrlPiece = toUrlPiece . getEpochIndex + +-- | Represents the name of a Cardano network. +newtype NetworkName = NetworkName + { getNetworkName :: Text + } deriving (Eq, Show) + +instance ToHttpApiData NetworkName where + toUrlPiece = getNetworkName diff --git a/test/unit/Cardano/NetworkLayer/HttpBridge/ApiSpec.hs b/test/unit/Cardano/NetworkLayer/HttpBridge/ApiSpec.hs new file mode 100644 index 00000000000..030b0906cb3 --- /dev/null +++ b/test/unit/Cardano/NetworkLayer/HttpBridge/ApiSpec.hs @@ -0,0 +1,12 @@ +module Cardano.NetworkLayer.HttpBridge.ApiSpec + ( spec + ) where + +import Cardano.NetworkLayer.HttpBridge.Api + () +import Prelude +import Test.Hspec + ( Spec ) + +spec :: Spec +spec = return () diff --git a/test/unit/Cardano/NetworkLayer/HttpBridgeSpec.hs b/test/unit/Cardano/NetworkLayer/HttpBridgeSpec.hs new file mode 100644 index 00000000000..64dd81bc496 --- /dev/null +++ b/test/unit/Cardano/NetworkLayer/HttpBridgeSpec.hs @@ -0,0 +1,135 @@ +module Cardano.NetworkLayer.HttpBridgeSpec + ( spec + ) where + +import Prelude + +import Cardano.NetworkLayer.HttpBridge + ( HttpBridge (..) + , HttpBridgeError (..) + , RustBackend + , nextBlocks + , runRustBackend + ) +import Cardano.Wallet.Primitive + ( Block (..), BlockHeader (..), Hash (..), SlotId (..), slotsPerEpoch ) +import Control.Exception + ( Exception, throwIO ) +import Control.Monad + ( (<=<) ) +import Control.Monad.Catch + ( MonadThrow (..) ) +import Control.Monad.Except + ( ExceptT, runExceptT, throwError ) +import Control.Monad.IO.Class + ( MonadIO, liftIO ) +import Data.Word + ( Word64 ) +import Test.Hspec + ( Spec, SpecWith, beforeAll, describe, it, shouldBe, shouldSatisfy ) + +import qualified Data.ByteString.Char8 as B8 + + +spec :: Spec +spec = do + describe "Getting next blocks with a mock backend" $ do + beforeAll (pure $ mockHttpBridge 105 (SlotId 106 1492)) $ do + getNextBlocksSpec + +getNextBlocksSpec :: SpecWith (HttpBridge 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 (slotId . 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 . slotId . 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 => HttpBridge IO -> ExceptT e RustBackend a -> IO a +runBackend network = runRustBackend network . unsafeRunExceptT + + +{------------------------------------------------------------------------------- + Mock HTTP Bridge +-------------------------------------------------------------------------------} + +-- | Embed an epoch index and slot number into a hash. +mockHash :: SlotId -> Hash a +mockHash (SlotId ep 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 (read ep) (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 slot prevHash + where + slot = unMockHash h + prevHash = + if slot == SlotId 0 0 then + Hash "genesis" + else + mockHash (pred slot) + +-- | Generate an entire epoch's worth of mock blocks. There are no transactions +-- generated. +mockEpoch :: Word64 -> [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. +mockHttpBridge + :: MonadThrow m + => Word64 -- ^ make getEpoch fail for epochs after this + -> SlotId -- ^ the tip block + -> HttpBridge m +mockHttpBridge firstUnstableEpoch tip = HttpBridge + { 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 $ HttpBridgeError $ + "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/NetworkLayerSpec.hs b/test/unit/Cardano/NetworkLayerSpec.hs new file mode 100644 index 00000000000..16af9aec9ae --- /dev/null +++ b/test/unit/Cardano/NetworkLayerSpec.hs @@ -0,0 +1,14 @@ +module Cardano.NetworkLayerSpec + ( spec + ) where + +import Prelude + +import Cardano.NetworkLayer + () +import Test.Hspec + ( Spec ) + + +spec :: Spec +spec = return () From 13015bd8c1c329c306f37fb4088b26aca6619cb0 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 13 Mar 2019 18:33:58 +0100 Subject: [PATCH 2/3] remove now obsolete chain producer modules --- cardano-wallet.cabal | 7 - src/Cardano/ChainProducer.hs | 36 ---- src/Cardano/ChainProducer/RustHttpBridge.hs | 194 ------------------ .../ChainProducer/RustHttpBridge/Api.hs | 94 --------- .../ChainProducer/RustHttpBridge/Client.hs | 88 -------- .../RustHttpBridge/NetworkLayer.hs | 39 ---- .../RustHttpBridge/MockNetworkLayer.hs | 76 ------- .../ChainProducer/RustHttpBridgeSpec.hs | 63 ------ 8 files changed, 597 deletions(-) delete mode 100644 src/Cardano/ChainProducer.hs delete mode 100644 src/Cardano/ChainProducer/RustHttpBridge.hs delete mode 100644 src/Cardano/ChainProducer/RustHttpBridge/Api.hs delete mode 100644 src/Cardano/ChainProducer/RustHttpBridge/Client.hs delete mode 100644 src/Cardano/ChainProducer/RustHttpBridge/NetworkLayer.hs delete mode 100644 test/unit/Cardano/ChainProducer/RustHttpBridge/MockNetworkLayer.hs delete mode 100644 test/unit/Cardano/ChainProducer/RustHttpBridgeSpec.hs diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 1842a840f00..585e709230b 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -58,11 +58,6 @@ library hs-source-dirs: src exposed-modules: - Cardano.ChainProducer - Cardano.ChainProducer.RustHttpBridge - Cardano.ChainProducer.RustHttpBridge.Api - Cardano.ChainProducer.RustHttpBridge.Client - Cardano.ChainProducer.RustHttpBridge.NetworkLayer Cardano.NetworkLayer Cardano.NetworkLayer.HttpBridge Cardano.NetworkLayer.HttpBridge.Api @@ -154,8 +149,6 @@ test-suite unit main-is: Main.hs other-modules: - Cardano.ChainProducer.RustHttpBridge.MockNetworkLayer - Cardano.ChainProducer.RustHttpBridgeSpec Cardano.Wallet.AddressDerivationSpec Cardano.Wallet.AddressDiscoverySpec Cardano.Wallet.Binary.PackfileSpec diff --git a/src/Cardano/ChainProducer.hs b/src/Cardano/ChainProducer.hs deleted file mode 100644 index 66a3f255928..00000000000 --- a/src/Cardano/ChainProducer.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | --- Copyright: © 2018-2019 IOHK --- License: MIT - -module Cardano.ChainProducer - ( MonadChainProducer (..) - , ErrGetNextBlocks (..) - ) where - -import Prelude - -import Cardano.Wallet.Primitive - ( Block, SlotId ) -import Control.Exception - ( Exception ) -import Control.Monad.Except - ( ExceptT ) -import Numeric.Natural - ( Natural ) - -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 - :: Natural -- ^ Number of blocks to retrieve - -> SlotId -- ^ Starting point - -> ExceptT ErrGetNextBlocks m [Block] - --- | The things that can go wrong when retrieving blocks. -newtype ErrGetNextBlocks - = GetNextBlocksError String - deriving (Show, Eq) - -instance Exception ErrGetNextBlocks diff --git a/src/Cardano/ChainProducer/RustHttpBridge.hs b/src/Cardano/ChainProducer/RustHttpBridge.hs deleted file mode 100644 index 4a183747812..00000000000 --- a/src/Cardano/ChainProducer/RustHttpBridge.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Copyright: © 2018-2019 IOHK --- License: MIT - -module Cardano.ChainProducer.RustHttpBridge - ( RustBackend - , runRustBackend - ) where - -import Prelude - -import Cardano.ChainProducer - ( ErrGetNextBlocks (..), MonadChainProducer (..) ) -import Cardano.ChainProducer.RustHttpBridge.NetworkLayer - ( NetworkLayer (..), NetworkLayerError ) -import Cardano.Wallet.Primitive - ( Block (..) - , BlockHeader (..) - , Hash (..) - , SlotId (..) - , slotIncr - , slotsPerEpoch - ) -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 Data.Word - ( Word64 ) -import Numeric.Natural - ( Natural ) - -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 - --- 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 - :: Natural -- ^ Number of blocks to retrieve - -> SlotId -- ^ Starting point - -> ExceptT ErrGetNextBlocks RustBackend [Block] -rbNextBlocks numBlocks start = do - net <- lift getNetwork - (tipHash, tip) <- fmap slotId <$> runNetworkLayer (getNetworkTip net) - epochBlocks <- blocksFromPacks net tip - lastBlocks <- unstableBlocks net tipHash tip epochBlocks - pure (epochBlocks ++ lastBlocks) - where - end = slotIncr 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 . succ . slotId . 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 - -> [Word64] - -> 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] - -runNetworkLayer - :: ExceptT NetworkLayerError IO a - -> ExceptT ErrGetNextBlocks RustBackend a -runNetworkLayer = - mapExceptT (fmap handle . liftIO) - where - handle = first (GetNextBlocksError . show) - --- * 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 - --- | 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 - :: Natural - -- ^ Number of slots - -> SlotId - -- ^ Start point - -> SlotId - -- ^ Latest block available - -> [Word64] -epochRange - numBlocks - (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) . slotId . header - --- | Predicate returns true iff the block is after then given slot -blockIsAfter :: SlotId -> Block -> Bool -blockIsAfter s = (> s) . slotId . header - --- | Predicate returns true iff the block is before the given slot. -blockIsBefore :: SlotId -> Block -> Bool -blockIsBefore s = (< s) . slotId . 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 deleted file mode 100644 index dd44b369c87..00000000000 --- a/src/Cardano/ChainProducer/RustHttpBridge/Api.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} - --- | --- Copyright: © 2018-2019 IOHK --- License: MIT --- --- An API specification for the Cardano HTTP Bridge. -module Cardano.ChainProducer.RustHttpBridge.Api - ( Api - , api - , Block (..) - , BlockHeader (..) - , EpochIndex (..) - , NetworkName (..) - ) where - -import Cardano.Wallet.Binary - ( decodeBlock, decodeBlockHeader ) -import Crypto.Hash.Algorithms - ( Blake2b_256 ) -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 - -api :: Proxy Api -api = Proxy - -type Api - = GetBlockByHash - :<|> GetEpochById - :<|> GetTipBlockHeader - --- | Retrieve a block identified by the unique hash of its header. -type GetBlockByHash - = Capture "networkName" NetworkName - :> "block" - :> Capture "blockHeaderHash" (Hash Blake2b_256 BlockHeader) - :> Get '[CBOR] Block - --- | Retrieve all the blocks for the epoch identified by the given integer ID. -type GetEpochById - = Capture "networkName" NetworkName - :> "epoch" - :> Capture "epochId" EpochIndex - :> Get '[Packed CBOR] [Block] - --- | Retrieve the header of the latest known block. -type GetTipBlockHeader - = Capture "networkName" NetworkName - :> "tip" - :> Get '[ComputeHash Blake2b_256 CBOR] (WithHash Blake2b_256 BlockHeader) - --- | Represents a block. -newtype Block = Block - { getBlock :: Primitive.Block - } deriving Eq - -instance FromCBOR Block where - fromCBOR = Block <$> decodeBlock - --- | Represents a block header. -newtype BlockHeader = BlockHeader - { getBlockHeader :: Primitive.BlockHeader - } deriving Eq - -instance FromCBOR BlockHeader where - fromCBOR = BlockHeader <$> decodeBlockHeader - --- | Represents a unique epoch. -newtype EpochIndex = EpochIndex - { getEpochIndex :: Word64 - } deriving (Eq, Show) - -instance ToHttpApiData (EpochIndex) where - toUrlPiece = toUrlPiece . getEpochIndex - --- | Represents the name of a Cardano network. -newtype NetworkName = NetworkName - { getNetworkName :: Text - } deriving (Eq, Show) - -instance ToHttpApiData NetworkName where - toUrlPiece = getNetworkName diff --git a/src/Cardano/ChainProducer/RustHttpBridge/Client.hs b/src/Cardano/ChainProducer/RustHttpBridge/Client.hs deleted file mode 100644 index bea30bf6f76..00000000000 --- a/src/Cardano/ChainProducer/RustHttpBridge/Client.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} - --- | --- Copyright: © 2018-2019 IOHK --- License: MIT --- --- An API client for the Cardano HTTP Bridge. -module Cardano.ChainProducer.RustHttpBridge.Client - ( mkNetworkLayer - ) where - -import Prelude - -import Cardano.ChainProducer.RustHttpBridge.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 Network.HTTP.Client - ( Manager ) -import Servant.API - ( (:<|>) (..) ) -import Servant.Client - ( BaseUrl, ClientM, client, mkClientEnv, runClientM ) -import Servant.Extra.ContentTypes - ( 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 -> EpochIndex -> ClientM [Block] - --- | Retrieve the header of the latest known block. -getTipBlockHeader :: NetworkName -> ClientM (WithHash Blake2b_256 BlockHeader) - -getBlockByHash - :<|> getEpochById - :<|> getTipBlockHeader - = client api - --- | Construct a new network layer -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 - -blockHeaderHash - :: WithHash algorithm BlockHeader - -> (Primitive.Hash "BlockHeader", Primitive.BlockHeader) -blockHeaderHash (WithHash h (Api.BlockHeader bh)) = - (Primitive.Hash (convert h), bh) - -hashToApi :: HashAlgorithm a => Primitive.Hash h -> Maybe (Hash a 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 deleted file mode 100644 index 406b8e38fcf..00000000000 --- a/src/Cardano/ChainProducer/RustHttpBridge/NetworkLayer.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | --- Copyright: © 2018-2019 IOHK --- License: MIT --- --- Representation of a network layer - -module Cardano.ChainProducer.RustHttpBridge.NetworkLayer - ( NetworkLayer (..) - , NetworkLayerError(..) - ) where - -import Prelude - -import Cardano.Wallet.Primitive - ( Block (..), BlockHeader (..), Hash (..) ) -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 - :: Word64 -> ExceptT NetworkLayerError m [Block] - , getNetworkTip - :: ExceptT NetworkLayerError m (Hash "BlockHeader", BlockHeader) - } - -newtype NetworkLayerError - = NetworkLayerError String - deriving (Show, Eq) - -instance Exception NetworkLayerError diff --git a/test/unit/Cardano/ChainProducer/RustHttpBridge/MockNetworkLayer.hs b/test/unit/Cardano/ChainProducer/RustHttpBridge/MockNetworkLayer.hs deleted file mode 100644 index d437b4ef0f9..00000000000 --- a/test/unit/Cardano/ChainProducer/RustHttpBridge/MockNetworkLayer.hs +++ /dev/null @@ -1,76 +0,0 @@ -module Cardano.ChainProducer.RustHttpBridge.MockNetworkLayer - ( mockNetworkLayer - ) where - -import Prelude - -import Cardano.ChainProducer.RustHttpBridge.NetworkLayer - ( NetworkLayer (..), NetworkLayerError (..) ) -import Cardano.Wallet.Primitive - ( Block (..), BlockHeader (..), Hash (..), SlotId (..), slotsPerEpoch ) -import Control.Monad.Catch - ( MonadThrow (..) ) -import Control.Monad.Except - ( throwError ) -import Data.Word - ( Word64 ) - -import qualified Data.ByteString.Char8 as B8 - - --- | Embed an epoch index and slot number into a hash. -mockHash :: SlotId -> Hash a -mockHash (SlotId ep 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 (read ep) (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 slot prevHash - where - slot = unMockHash h - prevHash = - if slot == SlotId 0 0 then - Hash "genesis" - else - mockHash (pred slot) - --- | Generate an entire epoch's worth of mock blocks. There are no transactions --- generated. -mockEpoch :: Word64 -> [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 - => Word64 -- ^ 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 deleted file mode 100644 index bf3b7af1be8..00000000000 --- a/test/unit/Cardano/ChainProducer/RustHttpBridgeSpec.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Cardano.ChainProducer.RustHttpBridgeSpec (spec) where - -import Prelude - -import Cardano.ChainProducer - ( nextBlocks ) -import Cardano.ChainProducer.RustHttpBridge - ( RustBackend, runRustBackend ) -import Cardano.ChainProducer.RustHttpBridge.MockNetworkLayer - ( mockNetworkLayer ) -import Cardano.ChainProducer.RustHttpBridge.NetworkLayer - ( NetworkLayer ) -import Cardano.Wallet.Primitive - ( BlockHeader (..), SlotId (..), header ) -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 ) - -spec :: Spec -spec = do - describe "Getting next blocks with a mock backend" $ do - beforeAll (pure $ mockNetworkLayer 105 (SlotId 106 1492)) $ 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 (slotId . 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 . slotId . 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 From 20462582f24f59212a0cab4ffe8bb14ab4bb732d Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 13 Mar 2019 18:43:52 +0100 Subject: [PATCH 3/3] move slotting comparison from HttpBridge to Primitive --- src/Cardano/NetworkLayer/HttpBridge.hs | 41 +++----------------------- src/Cardano/Wallet/Primitive.hs | 38 ++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 37 deletions(-) diff --git a/src/Cardano/NetworkLayer/HttpBridge.hs b/src/Cardano/NetworkLayer/HttpBridge.hs index baafe0e1ae9..b1c20ff8c15 100644 --- a/src/Cardano/NetworkLayer/HttpBridge.hs +++ b/src/Cardano/NetworkLayer/HttpBridge.hs @@ -25,8 +25,11 @@ import Cardano.Wallet.Primitive , Hash (..) , Hash (..) , SlotId (..) + , blockIsAfter + , blockIsBefore + , blockIsBetween + , epochRange , slotIncr - , slotsPerEpoch ) import Control.Exception ( Exception ) @@ -180,42 +183,6 @@ mapUntilError action (x:xs) = ExceptT $ runExceptT (action x) >>= \case mapUntilError _ [] = pure [] --- * Slotting calculation utilities (TODO: Move in the wallet primitives) - --- | 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 - :: Natural - -- ^ Number of slots - -> SlotId - -- ^ Start point - -> SlotId - -- ^ Latest block available - -> [Word64] -epochRange numBlocks (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) . slotId . header - --- | Predicate returns true iff the block is after then given slot -blockIsAfter :: SlotId -> Block -> Bool -blockIsAfter s = (> s) . slotId . header - --- | Predicate returns true iff the block is before the given slot. -blockIsBefore :: SlotId -> Block -> Bool -blockIsBefore s = (< s) . slotId . 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 - - {------------------------------------------------------------------------------- HTTP-Bridge Client -------------------------------------------------------------------------------} diff --git a/src/Cardano/Wallet/Primitive.hs b/src/Cardano/Wallet/Primitive.hs index 3ff97af1cf9..03b67b67013 100644 --- a/src/Cardano/Wallet/Primitive.hs +++ b/src/Cardano/Wallet/Primitive.hs @@ -55,6 +55,10 @@ module Cardano.Wallet.Primitive , slotsPerEpoch , slotDiff , slotIncr + , epochRange + , blockIsAfter + , blockIsBefore + , blockIsBetween -- * Polymorphic , Hash (..) @@ -119,6 +123,7 @@ data BlockHeader = BlockHeader instance NFData BlockHeader + -- * Tx data Tx = Tx @@ -333,6 +338,39 @@ isValidSlotId :: SlotId -> Bool isValidSlotId (SlotId e s) = e >= 0 && s >= 0 && s < fromIntegral slotsPerEpoch +-- | 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 + :: Natural + -- ^ Number of slots + -> SlotId + -- ^ Start point + -> SlotId + -- ^ Latest block available + -> [Word64] +epochRange numBlocks (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) . slotId . header + +-- | Predicate returns true iff the block is after then given slot +blockIsAfter :: SlotId -> Block -> Bool +blockIsAfter s = (> s) . slotId . header + +-- | Predicate returns true iff the block is before the given slot. +blockIsBefore :: SlotId -> Block -> Bool +blockIsBefore s = (< s) . slotId . 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 + -- * Polymorphic