Skip to content

Commit

Permalink
Try #2249:
Browse files Browse the repository at this point in the history
  • Loading branch information
iohk-bors[bot] authored Oct 19, 2020
2 parents 66df475 + 5d0c0a6 commit 18f1e50
Show file tree
Hide file tree
Showing 29 changed files with 8,471 additions and 298 deletions.
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
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
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
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 18f1e50

Please sign in to comment.