Skip to content
Permalink
Browse files

Merge pull request #400 from input-output-hk/KtorZ/jormungandr-networ…

…k-tip-tests

Preliminary integration tests between Jormungandr <-> Network Layer (`networkTip`)
  • Loading branch information...
KtorZ committed Jun 12, 2019
2 parents 8820524 + 37d95bb commit 7548ec5f40871b62489019cc0f817965546f44d6
@@ -33,8 +33,6 @@ import Data.Text
import GHC.Generics
( Generic )

import qualified Data.Text.IO as TIO

data NetworkLayer t m = NetworkLayer
{ nextBlocks :: SlotId -> ExceptT ErrNetworkUnreachable m [Block]
-- ^ Gets some blocks from the node. It will not necessarily return all
@@ -63,8 +61,6 @@ instance Exception ErrNetworkUnreachable
data ErrNetworkTip
= ErrNetworkTipNetworkUnreachable ErrNetworkUnreachable
| ErrNetworkTipNotFound
| ErrNetworkTipBlockNotFound (Hash "BlockHeader")
-- ^ The tip-block wasn't found. This would be surprising.
deriving (Generic, Show, Eq)

instance Exception ErrNetworkTip
@@ -90,18 +86,18 @@ waitForConnection nw policy = do
Right _ -> return ()
Left e -> throwIO e
where

shouldRetry _ = \case
Right _ -> do
Right _ ->
return False
Left (ErrNetworkTipNetworkUnreachable _) -> do
TIO.putStrLn "[INFO] waiting for connection to the node..."
return True
Left _ -> return True
Left ErrNetworkTipNotFound ->
return True
Left (ErrNetworkTipNetworkUnreachable _) ->
return True

-- | A default 'RetryPolicy' with a constant delay, but no longer than 20
-- seconds.
defaultRetryPolicy :: Monad m => RetryPolicyM m
defaultRetryPolicy =
limitRetriesByCumulativeDelay (20 * second)
(constantDelay (1 * second))
limitRetriesByCumulativeDelay (20 * second) (constantDelay (1 * second))
where
second = 1000*1000
@@ -148,8 +148,6 @@ rbNextBlocks bridge start = maybeTip (getNetworkTip bridge) >>= \case

maybeTip = mapExceptT $ fmap $ \case
Left (ErrNetworkTipNetworkUnreachable e) -> Left e
Left (ErrNetworkTipBlockNotFound _) -> Right Nothing
-- HttpBridge never throws ErrNetworkTipBlockNotFound.
Left ErrNetworkTipNotFound -> Right Nothing
Right tip -> Right (Just tip)

@@ -198,7 +198,6 @@ spec = do
where
unwrap (ErrNetworkTipNetworkUnreachable e) = e
unwrap ErrNetworkTipNotFound = ErrNetworkUnreachable "no tip"
unwrap (ErrNetworkTipBlockNotFound _) = ErrNetworkUnreachable "no tip"
newNetworkLayer =
HttpBridge.newNetworkLayer @'Testnet port
closeBridge (handle, _) = do
@@ -110,8 +110,13 @@ test-suite integration
build-depends:
async
, base
, cardano-wallet-core
, cardano-wallet-jormungandr
, cardano-wallet-launcher
, directory
, hspec
, servant
, transformers
type:
exitcode-stdio-1.0
hs-source-dirs:
@@ -120,3 +125,4 @@ test-suite integration
Main.hs
other-modules:
Cardano.LauncherSpec
Cardano.Wallet.Jormungandr.NetworkSpec
@@ -60,8 +60,7 @@ type Api = GetTipId :<|> GetBlock :<|> GetBlockDescendantIds

-- | Retrieve a block by its id.
type GetBlock
= "api"
:> "v0"
= "v0"
:> "block"
:> Capture "blockHeaderHash" BlockId
:> Get '[JormungandrBinary] Block
@@ -77,8 +76,7 @@ type GetBlock
-- > \ \ \
-- > parent +--- descendants ---+
type GetBlockDescendantIds
= "api"
:> "v0"
= "v0"
:> "block"
:> Capture "blockId" BlockId
:> "next_id"
@@ -87,14 +85,12 @@ type GetBlockDescendantIds

-- | Retrieve the header of the latest known block.
type GetTipId
= "api"
:> "v0"
= "v0"
:> "tip"
:> Get '[Hex] BlockId

type PostSignedTx
= "api"
:> "v0"
= "v0"
:> "transaction"
:> ReqBody '[JormungandrBinary] SignedTx
:> Post '[NoContent] NoContent
@@ -16,10 +16,10 @@
-- node. This is done by providing a @NetworkLayer@ with some logic building on
-- top of an underlying @JormungandrLayer@ HTTP client.
module Cardano.Wallet.Jormungandr.Network
( JormungandrLayer (..)
, mkJormungandrLayer
( newNetworkLayer

, mkNetworkLayer
-- * Exception
, ErrUnexpectedNetworkFailure (..)

-- * Re-export
, BaseUrl (..)
@@ -32,6 +32,8 @@ import Prelude

import Cardano.Wallet.Jormungandr.Api
( BlockId (..), GetBlock, GetBlockDescendantIds, GetTipId, api )
import Cardano.Wallet.Jormungandr.Compatibility
( Jormungandr )
import Cardano.Wallet.Network
( ErrNetworkTip (..), ErrNetworkUnreachable (..), NetworkLayer (..) )
import Cardano.Wallet.Primitive.Types
@@ -66,15 +68,25 @@ import Servant.Client.Core
import Servant.Links
( Link, safeLink )

-- | Creates a new 'NetworkLayer' connecting to an underlying 'Jormungandr'
-- backend target.
newNetworkLayer
:: forall n. ()
=> BaseUrl
-> IO (NetworkLayer (Jormungandr n) IO)
newNetworkLayer url = do
mgr <- newManager defaultManagerSettings
return $ mkNetworkLayer $ mkJormungandrLayer mgr url

-- | Wrap a Jormungandr client into a 'NetworkLayer' common interface.
mkNetworkLayer :: Monad m => JormungandrLayer m -> NetworkLayer t m
mkNetworkLayer j = NetworkLayer
{ networkTip = do
t@(BlockId hash) <- (getTipId j)
`mappingError` ErrNetworkTipNetworkUnreachable
b <- (getBlock j t)
`mappingError` \case
ErrGetBlockNotFound (BlockId h) ->
ErrNetworkTipBlockNotFound h
t@(BlockId hash) <- (getTipId j) `mappingError`
ErrNetworkTipNetworkUnreachable
b <- (getBlock j t) `mappingError` \case
ErrGetBlockNotFound (BlockId _) ->
ErrNetworkTipNotFound
ErrGetBlockNetworkUnreachable e ->
ErrNetworkTipNetworkUnreachable e
return (hash, header b)
@@ -124,13 +136,15 @@ mkJormungandrLayer mgr baseUrl = JormungandrLayer
{ getTipId = ExceptT $ do
let ctx = safeLink api (Proxy @GetTipId)
run cGetTipId >>= defaultHandler ctx

, getBlock = \blockId -> ExceptT $ do
run (cGetBlock blockId) >>= \case
Left (FailureResponse e) | responseStatusCode e == status404 ->
return . Left $ ErrGetBlockNotFound blockId
x -> do
let ctx = safeLink api (Proxy @GetBlock) blockId
left ErrGetBlockNetworkUnreachable <$> defaultHandler ctx x

, getDescendantIds = \parentId count -> ExceptT $ do
run (cGetBlockDescendantIds parentId (Just count)) >>= \case
Left (FailureResponse e) | responseStatusCode e == status404 ->
@@ -142,7 +156,6 @@ mkJormungandrLayer mgr baseUrl = JormungandrLayer
parentId
(Just count)
left ErrGetDescendantsNetworkUnreachable <$> defaultHandler ctx x

}
where
run :: ClientM a -> IO (Either ServantError a)
@@ -1,4 +1,4 @@
storage: "/tmp/cardano/storage"
storage: "/tmp/cardano-wallet-jormungandr/storage"

rest:
listen: "127.0.0.1:8081"
@@ -12,12 +12,15 @@ import Control.Concurrent.Async
( async, cancel, race, wait )
import Control.Monad
( void )
import System.Directory
( removePathForcibly )
import Test.Hspec
( Spec, describe, expectationFailure, it )

spec :: Spec
spec = describe "cardano-wallet-launcher" $ do
it "Can start launcher against testnet" $ do
removePathForcibly "/tmp/cardano-wallet-jormungandr"
let jormungandrLauncher = Command
"jormungandr"
[ "--genesis-block", dir ++ "/block-0.bin"
@@ -35,6 +38,5 @@ spec = describe "cardano-wallet-launcher" $ do
expectationFailure
"jormungandr isn't supposed to terminate. \
\Something went wrong."

where
dir = "test/data/jormungandr"
@@ -0,0 +1,122 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Wallet.Jormungandr.NetworkSpec
( spec
) where

import Prelude

import Cardano.Launcher
( Command (..), StdStream (..), launch )
import Cardano.Wallet.Jormungandr.Api
( GetTipId, api )
import Cardano.Wallet.Jormungandr.Compatibility
( Jormungandr, Network (..) )
import Cardano.Wallet.Jormungandr.Network
( BaseUrl (..), ErrUnexpectedNetworkFailure (..), Scheme (..) )
import Cardano.Wallet.Network
( ErrNetworkTip (..)
, NetworkLayer (..)
, defaultRetryPolicy
, waitForConnection
)
import Cardano.Wallet.Primitive.Types
( BlockHeader (..), SlotId (..) )
import Control.Concurrent
( threadDelay )
import Control.Concurrent.Async
( Async, async, cancel )
import Control.Exception
( SomeException, bracket, catch )
import Control.Monad
( void )
import Control.Monad.Trans.Except
( runExceptT )
import Data.Either
( isRight )
import Data.Functor
( ($>) )
import Data.Proxy
( Proxy (..) )
import Servant.Links
( safeLink )
import System.Directory
( removePathForcibly )
import Test.Hspec
( Spec
, afterAll
, beforeAll
, describe
, it
, shouldReturn
, shouldSatisfy
, shouldThrow
)

import qualified Cardano.Wallet.Jormungandr.Network as Jormungandr

spec :: Spec
spec = do
let startNode' = startNode url (`waitForConnection` defaultRetryPolicy)
describe "Happy Paths" $ beforeAll startNode' $ afterAll killNode $ do
it "get network tip" $ \(_, nw) -> do
resp <- runExceptT $ networkTip nw
resp `shouldSatisfy` isRight
let (Right slot) = slotId . snd <$> resp
slot `shouldSatisfy` (>= SlotId 0 0)

describe "Error paths" $ do
it "networkTip: ErrNetworkUnreachable" $ do
nw <- Jormungandr.newNetworkLayer url
let msg x =
"Expected a ErrNetworkUnreachable' failure but got "
<> show x
let action = do
res <- runExceptT $ networkTip nw
res `shouldSatisfy` \case
Left (ErrNetworkTipNetworkUnreachable _) -> True
_ -> error (msg res)
action `shouldReturn` ()

it "networkTip: throws on invalid url" $ do
let wrongUrl = BaseUrl Http "localhost" 8081 "/not-valid-prefix"
let wait nw = waitForConnection nw defaultRetryPolicy
`catch` (\(_ :: SomeException) -> return ())
let test (_, nw) = do
let io = void $ runExceptT $ networkTip nw
shouldThrow io $ \(ErrUnexpectedNetworkFailure link _) ->
show link == show (safeLink api (Proxy @GetTipId))
bracket (startNode wrongUrl wait) killNode test
where
url :: BaseUrl
url = BaseUrl Http "localhost" 8081 "/api"

second :: Int
second = 1000000

startNode
:: BaseUrl
-> (forall n. NetworkLayer n IO -> IO ())
-> IO (Async (), NetworkLayer (Jormungandr 'Testnet) IO)
startNode baseUrl wait = do
removePathForcibly "/tmp/cardano-wallet-jormungandr"
let dir = "test/data/jormungandr"
handle <- async $ void $ launch
[ Command "jormungandr"
[ "--genesis-block", dir ++ "/block-0.bin"
, "--config", dir ++ "/config.yaml"
, "--secret", dir ++ "/secret.yaml"
] (return ())
Inherit
]
nw <- Jormungandr.newNetworkLayer baseUrl
wait nw $> (handle, nw)

killNode :: (Async (), a) -> IO ()
killNode (h, _) = do
cancel h
threadDelay (1 * second)
@@ -6,7 +6,9 @@ import Test.Hspec
( describe, hspec )

import qualified Cardano.LauncherSpec as Launcher
import qualified Cardano.Wallet.Jormungandr.NetworkSpec as Network

main :: IO ()
main = hspec $ do
describe "Cardano.LauncherSpec" Launcher.spec
describe "Cardano.Wallet.NetworkSpec" Network.spec

0 comments on commit 7548ec5

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