From 0e1523ed5c4f429f87d5c6297977cf5bef3e7e29 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 13 Nov 2020 17:42:07 +0100 Subject: [PATCH 1/3] Add SMASH integration test --- .../Scenario/API/Shelley/StakePools.hs | 82 ++++++++++++------- lib/core/src/Cardano/Pool/Metadata.hs | 3 + .../src/Cardano/Wallet/Shelley/Launch.hs | 48 ++++++++++- lib/shelley/test/integration/Main.hs | 38 +++++---- lib/test-utils/src/Test/Utils/StaticServer.hs | 4 +- 5 files changed, 124 insertions(+), 51 deletions(-) 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 index 9223ac1a991..562daedf8ee 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs @@ -17,7 +17,8 @@ import Prelude import Cardano.Wallet.Api.Types ( ApiCertificate (JoinPool, QuitPool, RegisterRewardAccount) - , ApiStakePool + , ApiStakePool (flags) + , ApiStakePoolFlag (..) , ApiT (..) , ApiTransaction , ApiWallet @@ -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 @@ -137,6 +140,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. @@ -966,33 +970,6 @@ spec = describe "SHELLEY_STAKE_POOLS" $ 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 @@ -1120,7 +1097,56 @@ 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 $ 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"] + ] + 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*) diff --git a/lib/core/src/Cardano/Pool/Metadata.hs b/lib/core/src/Cardano/Pool/Metadata.hs index 89d251b7bc4..9153e842b33 100644 --- a/lib/core/src/Cardano/Pool/Metadata.hs +++ b/lib/core/src/Cardano/Pool/Metadata.hs @@ -27,6 +27,9 @@ module Cardano.Pool.Metadata -- * re-exports , newManager , defaultManagerSettings + + -- * Types + , SMASHPoolId (..) ) where import Prelude diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs index e87788e571f..fc671823a28 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs @@ -27,6 +27,7 @@ module Cardano.Wallet.Shelley.Launch withCluster , withBFTNode , withStakePool + , withSMASH , NodeParams (..) , singleNodeParams , PoolConfig (..) @@ -53,6 +54,9 @@ module Cardano.Wallet.Shelley.Launch , testLogDirFromEnv , walletListenFromEnv + -- * global vars + , operators + -- * Logging , ClusterLog (..) ) where @@ -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 @@ -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 @@ -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 @@ -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" @@ -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" @@ -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" diff --git a/lib/shelley/test/integration/Main.hs b/lib/shelley/test/integration/Main.hs index 143eef41070..58b31552363 100644 --- a/lib/shelley/test/integration/Main.hs +++ b/lib/shelley/test/integration/Main.hs @@ -63,6 +63,7 @@ import Cardano.Wallet.Shelley.Launch , testMinSeverityFromEnv , walletMinSeverityFromEnv , withCluster + , withSMASH , withSystemTempDir , withTempDir ) @@ -149,22 +150,25 @@ main = withUtf8Encoding $ withTracers $ \tracers -> do parallelIf (not nix) $ describe "Miscellaneous CLI tests" $ MiscellaneousCLI.spec @t specWithServer tracers $ do - parallel $ describe "API Specifications" $ do - Addresses.spec @n - CoinSelections.spec @n - ByronAddresses.spec @n - ByronCoinSelections.spec @n - Wallets.spec @n - ByronWallets.spec @n - HWWallets.spec @n - Migrations.spec @n - ByronMigrations.spec @n - Transactions.spec @n - Network.spec - Network_.spec - StakePools.spec @n - ByronTransactions.spec @n - ByronHWWallets.spec @n + describe "API Specifications" $ do + parallel $ do + Addresses.spec @n + CoinSelections.spec @n + ByronAddresses.spec @n + ByronCoinSelections.spec @n + Wallets.spec @n + ByronWallets.spec @n + HWWallets.spec @n + Migrations.spec @n + ByronMigrations.spec @n + Transactions.spec @n + Network.spec + Network_.spec + StakePools.spec @n + ByronTransactions.spec @n + ByronHWWallets.spec @n + + -- possible conflict with StakePools Settings.spec @n -- Hydra runs tests with code coverage enabled. CLI tests run @@ -243,7 +247,7 @@ specWithServer (tr, tracers) = aroundAll withContext atomicModifyIORef' eventsRef ((, ()) . (event :)) pure certificates - withServer dbDecorator action = bracketTracer' tr "withServer" $ do + withServer dbDecorator action = bracketTracer' tr "withServer" $ withSMASH tr' $ do minSev <- nodeMinSeverityFromEnv testPoolConfigs <- poolConfigsFromEnv withSystemTempDir tr' "test" $ \dir -> do diff --git a/lib/test-utils/src/Test/Utils/StaticServer.hs b/lib/test-utils/src/Test/Utils/StaticServer.hs index 7151db30ba6..1ffc57e6507 100644 --- a/lib/test-utils/src/Test/Utils/StaticServer.hs +++ b/lib/test-utils/src/Test/Utils/StaticServer.hs @@ -12,7 +12,7 @@ module Test.Utils.StaticServer import Prelude import Network.Wai.Application.Static - ( defaultWebAppSettings, staticApp ) + ( defaultFileServerSettings, staticApp ) import Network.Wai.Handler.Warp ( withApplication ) @@ -27,5 +27,5 @@ withStaticServer withStaticServer root action = withApplication (pure app) $ \port -> action (baseUrl port) where - app = staticApp $ defaultWebAppSettings root + app = staticApp $ defaultFileServerSettings root baseUrl port = "http://localhost:" <> show port <> "/" From db43c99faa4cdcd285005bbbb00f4643fe96de38 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 17 Nov 2020 11:23:55 +0100 Subject: [PATCH 2/3] Bracket settings changes --- .../src/Test/Integration/Framework/DSL.hs | 16 +++++++++++++++- .../Scenario/API/Shelley/StakePools.hs | 9 +++++---- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/lib/core-integration/src/Test/Integration/Framework/DSL.hs b/lib/core-integration/src/Test/Integration/Framework/DSL.hs index 7ea9edf8713..2dc37be3f12 100644 --- a/lib/core-integration/src/Test/Integration/Framework/DSL.hs +++ b/lib/core-integration/src/Test/Integration/Framework/DSL.hs @@ -133,6 +133,7 @@ module Test.Integration.Framework.DSL , oneSecond , getTTLSlots , updateMetadataSource + , bracketSettings , verifyMetadataSource , triggerMaintenanceAction , verifyMaintenanceAction @@ -212,6 +213,7 @@ import Cardano.Wallet.Api.Types , DecodeStakeAddress (..) , EncodeAddress (..) , Iso8601Time (..) + , SettingsPutData (..) , WalletStyle (..) , insertedAt ) @@ -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| { @@ -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 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 index 562daedf8ee..30164fc9fee 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs @@ -90,6 +90,7 @@ import Test.Integration.Framework.Context import Test.Integration.Framework.DSL ( Headers (..) , Payload (..) + , bracketSettings , delegating , delegationFee , emptyWallet @@ -154,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" @@ -164,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" @@ -966,7 +967,7 @@ 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 @@ -1098,7 +1099,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do (reverse epochs `zip` [1 ..]) `shouldSatisfy` all (uncurry (==)) it "STAKE_POOLS_SMASH_01 - fetching metadata from SMASH works with delisted pools" $ - \ctx -> runResourceT $ do + \ctx -> runResourceT $ bracketSettings ctx $ do smashUrl <- liftIO $ getEnv "CARDANO_WALLET_SMASH_URL" updateMetadataSource ctx (T.pack smashUrl) eventually "metadata is fetched" $ do From badf76901cdee877648b88561b8b0189f021e890 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 17 Nov 2020 14:41:35 +0100 Subject: [PATCH 3/3] Fix bug in delisted pools not clearing --- .../Scenario/API/Shelley/StakePools.hs | 18 +++++++++++ lib/core/src/Cardano/Pool/DB/Model.hs | 3 +- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 1 + .../test/unit/Cardano/Pool/DB/Properties.hs | 32 +++++++++++++++++++ 4 files changed, 53 insertions(+), 1 deletion(-) 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 index 30164fc9fee..85fcdfd3d0d 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs @@ -1120,6 +1120,24 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do "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 diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index 658ea3f5449..b8993aef366 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -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 diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 17d778d5ca9..d874db803ab 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -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) diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index 185f60bbd76..de4955908ab 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -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 @@ -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: --