Skip to content

Commit

Permalink
Merge #2319
Browse files Browse the repository at this point in the history
2319: Add SMASH integration test r=hasufell a=hasufell

# Issue Number

https://jira.iohk.io/browse/ADP-478

* add integration test for SMASH via file stub server

Co-authored-by: Julian Ospald <[email protected]>
  • Loading branch information
iohk-bors[bot] and Julian Ospald authored Nov 17, 2020
2 parents acc63ec + badf769 commit d2ab232
Show file tree
Hide file tree
Showing 9 changed files with 196 additions and 56 deletions.
16 changes: 15 additions & 1 deletion lib/core-integration/src/Test/Integration/Framework/DSL.hs
Original file line number Diff line number Diff line change
Expand Up @@ -133,6 +133,7 @@ module Test.Integration.Framework.DSL
, oneSecond
, getTTLSlots
, updateMetadataSource
, bracketSettings
, verifyMetadataSource
, triggerMaintenanceAction
, verifyMaintenanceAction
Expand Down Expand Up @@ -212,6 +213,7 @@ import Cardano.Wallet.Api.Types
, DecodeStakeAddress (..)
, EncodeAddress (..)
, Iso8601Time (..)
, SettingsPutData (..)
, WalletStyle (..)
, insertedAt
)
Expand Down Expand Up @@ -598,7 +600,7 @@ defaultTxTTL = 7200
--
updateMetadataSource :: (MonadIO m, MonadCatch m) => Context t -> Text -> m ()
updateMetadataSource ctx t = do
r <- request @(ApiT Settings) ctx Link.putSettings Default payload
r <- request @SettingsPutData ctx Link.putSettings Default payload
expectResponseCode HTTP.status204 r
where
payload = Json [aesonQQ| {
Expand All @@ -607,6 +609,18 @@ updateMetadataSource ctx t = do
}
} |]

bracketSettings :: (MonadIO m, MonadCatch m) => Context t -> m () -> m ()
bracketSettings ctx action = do
r@(_, response) <- request @(ApiT Settings) ctx Link.getSettings Default Empty
expectResponseCode HTTP.status200 r
case response of
Left e -> wantedSuccessButError e
Right s -> do
action
r' <- request @SettingsPutData ctx Link.putSettings Default
(Json $ Aeson.toJSON $ SettingsPutData s)
expectResponseCode HTTP.status204 r'

verifyMetadataSource
:: (MonadIO m, MonadCatch m)
=> Context t
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,8 @@ import Prelude

import Cardano.Wallet.Api.Types
( ApiCertificate (JoinPool, QuitPool, RegisterRewardAccount)
, ApiStakePool
, ApiStakePool (flags)
, ApiStakePoolFlag (..)
, ApiT (..)
, ApiTransaction
, ApiWallet
Expand Down Expand Up @@ -76,6 +77,8 @@ import Data.Text.Class
( showT, toText )
import Numeric.Natural
( Natural )
import System.Environment
( getEnv )
import Test.Hspec
( SpecWith, describe, pendingWith )
import Test.Hspec.Expectations.Lifted
Expand All @@ -87,6 +90,7 @@ import Test.Integration.Framework.Context
import Test.Integration.Framework.DSL
( Headers (..)
, Payload (..)
, bracketSettings
, delegating
, delegationFee
, emptyWallet
Expand Down Expand Up @@ -137,6 +141,7 @@ import Test.Integration.Framework.TestData
import qualified Cardano.Wallet.Api.Link as Link
import qualified Data.ByteString as BS
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Network.HTTP.Types.Status as HTTP

spec :: forall n t.
Expand All @@ -150,7 +155,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
(Link.listStakePools stake) Default Empty

it "STAKE_POOLS_MAINTENANCE_01 - \
\trigger GC action when metadata source = direct" $ \ctx -> runResourceT $ do
\trigger GC action when metadata source = direct" $ \ctx -> runResourceT $ bracketSettings ctx $ do
updateMetadataSource ctx "direct"
verifyMetadataSource ctx FetchDirect
triggerMaintenanceAction ctx "gc_stake_pools"
Expand All @@ -160,7 +165,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
verifyMaintenanceAction ctx NotApplicable

it "STAKE_POOLS_MAINTENANCE_02 - \
\trigger GC action when metadata source = none" $ \ctx -> runResourceT $ do
\trigger GC action when metadata source = none" $ \ctx -> runResourceT $ bracketSettings ctx $ do
updateMetadataSource ctx "none"
verifyMetadataSource ctx FetchNone
triggerMaintenanceAction ctx "gc_stake_pools"
Expand Down Expand Up @@ -962,37 +967,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
production `shouldSatisfy` (> 0)
saturation `shouldSatisfy` (any (> 0))

it "contains pool metadata" $ \ctx -> runResourceT $ do
it "contains pool metadata" $ \ctx -> runResourceT $ bracketSettings ctx $ do
updateMetadataSource ctx "direct"
eventually "metadata is fetched" $ do
r <- listPools ctx arbitraryStake
let metadataPossible = Set.fromList
[ StakePoolMetadata
{ ticker = (StakePoolTicker "GPA")
, name = "Genesis Pool A"
, description = Nothing
, homepage = "https://iohk.io"
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPB")
, name = "Genesis Pool B"
, description = Nothing
, homepage = "https://iohk.io"
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPC")
, name = "Genesis Pool C"
, description = Just "Lorem Ipsum Dolor Sit Amet."
, homepage = "https://iohk.io"
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPD")
, name = "Genesis Pool D"
, description = Just "Lorem Ipsum Dolor Sit Amet."
, homepage = "https://iohk.io"
}
]

verify r
[ expectListSize 3
, expectField Prelude.id $ \pools' -> do
Expand Down Expand Up @@ -1120,7 +1098,74 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
let epochs = poolGarbageCollectionEpochNo <$> events
(reverse epochs `zip` [1 ..]) `shouldSatisfy` all (uncurry (==))

it "STAKE_POOLS_SMASH_01 - fetching metadata from SMASH works with delisted pools" $
\ctx -> runResourceT $ bracketSettings ctx $ do
smashUrl <- liftIO $ getEnv "CARDANO_WALLET_SMASH_URL"
updateMetadataSource ctx (T.pack smashUrl)
eventually "metadata is fetched" $ do
r <- listPools ctx arbitraryStake
verify r
[ expectListSize 3
, expectField Prelude.id $ \pools' -> do
let metadataActual = Set.fromList $
mapMaybe (fmap getApiT . view #metadata) pools'
delistedPools = filter (\pool -> Delisted `elem` flags pool)
pools'
metadataActual
`shouldSatisfy` (`Set.isSubsetOf` metadataPossible)
metadataActual
`shouldSatisfy` (not . Set.null)
(fmap (getApiT . view #id) delistedPools)
`shouldBe` [PoolId . unsafeFromHex $
"b45768c1a2da4bd13ebcaa1ea51408eda31dcc21765ccbd407cda9f2"]
]

updateMetadataSource ctx "direct"
eventually "pools are not delisted anymore" $ do
r <- listPools ctx arbitraryStake
verify r
[ expectListSize 3
, expectField Prelude.id $ \pools' -> do
let metadataActual = Set.fromList $
mapMaybe (fmap getApiT . view #metadata) pools'
delistedPools = filter (\pool -> Delisted `elem` flags pool)
pools'
metadataActual
`shouldSatisfy` (`Set.isSubsetOf` metadataPossible)
metadataActual
`shouldSatisfy` (not . Set.null)
(fmap (getApiT . view #id) delistedPools)
`shouldBe` []
]

where
metadataPossible = Set.fromList
[ StakePoolMetadata
{ ticker = (StakePoolTicker "GPA")
, name = "Genesis Pool A"
, description = Nothing
, homepage = "https://iohk.io"
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPB")
, name = "Genesis Pool B"
, description = Nothing
, homepage = "https://iohk.io"
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPC")
, name = "Genesis Pool C"
, description = Just "Lorem Ipsum Dolor Sit Amet."
, homepage = "https://iohk.io"
}
, StakePoolMetadata
{ ticker = (StakePoolTicker "GPD")
, name = "Genesis Pool D"
, description = Just "Lorem Ipsum Dolor Sit Amet."
, homepage = "https://iohk.io"
}
]

arbitraryStake :: Maybe Coin
arbitraryStake = Just $ ada 10_000_000_000
where ada = Coin . (1000*1000*)
Expand Down
3 changes: 2 additions & 1 deletion lib/core/src/Cardano/Pool/DB/Model.hs
Original file line number Diff line number Diff line change
Expand Up @@ -209,9 +209,10 @@ mCleanDatabase :: ModelOp ()
mCleanDatabase = State.put emptyPoolDatabase

mCleanPoolMetadata :: ModelOp ()
mCleanPoolMetadata =
mCleanPoolMetadata = do
modify #metadata
$ const mempty
mPutDelistedPools []

mPutPoolProduction :: BlockHeader -> PoolId -> ModelOp ()
mPutPoolProduction point poolId = getPoints >>= \points -> if
Expand Down
1 change: 1 addition & 0 deletions lib/core/src/Cardano/Pool/DB/Sqlite.hs
Original file line number Diff line number Diff line change
Expand Up @@ -404,6 +404,7 @@ newDBLayer trace fp timeInterpreter = do
removePoolMetadata = do
deleteWhere ([] :: [Filter PoolMetadata])
deleteWhere ([] :: [Filter PoolMetadataFetchAttempts])
deleteWhere ([] :: [Filter PoolDelistment])

readPoolMetadata = do
Map.fromList . map (fromPoolMeta . entityVal)
Expand Down
3 changes: 3 additions & 0 deletions lib/core/src/Cardano/Pool/Metadata.hs
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,9 @@ module Cardano.Pool.Metadata
-- * re-exports
, newManager
, defaultManagerSettings

-- * Types
, SMASHPoolId (..)
) where

import Prelude
Expand Down
32 changes: 32 additions & 0 deletions lib/core/test/unit/Cardano/Pool/DB/Properties.hs
Original file line number Diff line number Diff line change
Expand Up @@ -225,6 +225,8 @@ properties = do
(property . prop_putLastMetadataGCReadLastMetadataGC)
it "putDelistedPools >> readDelistedPools shows the pool as delisted"
(property . prop_putDelistedPools)
it "clearing metadata also clears delisted pools"
(property . prop_removePoolMetadataDelistedPools)

{-------------------------------------------------------------------------------
Properties
Expand Down Expand Up @@ -1457,6 +1459,36 @@ prop_putLastMetadataGCReadLastMetadataGC DBLayer{..} posixTime = do
assertWith "Setting sync time and reading afterwards works"
(time == Just posixTime)

-- Check that removing pool metadata removes delisted pools.
prop_removePoolMetadataDelistedPools
:: DBLayer IO
-> Set.Set PoolId
-> Property
prop_removePoolMetadataDelistedPools DBLayer {..} pools =
monadicIO (setup >> prop)
where
setup = run $ atomically cleanDB

prop = do
run $ atomically $ putDelistedPools (Set.toList pools)
poolsActuallyDelisted <- Set.fromList . L.sort <$>
run (atomically readDelistedPools)
monitor $ counterexample $ unlines
[ "Pools to mark as delisted: "
, pretty $ Set.toList pools
, "Pools actually delisted: "
, pretty $ Set.toList poolsActuallyDelisted
]
assertWith "pools == poolsActuallyDelisted"
$ pools == poolsActuallyDelisted

-- now should be empty
run $ atomically removePoolMetadata
poolsAfter <- Set.fromList . L.sort <$>
run (atomically readDelistedPools)
assertWith "[] == poolsAfter"
$ null (Set.toList poolsAfter)

-- Check that 'putDelistedPools' completely overwrites the existing set
-- of delisted pools every time:
--
Expand Down
48 changes: 44 additions & 4 deletions lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,7 @@ module Cardano.Wallet.Shelley.Launch
withCluster
, withBFTNode
, withStakePool
, withSMASH
, NodeParams (..)
, singleNodeParams
, PoolConfig (..)
Expand All @@ -53,6 +54,9 @@ module Cardano.Wallet.Shelley.Launch
, testLogDirFromEnv
, walletListenFromEnv

-- * global vars
, operators

-- * Logging
, ClusterLog (..)
) where
Expand Down Expand Up @@ -85,6 +89,8 @@ import Cardano.Launcher.Node
, NodePort (..)
, withCardanoNode
)
import Cardano.Pool.Metadata
( SMASHPoolId (..) )
import Cardano.Wallet.Api.Server
( Listen (..) )
import Cardano.Wallet.Logging
Expand Down Expand Up @@ -120,7 +126,7 @@ import Control.Concurrent.Async
import Control.Concurrent.Chan
( newChan, readChan, writeChan )
import Control.Concurrent.MVar
( MVar, modifyMVar, newMVar, putMVar, takeMVar )
( MVar, modifyMVar, newMVar, putMVar, readMVar, takeMVar )
import Control.Exception
( SomeException, finally, handle, throwIO )
import Control.Monad
Expand Down Expand Up @@ -819,6 +825,40 @@ withStakePool tr baseDir idx params pledgeAmt poolConfig action =
dir = baseDir </> name
name = "pool-" ++ show idx

-- | Run a SMASH stub server, serving some delisted pool IDs.
withSMASH
:: Tracer IO ClusterLog
-> IO a
-> IO a
withSMASH tr action =
withSystemTempDir tr "smash" $ \fp -> do
let baseDir = fp </> "api/v1"

-- write pool metadatas
pools <- readMVar operators
forM_ pools $ \(poolId, _, _, _, metadata) -> do
let bytes = Aeson.encode metadata

let metadataDir = baseDir </> "metadata"
poolDir = metadataDir </> T.unpack (toText poolId)
hash = blake2b256S (BL.toStrict bytes)
hashFile = poolDir </> hash

createDirectoryIfMissing True poolDir
BL8.writeFile (poolDir </> hashFile) bytes

-- write delisted pools
let delisted = [SMASHPoolId (T.pack
"b45768c1a2da4bd13ebcaa1ea51408eda31dcc21765ccbd407cda9f2")]
bytes = Aeson.encode delisted
BL8.writeFile (baseDir </> "delisted") bytes

withStaticServer fp $ \baseUrl -> do
setEnv envVar baseUrl
action
where
envVar :: String
envVar = "CARDANO_WALLET_SMASH_URL"

updateVersion :: Tracer IO ClusterLog -> FilePath -> IO ()
updateVersion tr tmpDir = do
Expand Down Expand Up @@ -1402,7 +1442,7 @@ faucetIndex = unsafePerformIO $ newMVar 1
operators :: MVar [(PoolId, Aeson.Value, Aeson.Value, Aeson.Value, Aeson.Value)]
operators = unsafePerformIO $ newMVar
[ ( PoolId $ unsafeFromHex
"c7258ccc42a43b653aaf2f80dde3120df124ebc3a79353eed782267f78d04739"
"ec28f33dcbe6d6400a1e5e339bd0647c0973ca6c0cf9c2bbe6838dc6"
, Aeson.object
[ "type" .= Aeson.String "StakePoolVerificationKey_ed25519"
, "description" .= Aeson.String "Stake pool operator key"
Expand All @@ -1429,7 +1469,7 @@ operators = unsafePerformIO $ newMVar
]
)
, ( PoolId $ unsafeFromHex
"775af3b22eff9ff53a0bdd3ac6f8e1c5013ab68445768c476ccfc1e1c6b629b4"
"1b3dc19c6ab89eaffc8501f375bb03c11bf8ed5d183736b1d80413d6"
, Aeson.object
[ "type" .= Aeson.String "StakePoolVerificationKey_ed25519"
, "description" .= Aeson.String "Stake pool operator key"
Expand All @@ -1456,7 +1496,7 @@ operators = unsafePerformIO $ newMVar
]
)
, ( PoolId $ unsafeFromHex
"5a7b67c7dcfa8c4c25796bea05bcdfca01590c8c7612cc537c97012bed0dec35"
"b45768c1a2da4bd13ebcaa1ea51408eda31dcc21765ccbd407cda9f2"
, Aeson.object
[ "type" .= Aeson.String "StakePoolVerificationKey_ed25519"
, "description" .= Aeson.String "Stake pool operator key"
Expand Down
Loading

0 comments on commit d2ab232

Please sign in to comment.