Skip to content
Permalink
Browse files

change type in NetworkLayer

  • Loading branch information...
Anviking committed Jun 12, 2019
1 parent 6ac10ea commit 2fdacdeba6ade158bd89d2972a22d791716ed808
@@ -35,7 +35,7 @@ import GHC.Generics
( Generic )

data NetworkLayer t m = NetworkLayer
{ nextBlocks :: BlockHeader -> ExceptT ErrNetworkUnreachable m [Block]
{ nextBlocks :: BlockHeader -> ExceptT ErrGetBlock m [Block]
-- ^ Gets some blocks from the node. It will not necessarily return all
-- the blocks that the node has, but will receive a reasonable-sized
-- chunk. It will never return blocks from before the given slot. It
@@ -40,7 +40,8 @@ import Cardano.Wallet.HttpBridge.Compatibility
import Cardano.Wallet.HttpBridge.Environment
( KnownNetwork (..), Network (..) )
import Cardano.Wallet.Network
( ErrNetworkTip (..)
( ErrGetBlock (..)
, ErrNetworkTip (..)
, ErrNetworkUnreachable (..)
, ErrPostTx (..)
, NetworkLayer (..)
@@ -58,7 +59,7 @@ import Control.Monad.Catch
import Control.Monad.Fail
( MonadFail )
import Control.Monad.Trans.Except
( ExceptT (..), mapExceptT )
( ExceptT (..), mapExceptT, withExceptT )
import Crypto.Hash
( HashAlgorithm, digestFromByteString )
import Data.ByteArray
@@ -91,7 +92,8 @@ import qualified Servant.Extra.ContentTypes as Api
-- | Constructs a network layer with the given cardano-http-bridge API.
mkNetworkLayer :: Monad m => HttpBridgeLayer m -> NetworkLayer t m
mkNetworkLayer httpBridge = NetworkLayer
{ nextBlocks = \(BlockHeader sl _) -> rbNextBlocks httpBridge sl
{ nextBlocks = \(BlockHeader sl _) ->
withExceptT ErrGetBlockNetworkUnreachable (rbNextBlocks httpBridge sl)
, networkTip = snd <$> getNetworkTip httpBridge
, postTx = postSignedTx httpBridge
}
@@ -14,7 +14,8 @@ import Cardano.Launcher
import Cardano.Wallet.HttpBridge.Environment
( KnownNetwork (..), Network (..) )
import Cardano.Wallet.Network
( ErrNetworkTip (..)
( ErrGetBlock (..)
, ErrNetworkTip (..)
, ErrNetworkUnreachable (..)
, ErrPostTx (..)
, NetworkLayer (..)
@@ -90,7 +91,7 @@ spec = do
let action = runExceptT $ do
(SlotId ep sl) <- slotId <$> networkTip' bridge
let sl' = if sl > 2 then sl - 2 else 0
blocks <- nextBlocks bridge (mkHeader $ SlotId ep sl')
blocks <- nextBlocks' bridge (mkHeader $ SlotId ep sl')
lift $ blocks `shouldSatisfy` (\bs
-> length bs >= fromIntegral (sl - sl')
&& length bs <= fromIntegral (sl - sl' + 1)
@@ -100,7 +101,7 @@ spec = do
it "produce no blocks if start is after tip" $ \(_, bridge) -> do
let action = runExceptT $ do
SlotId ep sl <- slotId <$> networkTip' bridge
length <$> nextBlocks bridge (mkHeader $ SlotId (ep + 1) sl)
length <$> nextBlocks' bridge (mkHeader $ SlotId (ep + 1) sl)
action `shouldReturn` pure 0

describe "Error paths" $ beforeAll newNetworkLayer $ do
@@ -200,6 +201,12 @@ spec = do
where
unwrap (ErrNetworkTipNetworkUnreachable e) = e
unwrap ErrNetworkTipNotFound = ErrNetworkUnreachable "no tip"

nextBlocks' tip = withExceptT unwrap . nextBlocks tip
where
unwrap (ErrGetBlockNetworkUnreachable e) = e
unwrap (ErrGetBlockNotFound _) = ErrNetworkUnreachable "no block"

newNetworkLayer =
HttpBridge.newNetworkLayer @'Testnet port
closeBridge (handle, _) = do

0 comments on commit 2fdacde

Please sign in to comment.
You can’t perform that action at this time.