Skip to content

Commit

Permalink
Merge #1755 #1765 #1767
Browse files Browse the repository at this point in the history
1755: Bump cardano-node r=Anviking a=Anviking

- Appears to break compatibility with the most recent FF genesis
- Should include what we need to get non myopic member rewards

1765: Add script to show cardano-node and cardano-cli versions r=rvl a=rvl

Run this script if you would like to know which version of `cardano-node` will be in the `nix-shell` (i.e. CI).

This PR IntersectMBO/cardano-node#1283 fixes the CLI version strings.


1767: Better tracing of shelley network local state query r=rvl a=rvl

### Issue Number

ADP-302 / #1750

### Overview

More detail in the logs.


Co-authored-by: Johannes Lund <[email protected]>
Co-authored-by: Rodney Lorrimar <[email protected]>
  • Loading branch information
3 people authored Jun 16, 2020
4 parents 8d9d8aa + 26cc41a + 235a5a9 + e295b32 commit 8cf60f7
Show file tree
Hide file tree
Showing 67 changed files with 868 additions and 244 deletions.
2 changes: 1 addition & 1 deletion README.md
Original file line number Diff line number Diff line change
Expand Up @@ -70,7 +70,7 @@ See **Installation Instructions** for each available [release](https://github.co
>
> | cardano-wallet | jörmungandr (compatible versions) | cardano-node (compatible versions)
> | --- | --- | ---
> | `master` branch | [v0.8.18](https://github.com/input-output-hk/jormungandr/releases/tag/v0.8.18) | [1.13.0](https://github.com/input-output-hk/cardano-node/releases/tag/1.13.0)
> | `master` branch | [v0.8.18](https://github.com/input-output-hk/jormungandr/releases/tag/v0.8.18) | [93ca68b](https://github.com/input-output-hk/cardano-node/tree/93ca68b8004031df297063a3715178b664c61bac)
> | [v2020-05-06](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2020-05-06) | [v0.8.18](https://github.com/input-output-hk/jormungandr/releases/tag/v0.8.18) | [1.11.0](https://github.com/input-output-hk/cardano-node/releases/tag/1.11.0)
> | [v2020-04-28](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2020-04-28) | [v0.8.18](https://github.com/input-output-hk/jormungandr/releases/tag/v0.8.18) | [1.11.0](https://github.com/input-output-hk/cardano-node/releases/tag/1.11.0)
> | [v2020-04-07](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2020-04-07) | [v0.8.15](https://github.com/input-output-hk/jormungandr/releases/tag/v0.8.15) | [1.9.3](https://github.com/input-output-hk/cardano-node/releases/tag/1.9.3)
Expand Down
4 changes: 2 additions & 2 deletions lib/byron/src/Cardano/Wallet/Byron/Network.hs
Original file line number Diff line number Diff line change
Expand Up @@ -318,7 +318,7 @@ mkWalletClient
-> m (NetworkClient m)
mkWalletClient gp chainSyncQ = do
responsesBuffer <- atomically newTQueue
pure $ nodeToClientProtocols (const NodeToClientProtocols
pure $ nodeToClientProtocols (const $ pure $ NodeToClientProtocols
{ localChainSyncProtocol =
let
fromTip' =
Expand Down Expand Up @@ -391,7 +391,7 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onProtocolParamsUpdate = do
onTipUpdate tip
queryLocalState (getTipPoint tip)

pure $ nodeToClientProtocols (const NodeToClientProtocols
pure $ nodeToClientProtocols (const $ pure $ NodeToClientProtocols
{ localChainSyncProtocol =
let
codec = cChainSyncCodec codecs
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -14,27 +14,26 @@ module Test.Integration.Scenario.API.Shelley.StakePools
import Prelude

import Cardano.Wallet.Api.Types
( ApiT (..)
( ApiStakePool
, ApiT (..)
, ApiTransaction
, ApiWallet
, DecodeAddress
, EncodeAddress
, WalletStyle (..)
)
import Cardano.Wallet.Primitive.AddressDerivation
( PaymentAddress, fromHex )
( PaymentAddress )
import Cardano.Wallet.Primitive.AddressDerivation.Shelley
( ShelleyKey )
import Cardano.Wallet.Primitive.Types
( Direction (..), PoolId (..), TxStatus (..) )
import Data.ByteString
( ByteString )
( Direction (..), PoolId (..), TxStatus (..), WalletId )
import Data.Generics.Internal.VL.Lens
( (^.) )
( view, (^.) )
import Data.Quantity
( Quantity (..) )
import Data.Text.Class
( toText )
( fromText, toText )
import Test.Hspec
( SpecWith, describe, it, shouldBe, xit )
import Test.Integration.Framework.DSL
Expand All @@ -49,6 +48,7 @@ import Test.Integration.Framework.DSL
, expectErrorMessage
, expectField
, expectListField
, expectListSize
, expectResponseCode
, fixturePassphrase
, fixtureWallet
Expand All @@ -60,11 +60,13 @@ import Test.Integration.Framework.DSL
, notDelegating
, quitStakePool
, request
, unsafeRequest
, verify
, waitForNextEpoch
, walletId
, (.<=)
, (.>)
, (.>=)
)
import Test.Integration.Framework.TestData
( errMsg403DelegationFee
Expand All @@ -77,6 +79,7 @@ import Test.Integration.Framework.TestData

import qualified Cardano.Wallet.Api.Link as Link
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Network.HTTP.Types.Status as HTTP


Expand Down Expand Up @@ -105,14 +108,18 @@ spec = do

it "STAKE_POOLS_JOIN_01 - Cannot join existant stakepool with wrong password" $ \ctx -> do
w <- fixtureWallet ctx
joinStakePool @n ctx (ApiT poolIdMock) (w, "Wrong Passphrase") >>= flip verify
pool:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
joinStakePool @n ctx pool (w, "Wrong Passphrase") >>= flip verify
[ expectResponseCode HTTP.status403
, expectErrorMessage errMsg403WrongPass
]

it "STAKE_POOLS_JOIN_02 - Cannot join already joined stake pool" $ \ctx -> do
w <- fixtureWallet ctx
joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
pool:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
Expand All @@ -127,14 +134,16 @@ spec = do
, expectListField 0
(#status . #getApiT) (`shouldBe` InLedger)
]
joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status403
, expectErrorMessage (errMsg403PoolAlreadyJoined $ toText poolIdMock)
, expectErrorMessage (errMsg403PoolAlreadyJoined $ toText $ getApiT pool)
]

it "STAKE_POOLS_QUIT_02 - Passphrase must be correct to quit" $ \ctx -> do
w <- fixtureWallet ctx
joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
pool:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
Expand Down Expand Up @@ -170,7 +179,10 @@ spec = do
(currentEpoch, sp) <- getSlotParams ctx
waitForNextEpoch ctx

joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
pool1:pool2:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty

joinStakePool @n ctx pool1 (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
Expand All @@ -189,17 +201,17 @@ spec = do
request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
[ expectField #delegation
(`shouldBe` notDelegating
[ (Just (ApiT poolIdMock), mkEpochInfo (currentEpoch + 3) sp)
[ (Just pool1, mkEpochInfo (currentEpoch + 3) sp)
]
)
]
eventually "Wallet is delegating to p1" $ do
request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
[ expectField #delegation (`shouldBe` delegating (ApiT poolIdMock) [])
[ expectField #delegation (`shouldBe` delegating pool1 [])
]

-- join another stake pool
joinStakePool @n ctx (ApiT poolIdMock') (w, fixturePassphrase) >>= flip verify
joinStakePool @n ctx pool2 (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
Expand All @@ -217,7 +229,7 @@ spec = do

eventually "Wallet is delegating to p2" $ do
request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
[ expectField #delegation (`shouldBe` delegating (ApiT poolIdMock') [])
[ expectField #delegation (`shouldBe` delegating pool2 [])
]

--quiting
Expand All @@ -244,8 +256,10 @@ spec = do

xit "STAKE_POOLS_JOIN_04 - Rewards accumulate and stop" $ \ctx -> do
w <- fixtureWallet ctx
pool:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
-- Join a pool
joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
Expand Down Expand Up @@ -305,7 +319,11 @@ spec = do
\I can join if I have just the right amount" $ \ctx -> do
let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1
w <- fixtureWalletWith @n ctx [fee]
joinStakePool @n ctx (ApiT poolIdMock) (w, passwd)>>= flip verify

pool:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty

joinStakePool @n ctx pool (w, passwd)>>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
Expand All @@ -315,7 +333,9 @@ spec = do
\I cannot join if I have not enough fee to cover" $ \ctx -> do
let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1
w <- fixtureWalletWith @n ctx [fee - 1]
joinStakePool @n ctx (ApiT poolIdMock) (w, passwd) >>= flip verify
pool:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
joinStakePool @n ctx pool (w, passwd) >>= flip verify
[ expectResponseCode HTTP.status403
, expectErrorMessage (errMsg403DelegationFee 1)
]
Expand All @@ -327,16 +347,17 @@ spec = do
let (feeQuit, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1
let initBalance = [feeJoin + feeQuit]
w <- fixtureWalletWith @n ctx initBalance

joinStakePool @n ctx (ApiT poolIdMock) (w, passwd) >>= flip verify
pool:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
joinStakePool @n ctx pool (w, passwd) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
]

eventually "Wallet is delegating to p1" $ do
request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
[ expectField #delegation (`shouldBe` delegating (ApiT poolIdMock) [])
[ expectField #delegation (`shouldBe` delegating pool [])
]

quitStakePool @n ctx (w, passwd) >>= flip verify
Expand All @@ -359,15 +380,18 @@ spec = do
let initBalance = [feeJoin+1]
w <- fixtureWalletWith @n ctx initBalance

joinStakePool @n ctx (ApiT poolIdMock) (w, passwd) >>= flip verify
pool:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty

joinStakePool @n ctx pool (w, passwd) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
]

eventually "Wallet is delegating to p1" $ do
request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
[ expectField #delegation (`shouldBe` delegating (ApiT poolIdMock) [])
[ expectField #delegation (`shouldBe` delegating pool [])
]
quitStakePool @n ctx (w, passwd) >>= flip verify
[ expectResponseCode HTTP.status403
Expand All @@ -392,9 +416,82 @@ spec = do
, expectErrorMessage $ errMsg403DelegationFee fee
]

it "STAKE_POOLS_LIST_01 - List stake pools" $ \ctx -> do
w <- fixtureWallet ctx
eventually "Listing stake pools shows expected information" $ do
r <- request @[ApiStakePool] ctx (Link.listStakePools w) Default Empty
expectResponseCode HTTP.status200 r
verify r
[ expectListSize 3

-- Pending a mock metadata registry
-- , expectListField 0
-- #metadata ((`shouldBe` Just "Genesis Pool") . fmap (view #name . getApiT))
-- , expectListField 1
-- #metadata ((`shouldBe` Just "Genesis Pool") . fmap (view #name . getApiT))
-- , expectListField 2
-- #metadata ((`shouldBe` Just "Genesis Pool") . fmap (view #name . getApiT))

, expectListField 0
#cost (`shouldBe` (Quantity 0))
, expectListField 1
#cost (`shouldBe` (Quantity 0))
, expectListField 2
#cost (`shouldBe` (Quantity 0))

, expectListField 0
#margin (`shouldBe` (Quantity minBound))
, expectListField 1
#margin (`shouldBe` (Quantity minBound))
, expectListField 2
#margin (`shouldBe` (Quantity minBound))

-- Pending stake pools producing blocks in our setup,
-- AND pending keeping track of block producions
-- , expectListField 0
-- (#metrics . #producedBlocks) (.>= Quantity 0)
-- , expectListField 1
-- (#metrics . #producedBlocks) (.>= Quantity 0)
-- , expectListField 2
-- (#metrics . #producedBlocks) (.>= Quantity 0)
--
-- , expectListField 0
-- (#metrics . #nonMyopicMemberRewards) (.>= Quantity 0)
-- , expectListField 1
-- (#metrics . #nonMyopicMemberRewards) (.>= Quantity 0)
-- , expectListField 2
-- (#metrics . #nonMyopicMemberRewards) (.>= Quantity 0)

, expectListField 0
(#metrics . #saturation) (.>= 0)
, expectListField 1
(#metrics . #saturation) (.>= 0)
, expectListField 2
(#metrics . #saturation) (.>= 0)
]

it "STAKE_POOLS_LIST_05 - Fails for unknown wallets" $ \ctx -> do
-- FIXME: Type inference breaks without this line:
_w <- fixtureWallet ctx

r <- request @[ApiStakePool] ctx (Link.listStakePools (ApiT invalidWalletId, ())) Default Empty
expectResponseCode HTTP.status404 r

it "STAKE_POOLS_LIST_06 - NonMyopicMemberRewards are 0 for empty wallets" $ \ctx -> do
w <- emptyWallet ctx
eventually "Listing stake pools shows expected information" $ do
r <- request @[ApiStakePool] ctx (Link.listStakePools w) Default Empty
expectResponseCode HTTP.status200 r
verify r
[ expectListSize 3
, expectListField 0
(#metrics . #nonMyopicMemberRewards) (`shouldBe` Quantity 0)
, expectListField 1
(#metrics . #nonMyopicMemberRewards) (`shouldBe` Quantity 0)
, expectListField 2
(#metrics . #nonMyopicMemberRewards) (`shouldBe` Quantity 0)
]
where
(Right poolID) = fromHex @ByteString "5a7b67c7dcfa8c4c25796bea05bcdfca01590c8c7612cc537c97012bed0dec35"
poolIdMock = PoolId poolID
(Right poolID') = fromHex @ByteString "775af3b22eff9ff53a0bdd3ac6f8e1c5013ab68445768c476ccfc1e1c6b629b4"
poolIdMock' = PoolId poolID'
invalidWalletId :: WalletId
invalidWalletId = either (error . show) id $ fromText $ T.pack $ replicate 40 '0'
passwd = "Secure Passphrase"
1 change: 1 addition & 0 deletions lib/core/src/Cardano/Wallet/Api/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -81,6 +81,7 @@ module Cardano.Wallet.Api.Server
, withLegacyLayer'
, rndStateChange
, assignMigrationAddresses
, withWorkerCtx
) where

import Prelude
Expand Down
15 changes: 8 additions & 7 deletions lib/core/src/Cardano/Wallet/Network.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ module Cardano.Wallet.Network
, follow
, FollowAction (..)
, FollowExit (..)
, GetStakeDistribution

-- * Errors
, ErrNetworkUnavailable (..)
Expand All @@ -43,9 +44,7 @@ import Cardano.BM.Data.Tracer
import Cardano.Wallet.Primitive.Types
( BlockHeader (..)
, ChimericAccount (..)
, EpochNo
, Hash (..)
, PoolId (..)
, ProtocolParameters
, SealedTx
, SlotId
Expand All @@ -71,8 +70,6 @@ import Control.Tracer
( Tracer, traceWith )
import Data.List.NonEmpty
( NonEmpty (..) )
import Data.Map
( Map )
import Data.Quantity
( Quantity (..) )
import Data.Text
Expand Down Expand Up @@ -128,9 +125,7 @@ data NetworkLayer m target block = NetworkLayer
-- ^ Broadcast a transaction to the chain producer

, stakeDistribution
:: EpochNo
-> ExceptT ErrNetworkUnavailable m
(Map PoolId (Quantity "lovelace" Word64))
:: GetStakeDistribution target m

, getAccountBalance
:: ChimericAccount
Expand Down Expand Up @@ -225,6 +220,12 @@ defaultRetryPolicy =
where
second = 1000*1000

{-------------------------------------------------------------------------------
Queries
-------------------------------------------------------------------------------}

type family GetStakeDistribution target (m :: * -> *) :: *

{-------------------------------------------------------------------------------
Chain Sync
-------------------------------------------------------------------------------}
Expand Down
Loading

0 comments on commit 8cf60f7

Please sign in to comment.