Skip to content

Commit

Permalink
Simplify NetworkLayer
Browse files Browse the repository at this point in the history
  • Loading branch information
rvl committed Mar 14, 2019
1 parent 6e54b08 commit 2fbbd44
Show file tree
Hide file tree
Showing 4 changed files with 113 additions and 104 deletions.
1 change: 1 addition & 0 deletions cardano-wallet.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -52,6 +52,7 @@ library
, mtl
, servant
, servant-client
, servant-client-core
, text
, time-units
, transformers
Expand Down
4 changes: 3 additions & 1 deletion src/Cardano/NetworkLayer.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,8 @@
{-# LANGUAGE DataKinds #-}

module Cardano.NetworkLayer where
module Cardano.NetworkLayer
( NetworkLayer (..)
) where

import Cardano.Wallet.Primitive
( Block, BlockHeader (..), Hash (..), SlotId )
Expand Down
153 changes: 84 additions & 69 deletions src/Cardano/NetworkLayer/HttpBridge.hs
Original file line number Diff line number Diff line change
@@ -1,12 +1,16 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.NetworkLayer.HttpBridge where
module Cardano.NetworkLayer.HttpBridge
( HttpBridge(..)
, HttpBridgeError(..)
, mkNetworkLayer
, newNetworkLayer
) where

-- |
-- Copyright: © 2018-2019 IOHK
Expand All @@ -17,8 +21,10 @@ module Cardano.NetworkLayer.HttpBridge where

import Prelude

import Cardano.NetworkLayer
( NetworkLayer (..) )
import Cardano.NetworkLayer.HttpBridge.Api
( ApiT (..), EpochIndex (..), NetworkName, api )
( ApiT (..), EpochIndex (..), NetworkName (..), api )
import Cardano.Wallet.Primitive
( Block (..)
, BlockHeader (..)
Expand All @@ -32,13 +38,9 @@ import Cardano.Wallet.Primitive
, slotIncr
)
import Control.Exception
( 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 )
( ExceptT (..), runExceptT, throwError )
import Crypto.Hash
( HashAlgorithm, digestFromByteString )
import Crypto.Hash.Algorithms
Expand All @@ -49,57 +51,39 @@ import Data.ByteArray
( convert )
import Data.Maybe
( fromMaybe )
import Data.Text
( Text )
import Data.Word
( Word64 )
import Network.HTTP.Client
( Manager )
( Manager, defaultManagerSettings, newManager )
import Numeric.Natural
( Natural )
import Servant.API
( (:<|>) (..) )
import Servant.Client
( BaseUrl, ClientM, client, mkClientEnv, runClientM )
( BaseUrl (..), ClientM, Scheme (Http), client, mkClientEnv, runClientM )
import Servant.Client.Core
( ServantError (..) )
import Servant.Extra.ContentTypes
( WithHash (..) )

import qualified Data.Text as T
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)
rbNextBlocks
:: Monad m
=> HttpBridge m e -- ^ http-bridge API
-> Natural -- ^ Number of blocks to retrieve
-> SlotId -- ^ Starting point
-> ExceptT e m [Block]
rbNextBlocks net numBlocks start = do
(tipHash, tip) <- fmap slotId <$> getNetworkTip net
epochBlocks <- blocksFromPacks net tip
lastBlocks <- unstableBlocks net tipHash tip epochBlocks
pure (epochBlocks ++ lastBlocks)
Expand All @@ -109,7 +93,7 @@ nextBlocks numBlocks start = do
-- Grab blocks from epoch pack files
blocksFromPacks network tip = do
let epochs = epochRange numBlocks start tip
epochBlocks <- runHttpBridge (getEpochs network epochs)
epochBlocks <- getEpochs network epochs
pure $ filter (blockIsBetween start end) (concat epochBlocks)

-- The next slot after the last block.
Expand All @@ -122,26 +106,26 @@ nextBlocks numBlocks start = do
let start' = fromMaybe start (slotAfter epochBlocks)

lastBlocks <- if end > start' && start' <= tip
then runHttpBridge $ fetchBlocksFromTip network start' tipHash
then fetchBlocksFromTip network start' tipHash
else pure []

pure $ filter (blockIsBefore end) lastBlocks

-- | Fetch epoch blocks until one fails.
getEpochs
:: Monad m
=> HttpBridge m
=> HttpBridge m e
-> [Word64]
-> ExceptT HttpBridgeError m [[Block]]
-> ExceptT e m [[Block]]
getEpochs network = mapUntilError (getEpoch network)

-- Fetch blocks which are not in epoch pack files.
fetchBlocksFromTip
:: Monad m
=> HttpBridge m
=> HttpBridge m e
-> SlotId
-> Hash "BlockHeader"
-> ExceptT HttpBridgeError m [Block]
-> ExceptT e m [Block]
fetchBlocksFromTip network start tipHash =
reverse <$> workBackwards tipHash
where
Expand All @@ -153,14 +137,6 @@ fetchBlocksFromTip network start tipHash =
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

Expand Down Expand Up @@ -188,21 +164,15 @@ mapUntilError _ [] = pure []
-------------------------------------------------------------------------------}

-- | Endpoints of the cardano-http-bridge API.
data HttpBridge m = HttpBridge
data HttpBridge m e = HttpBridge
{ getBlock
:: Hash "BlockHeader" -> ExceptT HttpBridgeError m Block
:: Hash "BlockHeader" -> ExceptT e m Block
, getEpoch
:: Word64 -> ExceptT HttpBridgeError m [Block]
:: Word64 -> ExceptT e m [Block]
, getNetworkTip
:: ExceptT HttpBridgeError m (Hash "BlockHeader", BlockHeader)
:: ExceptT e 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)

Expand All @@ -218,7 +188,7 @@ getBlockByHash
= client api

-- | Construct a new network layer
mkHttpBridge :: Manager -> BaseUrl -> NetworkName -> HttpBridge IO
mkHttpBridge :: Manager -> BaseUrl -> NetworkName -> HttpBridge IO HttpBridgeError
mkHttpBridge mgr baseUrl network = HttpBridge
{ getBlock = \hash -> do
hash' <- hashToApi' hash
Expand All @@ -231,7 +201,34 @@ mkHttpBridge mgr baseUrl network = HttpBridge
run :: ClientM a -> ExceptT HttpBridgeError IO a
run query = ExceptT $ (first convertError) <$> runClientM query env
env = mkClientEnv mgr baseUrl
convertError = HttpBridgeError . show

convertError :: ServantError -> HttpBridgeError
convertError e@(FailureResponse _) =
NodeUnavailable (displayException e)
convertError (ConnectionError e) =
NodeUnavailable ("Connection error: " <> T.unpack e)
convertError e@(DecodeFailure _ _) =
BadResponseFromNode (show e)
convertError (UnsupportedContentType _ _) =
BadResponseFromNode "UnsupportedContentType"
convertError (InvalidContentTypeHeader _) =
BadResponseFromNode "InvalidContentTypeHeader"

-- | The things that can go wrong when retrieving blocks.
data HttpBridgeError
= NodeUnavailable String
-- ^ Could not connect to or read from the node API.
| BadResponseFromNode String
-- ^ The node returned an unexpected response.
deriving (Show, Eq)

instance Exception HttpBridgeError where
displayException (NodeUnavailable e) =
"Internal error: cardano-http-bridge returned an error code "
++ " or could not be connected to: " ++ e
displayException (BadResponseFromNode e) =
"Internal error: cardano-http-bridge returned an "
++ " unexpected response: " ++ e

blockHeaderHash
:: WithHash algorithm (ApiT BlockHeader)
Expand All @@ -250,4 +247,22 @@ hashToApi'
hashToApi' h = case hashToApi h of
Just h' -> pure h'
Nothing -> throwError
$ HttpBridgeError "hashToApi: Digest was of the wrong length"
$ BadResponseFromNode "hashToApi: Digest was of the wrong length"

-- | Creates a cardano-http-bridge API with the given connection settings.
newHttpBridge :: Text -> Int -> IO (HttpBridge IO HttpBridgeError)
newHttpBridge network port = do
mgr <- newManager defaultManagerSettings
let baseUrl = BaseUrl Http "localhost" port ""
pure $ mkHttpBridge mgr baseUrl (NetworkName network)

-- | Creates a cardano-http-bridge 'NetworkLayer' using the given connection settings.
newNetworkLayer :: Text -> Int -> IO (NetworkLayer IO HttpBridgeError HttpBridgeError)
newNetworkLayer network port = mkNetworkLayer <$> newHttpBridge network port

-- | Constructs a network layer with the given cardano-http-bridge API.
mkNetworkLayer :: Monad m => HttpBridge m e -> NetworkLayer m e e
mkNetworkLayer httpBridge = NetworkLayer
{ nextBlocks = rbNextBlocks httpBridge
, networkTip = getNetworkTip httpBridge
}
Loading

0 comments on commit 2fbbd44

Please sign in to comment.