Skip to content

Commit

Permalink
Try #2249:
Browse files Browse the repository at this point in the history
  • Loading branch information
@iohk-bors
iohk-bors[bot] authored Oct 17, 2020
2 parents 05e59a0 + 59a75fe commit eb84baf
Show file tree
Hide file tree
Showing 29 changed files with 8,471 additions and 298 deletions.
98 changes: 58 additions & 40 deletions lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ import Prelude

import Cardano.Wallet.Api.Types
( ApiCertificate (JoinPool, QuitPool, RegisterRewardAccount)
, ApiListStakePools (..)
, ApiStakePool
, ApiT (..)
, ApiTransaction
Expand Down Expand Up @@ -46,6 +47,8 @@ import Cardano.Wallet.Unsafe
( unsafeFromHex, unsafeMkPercentage )
import Control.Monad
( forM_ )
import Data.Bifunctor
( second )
import Data.Function
( (&) )
import Data.Generics.Internal.VL.Lens
Expand Down Expand Up @@ -131,8 +134,9 @@ spec :: forall n t.
, PaymentAddress n ShelleyKey
) => SpecWith (Context t)
spec = describe "SHELLEY_STAKE_POOLS" $ do
let listPools ctx stake = request @[ApiStakePool] @IO ctx
(Link.listStakePools stake) Default Empty
let listPools ctx stake = (second . second) (view #pools)
<$> request @(ApiListStakePools ApiStakePool) @IO ctx
(Link.listStakePools stake) Default Empty

it "STAKE_POOLS_JOIN_01 - Cannot join non-existent wallet" $ \ctx -> do
w <- emptyWallet ctx
Expand All @@ -154,8 +158,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
it "STAKE_POOLS_JOIN_01 - \
\Cannot join existent stakepool with wrong password" $ \ctx -> do
w <- fixtureWallet ctx
pool:_ <- map (view #id) . snd <$> unsafeRequest
@[ApiStakePool] ctx (Link.listStakePools arbitraryStake) Empty
pool:_ <- map (view #id) . view #pools . snd <$> unsafeRequest
@(ApiListStakePools ApiStakePool) ctx (Link.listStakePools arbitraryStake) Empty
joinStakePool @n ctx pool (w, "Wrong Passphrase") >>= flip verify
[ expectResponseCode HTTP.status403
, expectErrorMessage errMsg403WrongPass
Expand All @@ -168,8 +172,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
dest <- emptyWallet ctx

-- Join Pool
pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool] ctx
(Link.listStakePools arbitraryStake) Empty
pool:_ <- map (view #id) . view #pools . snd
<$> unsafeRequest @(ApiListStakePools ApiStakePool) ctx
(Link.listStakePools arbitraryStake) Empty
joinStakePool @n ctx pool (src, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
Expand Down Expand Up @@ -345,8 +350,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
it "STAKE_POOLS_JOIN_02 - \
\Cannot join already joined stake pool" $ \ctx -> do
w <- fixtureWallet ctx
pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
ctx (Link.listStakePools arbitraryStake) Empty
pool:_ <- map (view #id) . view #pools . snd
<$> unsafeRequest @(ApiListStakePools ApiStakePool)
ctx (Link.listStakePools arbitraryStake) Empty
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
Expand Down Expand Up @@ -394,8 +400,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do

it "STAKE_POOLS_QUIT_02 - Passphrase must be correct to quit" $ \ctx -> do
w <- fixtureWallet ctx
pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
ctx (Link.listStakePools arbitraryStake) Empty
pool:_ <- map (view #id) . view #pools . snd
<$> unsafeRequest @(ApiListStakePools ApiStakePool)
ctx (Link.listStakePools arbitraryStake) Empty
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
Expand Down Expand Up @@ -433,9 +440,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
(currentEpoch, _) <- getSlotParams ctx
waitForNextEpoch ctx

pool1:pool2:_ <- map (view #id) . snd
<$> unsafeRequest @[ApiStakePool] ctx
(Link.listStakePools arbitraryStake) Empty
pool1:pool2:_ <- map (view #id) . view #pools . snd
<$> unsafeRequest @(ApiListStakePools ApiStakePool)
ctx (Link.listStakePools arbitraryStake) Empty

joinStakePool @n ctx pool1 (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
Expand Down Expand Up @@ -499,8 +506,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do

it "STAKE_POOLS_JOIN_04 - Rewards accumulate" $ \ctx -> do
w <- fixtureWallet ctx
pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
ctx (Link.listStakePools arbitraryStake) Empty
pool:_ <- map (view #id) . view #pools . snd
<$> unsafeRequest @(ApiListStakePools ApiStakePool)
ctx (Link.listStakePools arbitraryStake) Empty
-- Join a pool
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
Expand Down Expand Up @@ -548,8 +556,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do

(_, w) <- unsafeRequest @ApiWallet ctx
(Link.postWallet @'Shelley) payload
pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
ctx (Link.listStakePools arbitraryStake) Empty
pool:_ <- map (view #id) . view #pools . snd
<$> unsafeRequest @(ApiListStakePools ApiStakePool)
ctx (Link.listStakePools arbitraryStake) Empty

eventually "wallet join a pool" $ do
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
Expand Down Expand Up @@ -659,8 +668,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
$ it "Can quit a joined pool" $ \ctx -> do
w <- fixtureWallet ctx

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

joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
Expand Down Expand Up @@ -700,8 +710,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
it "STAKE_POOLS_JOIN_01x - \
\I can join if I have just the right amount" $ \ctx -> do
w <- fixtureWalletWith @n ctx [costOfJoining ctx + depositAmt ctx]
pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
ctx (Link.listStakePools arbitraryStake) Empty
pool:_ <- map (view #id) . view #pools . snd
<$> unsafeRequest @(ApiListStakePools ApiStakePool)
ctx (Link.listStakePools arbitraryStake) Empty
joinStakePool @n ctx pool (w, fixturePassphrase)>>= flip verify
[ expectResponseCode HTTP.status202
, expectField (#status . #getApiT) (`shouldBe` Pending)
Expand All @@ -711,8 +722,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
it "STAKE_POOLS_JOIN_01x - \
\I cannot join if I have not enough fee to cover" $ \ctx -> do
w <- fixtureWalletWith @n ctx [costOfJoining ctx + depositAmt ctx - 1]
pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
ctx (Link.listStakePools arbitraryStake) Empty
pool:_ <- map (view #id) . view #pools . snd
<$> unsafeRequest @(ApiListStakePools ApiStakePool)
ctx (Link.listStakePools arbitraryStake) Empty
joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status403
, expectErrorMessage (errMsg403DelegationFee 1)
Expand All @@ -733,8 +745,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
]
w <- fixtureWalletWith @n ctx initBalance

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

joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
Expand Down Expand Up @@ -769,8 +782,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
let initBalance = [ costOfJoining ctx + depositAmt ctx ]
w <- fixtureWalletWith @n ctx initBalance

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

joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
[ expectResponseCode HTTP.status202
Expand Down Expand Up @@ -843,18 +857,18 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
r <- listPools ctx arbitraryStake
expectResponseCode HTTP.status200 r
let oneMillionAda = 1_000_000_000_000
let pools = either (error . show) Prelude.id $ snd r
let pools' = either (error . show) Prelude.id $ snd r

-- To ignore the ordering of the pools, we use Set.
setOf pools (view #cost)
setOf pools' (view #cost)
`shouldBe` Set.singleton (Quantity 0)

setOf pools (view #margin)
setOf pools' (view #margin)
`shouldBe`
Set.singleton
(Quantity $ unsafeMkPercentage 0.1)

setOf pools (view #pledge)
setOf pools' (view #pledge)
`shouldBe`
Set.fromList
[ Quantity oneMillionAda
Expand All @@ -881,44 +895,48 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
, name = "Genesis Pool A"
, description = Nothing
, homepage = "https://iohk.io"
, delisted = False
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPB")
, name = "Genesis Pool B"
, description = Nothing
, homepage = "https://iohk.io"
, delisted = False
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPC")
, name = "Genesis Pool C"
, description = Just "Lorem Ipsum Dolor Sit Amet."
, homepage = "https://iohk.io"
, delisted = False
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPD")
, name = "Genesis Pool D"
, description = Just "Lorem Ipsum Dolor Sit Amet."
, homepage = "https://iohk.io"
, delisted = False
}
]

verify r
[ expectListSize 3
, expectField Prelude.id $ \pools -> do
, expectField Prelude.id $ \pools' -> do
let metadataActual = Set.fromList $
mapMaybe (fmap getApiT . view #metadata) pools
mapMaybe (fmap getApiT . view #metadata) pools'
metadataActual
`shouldSatisfy` (`Set.isSubsetOf` metadataPossible)
]

it "contains and is sorted by non-myopic-rewards" $ \ctx -> do
eventually "eventually shows non-zero rewards" $ do
Right pools@[pool1,_pool2,pool3] <-
Right pools'@[pool1,_pool2,pool3] <-
snd <$> listPools ctx arbitraryStake
let rewards = view (#metrics . #nonMyopicMemberRewards)
print (rewards <$> pools) -- FIXME temporary
(rewards <$> pools) `shouldBe`
(rewards <$> sortOn (Down . rewards) pools)
print (rewards <$> pools') -- FIXME temporary
(rewards <$> pools') `shouldBe`
(rewards <$> sortOn (Down . rewards) pools')
-- Make sure the rewards are not all equal:
rewards pool1 .> rewards pool3

Expand All @@ -936,18 +954,18 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
rewardsStakeBig .> rewardsStakeSmall

it "STAKE_POOLS_LIST_05 - Fails without query parameter" $ \ctx -> do
r <- request @[ApiStakePool] @IO ctx
r <- request @(ApiListStakePools ApiStakePool) @IO ctx
(Link.listStakePools Nothing) Default Empty
expectResponseCode HTTP.status400 r

it "STAKE_POOLS_LIST_06 - \
\NonMyopicMemberRewards are 0 when stake is 0" $ \ctx -> do
pendingWith "This assumption seems false, for some reasons..."
let stake = Just $ Coin 0
r <- request @[ApiStakePool] @IO ctx (Link.listStakePools stake)
r <- request @(ApiListStakePools ApiStakePool) @IO ctx (Link.listStakePools stake)
Default Empty
expectResponseCode HTTP.status200 r
verify r
verify ((second . second) (view #pools) r)
[ expectListSize 3
, expectListField 0
(#metrics . #nonMyopicMemberRewards) (`shouldBe` Quantity 0)
Expand Down
1 change: 1 addition & 0 deletions lib/core/cardano-wallet-core.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -90,6 +90,7 @@ library
, statistics
, stm
, streaming-commons
, string-interpolate
, string-qq
, template-haskell
, text
Expand Down
16 changes: 16 additions & 0 deletions lib/core/src/Cardano/Pool/DB.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,8 @@ import Data.Map.Strict
( Map )
import Data.Quantity
( Quantity (..) )
import Data.Time.Clock.POSIX
( POSIXTime )
import Data.Word
( Word64 )
import System.Random
Expand Down Expand Up @@ -211,6 +213,11 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
-> stm ()
-- ^ Remove all entries of slot ids newer than the argument

, delistPools
:: [PoolId]
-> stm ()
-- ^ Mark pools as delisted
--
, removePools
:: [PoolId]
-> stm ()
Expand Down Expand Up @@ -249,6 +256,15 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
-> stm ()
-- ^ Modify the settings.

, readLastMetadataGC
:: stm POSIXTime
-- ^ Get the last metadata GC time.

, putLastMetadataGC
:: POSIXTime
-> stm ()
-- ^ Set the last metadata GC time.
--
, cleanDB
:: stm ()
-- ^ Clean a database
Expand Down
11 changes: 11 additions & 0 deletions lib/core/src/Cardano/Pool/DB/MVar.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,19 +26,22 @@ import Cardano.Pool.DB.Model
, emptyPoolDatabase
, mCleanDatabase
, mCleanPoolMetadata
, mDelistPools
, mListHeaders
, mListPoolLifeCycleData
, mListRegisteredPools
, mListRetiredPools
, mPutFetchAttempt
, mPutHeader
, mPutLastMetadataGC
, mPutPoolMetadata
, mPutPoolProduction
, mPutPoolRegistration
, mPutPoolRetirement
, mPutSettings
, mPutStakeDistribution
, mReadCursor
, mReadLastMetadataGC
, mReadPoolLifeCycleStatus
, mReadPoolMetadata
, mReadPoolProduction
Expand Down Expand Up @@ -146,6 +149,9 @@ newDBLayer timeInterpreter = do
rollbackTo =
void . alterPoolDB (const Nothing) db . mRollbackTo timeInterpreter

delistPools =
void . alterPoolDB (const Nothing) db . mDelistPools

removePools =
void . alterPoolDB (const Nothing) db . mRemovePools

Expand All @@ -165,6 +171,11 @@ newDBLayer timeInterpreter = do
putSettings =
void . alterPoolDB (const Nothing) db . mPutSettings

readLastMetadataGC = readPoolDB db mReadLastMetadataGC

putLastMetadataGC =
void . alterPoolDB (const Nothing) db . mPutLastMetadataGC

cleanDB =
void $ alterPoolDB (const Nothing) db mCleanDatabase

Expand Down
Loading

0 comments on commit eb84baf

Please sign in to comment.