Improve test output.

IntersectMBO · Oct 28, 2022 · 0ac5f32 · 0ac5f32
1 parent 289f905
commit 0ac5f32
Show file tree

Hide file tree

Showing 6 changed files with 69 additions and 74 deletions.
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
@@ -24,6 +24,10 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
+        # Add more elements to this list to run multiple instances of the build in CI.  Increasing the
+        # number instances is a good way to trigger flaky build failures
+        n: [1]
+
         ghc: ["8.10.7"]
         os: [ubuntu-latest, macos-latest, windows-latest]
 
@@ -257,7 +261,7 @@ jobs:
       if: ${{ always() }}
       continue-on-error: true
       with:
-        name: chairman-test-artifacts-${{ matrix.os }}-${{ matrix.ghc }}
+        name: chairman-test-artifacts-${{ matrix.os }}-${{ matrix.n }}-${{ matrix.ghc }}
         path: ${{ runner.temp }}/chairman/
 
   release:

diff --git a/cardano-testnet/src/Testnet/Byron.hs b/cardano-testnet/src/Testnet/Byron.hs
@@ -237,7 +237,7 @@ testnet testnetOptions H.Conf {..} = do
     sprocket <- H.noteShow $ Sprocket tempBaseAbsPath (socketDir </> "node-" <> si)
     _spocketSystemNameFile <- H.noteShow $ IO.sprocketSystemName sprocket
     -- TODO: Better error message need to indicate a sprocket was not created
-    H.assertByDeadlineM deadline $ H.doesSprocketExist sprocket
+    H.byDeadlineM 10 deadline $ H.assertM $ H.doesSprocketExist sprocket
 
   forM_ nodeIndexes $ \i -> do
     si <- H.noteShow $ show @Int i

diff --git a/cardano-testnet/src/Testnet/Cardano.hs b/cardano-testnet/src/Testnet/Cardano.hs
@@ -833,7 +833,7 @@ testnet testnetOptions H.Conf {..} = do
   forM_ allNodeNames $ \node -> do
     sprocket <- H.noteShow $ Sprocket tempBaseAbsPath (socketDir </> node)
     _spocketSystemNameFile <- H.noteShow $ IO.sprocketSystemName sprocket
-    H.assertByDeadlineM deadline $ H.doesSprocketExist sprocket
+    H.byDeadlineM 10 deadline $ H.assertM $ H.doesSprocketExist sprocket
 
   forM_ allNodeNames $ \node -> do
     nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log"

diff --git a/cardano-testnet/src/Testnet/Shelley.hs b/cardano-testnet/src/Testnet/Shelley.hs
@@ -454,7 +454,7 @@ testnet testnetOptions H.Conf {..} = do
   forM_ allNodes $ \node -> do
     sprocket <- H.noteShow $ Sprocket tempBaseAbsPath (socketDir </> node)
     _spocketSystemNameFile <- H.noteShow $ IO.sprocketSystemName sprocket
-    H.assertByDeadlineM deadline $ H.doesSprocketExist sprocket
+    H.byDeadlineM 10 deadline $ H.assertM $ H.doesSprocketExist sprocket
 
   forM_ allNodes $ \node -> do
     nodeStdoutFile <- H.noteTempFile logDir $ node <> ".stdout.log"

diff --git a/cardano-testnet/src/Testnet/Utils.hs b/cardano-testnet/src/Testnet/Utils.hs
@@ -10,20 +10,19 @@ module Testnet.Utils
 import           Cardano.Api
 import           Prelude
 
+import           Cardano.CLI.Shelley.Output
 import           Control.Concurrent (threadDelay)
 import           Control.Exception.Safe (MonadCatch)
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Aeson (fromJSON)
 import           GHC.Stack
+import           Hedgehog.Extras.Test.Process (ExecConfig)
+import           Hedgehog.Internal.Property (MonadTest)
 import           System.Directory (doesFileExist, removeFile)
 
-import           Cardano.CLI.Shelley.Output
-
 import qualified Hedgehog.Extras.Test.Base as H
 import qualified Hedgehog.Extras.Test.File as H
-import           Hedgehog.Extras.Test.Process (ExecConfig)
-import           Hedgehog.Internal.Property (MonadTest)
 import qualified Test.Process as H
 
 

diff --git a/cardano-testnet/test/Spec/Cli/KesPeriodInfo.hs b/cardano-testnet/test/Spec/Cli/KesPeriodInfo.hs
@@ -8,44 +8,42 @@ module Spec.Cli.KesPeriodInfo
   ( hprop_kes_period_info
   ) where
 
-
-import           Prelude
-
 import           Cardano.Api
-import           Cardano.Api.Shelley
-
+import           Cardano.Api.Shelley (PoolId)
 import           Control.Monad (void)
-import qualified Data.Aeson as J
-import qualified Data.Map.Strict as Map
 import           Data.Monoid (Last (..))
 import           Data.Set (Set)
-import qualified Data.Set as Set
-import qualified Data.Text as T
 import           GHC.Stack (callStack)
-import qualified System.Directory as IO
+import           Hedgehog (Property, (===))
+import           Prelude
 import           System.Environment (getEnvironment)
 import           System.FilePath ((</>))
 
 import           Cardano.CLI.Shelley.Output
 import           Cardano.CLI.Shelley.Run.Query
 
-import           Hedgehog (Property, (===))
+import           Testnet.Cardano (TestnetOptions (..), TestnetRuntime (..), defaultTestnetOptions,
+                   testnet)
+import           Testnet.Utils (waitUntilEpoch)
+
+import qualified Data.Aeson as J
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
 import qualified Hedgehog as H
 import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO
 import qualified Hedgehog.Extras.Test.Base as H
-import qualified Hedgehog.Extras.Test.Concurrent as H
 import qualified Hedgehog.Extras.Test.File as H
 import qualified Hedgehog.Extras.Test.Process as H
+import qualified System.Directory as IO
 import qualified System.Info as SYS
 import qualified Test.Base as H
 import qualified Test.Process as H
 import qualified Test.Runtime as TR
 import qualified Testnet.Cardano as TC
-import           Testnet.Cardano (TestnetOptions (..), TestnetRuntime (..),
-                   defaultTestnetNodeOptions, defaultTestnetOptions, testnet)
+import           Testnet.Cardano (defaultTestnetNodeOptions)
 import qualified Testnet.Conf as H
 import           Testnet.Conf (ProjectBase (..), YamlFilePath (..))
-import           Testnet.Utils (waitUntilEpoch)
 
 import           Testnet.Properties.Cli.KesPeriodInfo
 
@@ -107,7 +105,7 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman"
 
   utxo1Json <- H.leftFailM . H.readJsonFile $ work </> "utxo-1.json"
   UTxO utxo1 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(UTxO AlonzoEra) utxo1Json
-  txin <- H.noteShow $ head $ Map.keys utxo1
+  txin <- H.noteShow =<< H.headM (Map.keys utxo1)
 
   -- Staking keys
   utxoStakingVkey2 <- H.note $ tempAbsPath </> "shelley/utxo-keys/utxo2-stake.vkey"
@@ -188,27 +186,24 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman"
                , "--testnet-magic", show @Int testnetMagic
                ]
 
-  -- Things take long on non-linux machines
-  if H.isLinux
-  then H.threadDelay 5000000
-  else H.threadDelay 10000000
+  delegsAndRewards <- H.byDurationM 3 12 $ do
+    -- Check to see if pledge's stake address was registered
 
-  -- Check to see if pledge's stake address was registered
-
-  void $ H.execCli' execConfig
-    [ "query", "stake-address-info"
-    , "--address", poolownerstakeaddr
-    , "--testnet-magic", show @Int testnetMagic
-    , "--out-file", work </> "pledgeownerregistration.json"
-    ]
+    void $ H.execCli' execConfig
+      [ "query", "stake-address-info"
+      , "--address", poolownerstakeaddr
+      , "--testnet-magic", show @Int testnetMagic
+      , "--out-file", work </> "pledgeownerregistration.json"
+      ]
 
-  pledgerStakeInfo <- H.leftFailM . H.readJsonFile $ work </> "pledgeownerregistration.json"
-  delegsAndRewardsMap <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards pledgerStakeInfo
-  let delegsAndRewards = mergeDelegsAndRewards delegsAndRewardsMap
+    pledgerStakeInfo <- H.leftFailM . H.readJsonFile $ work </> "pledgeownerregistration.json"
+    delegsAndRewardsMap <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards pledgerStakeInfo
+    delegsAndRewards <- H.noteShow $ mergeDelegsAndRewards delegsAndRewardsMap
 
-  length delegsAndRewards === 1
+    length delegsAndRewards === 1
+    return delegsAndRewards
 
-  let (pledgerSAddr, _rewards, _poolId) = head delegsAndRewards
+  (pledgerSAddr, _rewards, _poolId) <- H.headM delegsAndRewards
 
   -- Pledger and owner are and can be the same
   T.unpack (serialiseAddress pledgerSAddr) === poolownerstakeaddr
@@ -227,7 +222,7 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman"
 
   utxoWithStaking1Json <- H.leftFailM . H.readJsonFile $ work </> "utxo-addr-with-staking-1.json"
   UTxO utxoWithStaking1 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(UTxO AlonzoEra) utxoWithStaking1Json
-  txinForStakeReg <- H.noteShow $ head $ Map.keys utxoWithStaking1
+  txinForStakeReg <- H.noteShow =<< H.headM (Map.keys utxoWithStaking1)
 
   void $ H.execCli [ "stake-address", "registration-certificate"
                    , "--stake-verification-key-file", utxoStakingVkey2
@@ -262,21 +257,21 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman"
     ]
 
   H.note_ $ "Check to see if " <> utxoStakingVkey2 <> " was registered..."
-  H.threadDelay 10000000
 
-  void $ H.execCli' execConfig
-    [ "query", "stake-address-info"
-    , "--address", utxostakingaddr
-    , "--testnet-magic", show @Int testnetMagic
-    , "--out-file", work </> "stake-address-info-utxo-staking-vkey-2.json"
-    ]
-
-  userStakeAddrInfoJSON <- H.leftFailM . H.readJsonFile $ work </> "stake-address-info-utxo-staking-vkey-2.json"
-  delegsAndRewardsMapUser <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards userStakeAddrInfoJSON
-  let delegsAndRewardsUser = mergeDelegsAndRewards delegsAndRewardsMapUser
-      userStakeAddrInfo = filter (\(sAddr,_,_) -> utxostakingaddr == T.unpack (serialiseAddress sAddr)) delegsAndRewardsUser
-      (userSAddr, _rewards, _poolId) = head userStakeAddrInfo
+  userSAddr <- H.byDurationM 3 12 $ do
+    void $ H.execCli' execConfig
+      [ "query", "stake-address-info"
+      , "--address", utxostakingaddr
+      , "--testnet-magic", show @Int testnetMagic
+      , "--out-file", work </> "stake-address-info-utxo-staking-vkey-2.json"
+      ]
 
+    userStakeAddrInfoJSON <- H.leftFailM . H.readJsonFile $ work </> "stake-address-info-utxo-staking-vkey-2.json"
+    delegsAndRewardsMapUser <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards userStakeAddrInfoJSON
+    delegsAndRewardsUser <- H.noteShow $ mergeDelegsAndRewards delegsAndRewardsMapUser
+    userStakeAddrInfo <- H.noteShow $ filter (\(sAddr,_,_) -> utxostakingaddr == T.unpack (serialiseAddress sAddr)) delegsAndRewardsUser
+    (userSAddr, _rewards, _poolId) <- H.headM userStakeAddrInfo
+    return userSAddr
 
   H.note_ $ "Check staking key: " <> show utxoStakingVkey2 <> " was registered"
   T.unpack (serialiseAddress userSAddr) === utxostakingaddr
@@ -295,7 +290,7 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman"
 
   utxo2Json <- H.leftFailM . H.readJsonFile $ work </> "utxo-2.json"
   UTxO utxo2 <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(UTxO AlonzoEra) utxo2Json
-  txin2 <- H.noteShow $ head $ Map.keys utxo2
+  txin2 <- H.noteShow =<< H.headM (Map.keys utxo2)
 
   H.note_ "Create delegation certificate of pledger"
 
@@ -337,22 +332,19 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman"
     , "--testnet-magic", show @Int testnetMagic
     ]
 
-  if H.isLinux
-  then H.threadDelay 5000000
-  else H.threadDelay 20000000
-
-  void $ H.execCli' execConfig
-    [ "query", "stake-pools"
-    , "--testnet-magic", show @Int testnetMagic
-    , "--out-file", work </> "current-registered.pools.json"
-    ]
+  H.byDurationM 3 12 $ do
+    void $ H.execCli' execConfig
+      [ "query", "stake-pools"
+      , "--testnet-magic", show @Int testnetMagic
+      , "--out-file", work </> "current-registered.pools.json"
+      ]
 
-  currRegPools <- H.leftFailM . H.readJsonFile $ work </> "current-registered.pools.json"
-  poolIds <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(Set PoolId) currRegPools
-  poolId <- H.noteShow $ head $ Set.toList poolIds
+    currRegPools <- H.leftFailM . H.readJsonFile $ work </> "current-registered.pools.json"
+    poolIds <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @(Set PoolId) currRegPools
+    poolId <- H.noteShow =<< H.headM (Set.toList poolIds)
 
-  H.note_ "Check stake pool was successfully registered"
-  T.unpack (serialiseToBech32 poolId) === stakePoolId
+    H.note_ "Check stake pool was successfully registered"
+    T.unpack (serialiseToBech32 poolId) === stakePoolId
 
   H.note_ "Check pledge was successfully delegated"
   void $ H.execCli' execConfig
@@ -364,9 +356,10 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman"
 
   pledgeStakeAddrInfoJSON <- H.leftFailM . H.readJsonFile $ work </> "pledge-stake-address-info.json"
   delegsAndRewardsMapPledge <- H.noteShowM $ H.jsonErrorFail $ J.fromJSON @DelegationsAndRewards pledgeStakeAddrInfoJSON
-  let delegsAndRewardsPledge = mergeDelegsAndRewards delegsAndRewardsMapPledge
-      pledgeStakeAddrInfo = filter (\(sAddr,_,_) -> poolownerstakeaddr == T.unpack (serialiseAddress sAddr)) delegsAndRewardsPledge
-      (pledgeSAddr, _rewards, pledgerDelegPoolId) = head pledgeStakeAddrInfo
+  delegsAndRewardsPledge <- H.noteShow $ mergeDelegsAndRewards delegsAndRewardsMapPledge
+  pledgeStakeAddrInfo <- H.noteShow $ filter (\(sAddr,_,_) -> poolownerstakeaddr == T.unpack (serialiseAddress sAddr)) delegsAndRewardsPledge
+
+  (pledgeSAddr, _rewards, pledgerDelegPoolId) <- H.headM pledgeStakeAddrInfo
 
   H.note_ "Check pledge has been delegated to pool"
   case pledgerDelegPoolId of
@@ -467,4 +460,3 @@ hprop_kes_period_info = H.integration . H.runFinallies . H.workspace "chairman"
   -- TODO: Linking to the node log file like this is fragile.
   spoLogFile <- H.note $ tempAbsPath </> "logs/node-pool1.stdout.log"
   prop_node_minted_block spoLogFile
-