Merge #1736 #1738 #1747

1736: Add unit test to check updates of decentralizationLevel r=rvl a=rvl ### Issue Number #1693 can be moved to "QA" column once this is merged. ### Overview - Enhances the "unit test" to check that protocol parameters can be updated to include decentralization level. - Removes "todo" comment from `NETWORK_PARAMS - Able to fetch network parameters` integration test case. The `decentralisationParam` in the shelley integration test genesis is 1.0 ⇒ 0% decentralised. 1738: Parameterise `StakePools` API over apiPool type r=Anviking a=Anviking # Issue Number ADP-311, #1718 # Overview  - [x] I parameterised `StakePools` API over `apiPool` - [x] I renamed `ApiStakePool` to `ApiJormungandrStakePool`, such that we can later introduce a haskell `ApiStakePool` - [x] I made the default `Api` type use `ApiJormungandrStakePool`. We should later switch to `ApiStakePool`, and update the swagger scheme such that it targets haskell, and not jormungandr. - [x] I moved `StakePoolLayer` to the jormungandr package. # Comments - I am keeping the Pool DB in core, since I think we still want it. But I have not thought about how it would work with shelley. - changelog: this is pure refactoring, but in combination with follow-up PRs this is a new feature.   1747: Delegation fee shelley r=paweljakubas a=paweljakubas # Issue Number  #1709 # Overview  - [x] I have enabled delegation fee in Shelley server - [x] I have ported integration tests from jormungandr - [x] I have adjusted feeMin # Comments   Co-authored-by: Rodney Lorrimar <[email protected]> Co-authored-by: KtorZ <[email protected]> Co-authored-by: Johannes Lund <[email protected]> Co-authored-by: Pawel Jakubas <[email protected]>
cardano-foundation · Jun 12, 2020 · 2787bbd · 2787bbd
4 parents 5417c0a + fb84402 + a42e9ae + 8625769
commit 2787bbd
Show file tree

Hide file tree

Showing 30 changed files with 684 additions and 175 deletions.
diff --git a/lib/byron/src/Cardano/Wallet/Byron/Api/Server.hs b/lib/byron/src/Cardano/Wallet/Byron/Api/Server.hs
@@ -77,7 +77,7 @@ import Cardano.Wallet.Api.Server
     , withLegacyLayer'
     )
 import Cardano.Wallet.Api.Types
-    ( ApiT (..), SomeByronWalletPostData (..) )
+    ( ApiJormungandrStakePool, ApiT (..), SomeByronWalletPostData (..) )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( PaymentAddress (..) )
 import Cardano.Wallet.Primitive.AddressDerivation.Byron
@@ -161,7 +161,7 @@ server byron icarus ntp =
              (\_   -> throwError err501)
         :<|> (\_ _ -> throwError err501)
 
-    stakePools :: Server (StakePools n)
+    stakePools :: Server (StakePools n ApiJormungandrStakePool)
     stakePools =
              throwError err501
         :<|> (\_ _ _ -> throwError err501)

diff --git a/lib/byron/test/unit/Cardano/Wallet/Byron/NetworkSpec.hs b/lib/byron/test/unit/Cardano/Wallet/Byron/NetworkSpec.hs
@@ -49,7 +49,7 @@ import Test.Utils.Trace
 
 spec :: Spec
 spec = describe "getTxParameters" $ do
-    it "Correct values are queried" $ do
+    it "Correct values are queried" $
         withTestNode $ \np sock vData -> withLogging $ \(tr, getLogs) -> do
             -- Initial TxParameters for NetworkLayer are all zero
             let np' = np &

diff --git a/lib/cli/src/Cardano/CLI.hs b/lib/cli/src/Cardano/CLI.hs
@@ -1495,7 +1495,8 @@ cmdVersion = command "version" $ info cmd $ mempty
 -------------------------------------------------------------------------------}
 
 cmdStakePool
-    :: StakePoolClient
+    :: ToJSON apiPool
+    => StakePoolClient apiPool
     -> Mod CommandFields (IO ())
 cmdStakePool mkClient =
     command "stake-pool" $ info (helper <*> cmds) $ mempty
@@ -1510,7 +1511,8 @@ newtype StakePoolListArgs = StakePoolListArgs
     }
 
 cmdStakePoolList
-    :: StakePoolClient
+    :: ToJSON apiPool
+    => StakePoolClient apiPool
     -> Mod CommandFields (IO ())
 cmdStakePoolList mkClient =
     command "list" $ info (helper <*> cmd) $ mempty

diff --git a/lib/cli/test/unit/Cardano/CLISpec.hs b/lib/cli/test/unit/Cardano/CLISpec.hs
@@ -1031,7 +1031,7 @@ parser = cli $ mempty
     <> cmdWallet cmdWalletCreate walletClient
     <> cmdTransaction transactionClient walletClient
     <> cmdAddress addressClient
-    <> cmdStakePool stakePoolClient
+    <> cmdStakePool (stakePoolClient @()) -- Type of pool not important here.
     <> cmdNetwork networkClient
     <> cmdKey
 

diff --git a/lib/core-integration/src/Test/Integration/Framework/DSL.hs b/lib/core-integration/src/Test/Integration/Framework/DSL.hs
@@ -37,6 +37,7 @@ module Test.Integration.Framework.DSL
     , expectWalletUTxO
     , between
     , (.>=)
+    , (.<=)
     , (.>)
     , verify
     , Headers(..)
@@ -575,6 +576,18 @@ a .>= b
             , ")"
             ]
 
+(.<=) :: (Ord a, Show a) => a -> a -> Expectation
+a .<= b
+    | a <= b
+        = return ()
+    | otherwise
+        = fail $ mconcat
+            [ show a
+            , " does not satisfy (<= "
+            , show b
+            , ")"
+            ]
+
 -- Retry the given action a couple of time until it doesn't throw, or until it
 -- has been retried enough.
 --

diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
@@ -31,15 +31,19 @@ import Data.ByteString
     ( ByteString )
 import Data.Generics.Internal.VL.Lens
     ( (^.) )
+import Data.Quantity
+    ( Quantity (..) )
 import Data.Text.Class
     ( toText )
 import Test.Hspec
-    ( SpecWith, it, shouldBe )
+    ( SpecWith, describe, it, shouldBe )
 import Test.Integration.Framework.DSL
     ( Context (..)
     , Headers (..)
     , Payload (..)
+    , TxDescription (..)
     , delegating
+    , delegationFee
     , emptyWallet
     , eventually
     , expectErrorMessage
@@ -48,6 +52,7 @@ import Test.Integration.Framework.DSL
     , expectResponseCode
     , fixturePassphrase
     , fixtureWallet
+    , fixtureWalletWith
     , getSlotParams
     , joinStakePool
     , mkEpochInfo
@@ -57,9 +62,11 @@ import Test.Integration.Framework.DSL
     , verify
     , waitForNextEpoch
     , walletId
+    , (.<=)
     )
 import Test.Integration.Framework.TestData
-    ( errMsg403NotDelegating
+    ( errMsg403DelegationFee
+    , errMsg403NotDelegating
     , errMsg403PoolAlreadyJoined
     , errMsg403WrongPass
     , errMsg404NoSuchPool
@@ -232,8 +239,102 @@ spec = do
             request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
                 [ expectField #delegation (`shouldBe` notDelegating [])
                 ]
+
+    describe "STAKE_POOLS_JOIN_01x - Fee boundary values" $ do
+        it "STAKE_POOLS_JOIN_01x - \
+            \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
+                [ expectResponseCode HTTP.status202
+                , expectField (#status . #getApiT) (`shouldBe` Pending)
+                , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
+                ]
+
+        it "STAKE_POOLS_JOIN_01x - \
+           \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
+                [ expectResponseCode HTTP.status403
+                , expectErrorMessage (errMsg403DelegationFee 1)
+                ]
+
+    describe "STAKE_POOLS_QUIT_01x - Fee boundary values" $ do
+        it "STAKE_POOLS_QUIT_01x - \
+            \I can quit if I have enough to cover fee" $ \ctx -> do
+            let (feeJoin, _) = ctx ^. #_feeEstimator $ DelegDescription 1 1 1
+            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
+                [ 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) [])
+                    ]
+
+            quitStakePool @n ctx (w, passwd) >>= flip verify
+                [ expectResponseCode HTTP.status202
+                ]
+            eventually "Wallet is not delegating and has balance = 0" $ do
+                request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
+                    [ expectField #delegation (`shouldBe` notDelegating [])
+                    -- balance is 0 because the rest was used for fees
+                    , expectField
+                        (#balance . #getApiT . #total) (`shouldBe` Quantity 0)
+                    , expectField
+                        (#balance . #getApiT . #available) (`shouldBe` Quantity 0)
+                    ]
+
+        it "STAKE_POOLS_QUIT_01x - \
+            \I cannot quit if I have not enough fee to cover" $ \ctx -> do
+            let (feeJoin, _) = ctx ^. #_feeEstimator $ DelegDescription 1 1 1
+            let (feeQuit, _) = ctx ^. #_feeEstimator $ DelegDescription 0 0 1
+            let initBalance = [feeJoin+1]
+            w <- fixtureWalletWith @n ctx initBalance
+
+            joinStakePool @n ctx (ApiT poolIdMock) (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) [])
+                    ]
+            quitStakePool @n ctx (w, passwd) >>= flip verify
+                [ expectResponseCode HTTP.status403
+                , expectErrorMessage (errMsg403DelegationFee (feeQuit - 1))
+                ]
+
+    it "STAKE_POOLS_ESTIMATE_FEE_01x - edge-case fee in-between coeff" $ \ctx -> do
+        let (feeMin, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1
+        w <- fixtureWalletWith @n ctx [feeMin + 1, feeMin + 1]
+        let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 2 1 1
+        delegationFee ctx w >>= flip verify
+            [ expectResponseCode HTTP.status200
+            , expectField (#estimatedMin . #getQuantity) (.<= fee)
+            ]
+
+    it "STAKE_POOLS_ESTIMATE_FEE_02 - \
+        \empty wallet cannot estimate fee" $ \ctx -> do
+        w <- emptyWallet ctx
+        let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 0 0 1
+        delegationFee ctx w >>= flip verify
+            [ expectResponseCode HTTP.status403
+            , expectErrorMessage $ errMsg403DelegationFee fee
+            ]
+
   where
     (Right poolID) = fromHex @ByteString "5a7b67c7dcfa8c4c25796bea05bcdfca01590c8c7612cc537c97012bed0dec35"
     poolIdMock = PoolId poolID
     (Right poolID') = fromHex @ByteString "775af3b22eff9ff53a0bdd3ac6f8e1c5013ab68445768c476ccfc1e1c6b629b4"
     poolIdMock' = PoolId poolID'
+    passwd = "Secure Passphrase"
diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal
@@ -110,7 +110,6 @@ library
       Cardano.Byron.Codec.Cbor
       Cardano.DB.Sqlite
       Cardano.DB.Sqlite.Delete
-      Cardano.Pool
       Cardano.Pool.Metadata
       Cardano.Pool.DB
       Cardano.Pool.DB.MVar

diff --git a/lib/core/src/Cardano/Pool.hs b/lib/core/src/Cardano/Pool.hs
diff --git a/lib/core/src/Cardano/Wallet/Api.hs b/lib/core/src/Cardano/Wallet/Api.hs
@@ -106,13 +106,13 @@ import Cardano.Wallet.Api.Types
     , ApiByronWallet
     , ApiCoinSelectionT
     , ApiFee
+    , ApiJormungandrStakePool
     , ApiNetworkClock
     , ApiNetworkInformation
     , ApiNetworkParameters
     , ApiPoolId
     , ApiPostRandomAddressData
     , ApiSelectCoinsDataT
-    , ApiStakePool
     , ApiT
     , ApiTransactionT
     , ApiTxId
@@ -183,13 +183,16 @@ import Servant.API.Verbs
 
 type ApiV2 n = "v2" :> Api n
 
+-- | The full cardano-wallet API.
+--
+-- The API used in cardano-wallet-jormungandr may differ from this one.
 type Api n =
          Wallets
     :<|> Addresses n
     :<|> CoinSelections n
     :<|> Transactions n
     :<|> ShelleyMigrations n
-    :<|> StakePools n
+    :<|> StakePools n ApiJormungandrStakePool -- TODO: Make haskell specific
     :<|> ByronWallets
     :<|> ByronAddresses n
     :<|> ByronCoinSelections n
@@ -358,15 +361,15 @@ type GetShelleyWalletMigrationInfo = "wallets"
   See also: https://input-output-hk.github.io/cardano-wallet/api/edge/#tag/Stake-Pools
 -------------------------------------------------------------------------------}
 
-type StakePools n =
-    ListStakePools
+type StakePools n apiPool =
+    ListStakePools apiPool
     :<|> JoinStakePool n
     :<|> QuitStakePool n
     :<|> DelegationFee
 
 -- | https://input-output-hk.github.io/cardano-wallet/api/edge/#operation/listStakePools
-type ListStakePools = "stake-pools"
-    :> Get '[JSON] [ApiStakePool]
+type ListStakePools apiPool = "stake-pools"
+    :> Get '[JSON] [apiPool]
 
 -- | https://input-output-hk.github.io/cardano-wallet/api/#operation/joinStakePool
 type JoinStakePool n = "stake-pools"

diff --git a/lib/core/src/Cardano/Wallet/Api/Client.hs b/lib/core/src/Cardano/Wallet/Api/Client.hs
@@ -68,7 +68,6 @@ import Cardano.Wallet.Api.Types
     , ApiPoolId
     , ApiPostRandomAddressData
     , ApiSelectCoinsDataT
-    , ApiStakePool
     , ApiT (..)
     , ApiTransactionT
     , ApiTxId (..)
@@ -174,9 +173,9 @@ data AddressClient = AddressClient
         -> ClientM NoContent
     }
 
-data StakePoolClient = StakePoolClient
+data StakePoolClient apiPool = StakePoolClient
     { listPools
-        :: ClientM [ApiStakePool]
+        :: ClientM [apiPool]
     , joinStakePool
         :: ApiPoolId
         -> ApiT WalletId
@@ -326,14 +325,14 @@ byronAddressClient =
 
 -- | Produces an 'StakePoolsClient n' working against the /stake-pools API
 stakePoolClient
-    :: StakePoolClient
+    :: forall apiPool. (Aeson.FromJSON apiPool) => StakePoolClient apiPool
 stakePoolClient =
     let
         _listPools
             :<|> _joinStakePool
             :<|> _quitStakePool
             :<|> _delegationFee
-            = client (Proxy @("v2" :> StakePools Aeson.Value))
+            = client (Proxy @("v2" :> StakePools Aeson.Value apiPool))
     in
         StakePoolClient
             { listPools = _listPools

diff --git a/lib/core/src/Cardano/Wallet/Api/Link.hs b/lib/core/src/Cardano/Wallet/Api/Link.hs
@@ -85,8 +85,6 @@ module Cardano.Wallet.Api.Link
 
 import Prelude
 
-import Cardano.Wallet.Api
-    ( Api )
 import Cardano.Wallet.Api.Types
     ( ApiPoolId (..)
     , ApiT (..)
@@ -383,7 +381,7 @@ deleteTransaction w t = discriminate @style
 listStakePools
     :: (Method, Text)
 listStakePools =
-    endpoint @Api.ListStakePools id
+    endpoint @(Api.ListStakePools ()) id
 
 joinStakePool
     :: forall s w.
@@ -491,15 +489,15 @@ postExternalTransaction =
 --   ( "GET", "v2/wallets/2512a00e9653fe49a44a5886202e24d77eeb998f" )
 endpoint
     :: forall endpoint.
-        ( IsElem  endpoint (Api Net)
-        , HasLink endpoint
+        ( HasLink endpoint
+        , IsElem endpoint endpoint
         , HasVerb endpoint
         )
     => (MkLink endpoint Text -> Text)
     -> (Method, Text)
 endpoint mk =
     ( method (Proxy @endpoint)
-    , "v2/" <> mk (safeLink' toUrlPiece (Proxy @(Api Net)) (Proxy @endpoint))
+    , "v2/" <> mk (safeLink' toUrlPiece (Proxy @endpoint) (Proxy @endpoint))
     )
 
 -- Returns first argument for Shelley style wallet, second argument otherwise.