Merge #4575

4575: Improve test output r=Jimbo4350 a=newhoggy Exceptions in tests (for example from partial functions) cause failure without line number which makes the cause difficult to find. This PR switches to use functions that accurately convey location of failure in the test. Use `byDeadlineM` instead of `assertByDeadlineM`, which allows specifying a period. This allows a longer poll time to be used so the test output isn't as spammy. Co-authored-by: John Ky <[email protected]>
IntersectMBO · Oct 29, 2022 · 800bd79 · 800bd79
2 parents d533317 + 62198f6
commit 800bd79
Show file tree

Hide file tree

Showing 6 changed files with 68 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,41 @@ 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 (..),
+                   defaultTestnetNodeOptions, 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 qualified Testnet.Conf as H
 import           Testnet.Conf (ProjectBase (..), YamlFilePath (..))
-import           Testnet.Utils (waitUntilEpoch)
 
 import           Testnet.Properties.Cli.KesPeriodInfo
 
@@ -107,7 +104,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 +185,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 +221,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 +256,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 +289,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 +331,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 +355,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 +459,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
-