Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add fix and test for foldBlocks #4679

Merged
merged 1 commit into from
Dec 19, 2022
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 6 additions & 1 deletion cardano-testnet/cardano-testnet.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,9 @@ library
, bytestring
, cardano-api
, cardano-cli
, cardano-crypto-class
, cardano-git-rev
, cardano-ledger-byron
, cardano-node
, containers
, directory
Expand Down Expand Up @@ -103,25 +105,28 @@ test-suite cardano-testnet-tests
other-modules: Test.Cli.Alonzo.LeadershipSchedule
Test.Cli.Babbage.LeadershipSchedule
Test.Cli.KesPeriodInfo
Test.FoldBlocks
Test.Misc
Test.Node.Shutdown
Test.ShutdownOnSlotSynced

type: exitcode-stdio-1.0

build-depends: aeson
, async
, cardano-api
, cardano-cli
, cardano-testnet
, containers
, directory
, filepath
, hedgehog
, hedgehog
, hedgehog-extras
, process
, tasty
, text
, time
, transformers


other-modules:
Expand Down
32 changes: 31 additions & 1 deletion cardano-testnet/src/Testnet/Cardano.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,20 +17,26 @@ module Testnet.Cardano
, cardanoTestnet
) where

import qualified Cardano.Crypto.Hash.Blake2b
import qualified Cardano.Crypto.Hash.Class
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Except
import Data.Aeson ((.=))
import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString)
import Data.List ((\\))
import Data.Maybe
import Data.String
import qualified Hedgehog as H
import Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..))
import Hedgehog.Extras.Stock.Time (formatIso8601, showUTCTimeSeconds)
import Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..))
import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..))
import Prelude
import System.FilePath.Posix ((</>))

import Cardano.Chain.Genesis (GenesisHash (unGenesisHash), readGenesisData)
import qualified Cardano.Node.Configuration.Topology as NonP2P
import qualified Cardano.Node.Configuration.TopologyP2P as P2P
import qualified Data.Aeson as J
Expand Down Expand Up @@ -706,6 +712,15 @@ cardanoTestnet testnetOptions H.Conf {..} = do
-- Generated a signed 'do it all' transaction:
H.assertIO . IO.doesFileExist $ tempAbsPath </> "tx1.tx"

-- Add Byron, Shelley and Alonzo genesis hashes to node configuration
byronGenesisHash <- getByronGenesisHash $ tempAbsPath </> "byron/genesis.json"
shelleyGenesisHash <- getShelleyGenesisHash $ tempAbsPath </> "shelley/genesis.json"
alonzoGenesisHash <- getShelleyGenesisHash $ tempAbsPath </> "shelley/genesis.alonzo.json"
H.rewriteYamlFile (tempAbsPath </> "configuration.yaml") . J.rewriteObject
$ HM.insert "ByronGenesisHash" byronGenesisHash
. HM.insert "ShelleyGenesisHash" shelleyGenesisHash
. HM.insert "AlonzoGenesisHash" alonzoGenesisHash

--------------------------------
-- Launch cluster of three nodes

Expand Down Expand Up @@ -761,3 +776,18 @@ cardanoTestnet testnetOptions H.Conf {..} = do
, wallets
, delegators = [] -- TODO this should be populated
}

-- * Generate hashes for genesis.json files

getByronGenesisHash :: (H.MonadTest m, MonadIO m) => FilePath -> m J.Value
getByronGenesisHash path = do
e <- runExceptT $ readGenesisData path
(_, genesisHash) <- H.leftFail e
let genesisHash' = J.toJSON $ unGenesisHash genesisHash
pure genesisHash'

getShelleyGenesisHash :: (H.MonadTest m, MonadIO m) => FilePath -> m J.Value
getShelleyGenesisHash path = do
content <- liftIO $ BS.readFile path
let genesisHash = Cardano.Crypto.Hash.Class.hashWith id content :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 BS.ByteString
pure $ J.toJSON genesisHash
2 changes: 2 additions & 0 deletions cardano-testnet/test/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,7 @@ import qualified Test.Tasty.Ingredients as T
--import qualified Test.Cli.Alonzo.LeadershipSchedule
import qualified Test.Cli.Babbage.LeadershipSchedule
import qualified Test.Cli.KesPeriodInfo
import qualified Test.FoldBlocks
import qualified Test.Node.Shutdown
import qualified Test.ShutdownOnSlotSynced
import qualified Util.Ignore as H
Expand All @@ -35,6 +36,7 @@ tests = pure $ T.testGroup "test/Spec.hs"
-- TODO: Babbage temporarily ignored due to broken protocol-state query
, H.disabled "kes-period-info" Test.Cli.KesPeriodInfo.hprop_kes_period_info
]
, H.ignoreOnWindows "foldBlocks receives ledger state" Test.FoldBlocks.prop_foldBlocks
]

ingredients :: [T.Ingredient]
Expand Down
84 changes: 84 additions & 0 deletions cardano-testnet/test/Test/FoldBlocks.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,84 @@
{-# LANGUAGE OverloadedStrings #-}

module Test.FoldBlocks where

import qualified Control.Concurrent as IO
import Control.Concurrent.Async (async, link)
import Control.Exception (Exception, throw)
import Control.Monad (forever)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (runExceptT)
import qualified Data.Text as TS
import Prelude
import qualified System.Directory as IO
import System.FilePath ((</>))

import qualified Hedgehog as H
import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as HE
import qualified Hedgehog.Extras.Test as HE
import qualified Hedgehog.Extras.Test.Base as H

import qualified Cardano.Api as C
import qualified Testnet.Cardano as TN
import qualified Testnet.Conf as TC (Conf (..), ProjectBase (ProjectBase),
YamlFilePath (YamlFilePath), mkConf)
import qualified Util.Base as U
import qualified Util.Runtime as U


newtype FoldBlocksException = FoldBlocksException C.FoldBlocksError
instance Exception FoldBlocksException
instance Show FoldBlocksException where
show (FoldBlocksException a) = TS.unpack $ C.renderFoldBlocksError a

-- | This test starts a testnet with wery short timing, then starts
-- `foldBlocks` in another thread to listen for ledger state, ledger
-- events and block, and on reception writes this to the `lock` `MVar`
-- that main thread blocks on.
prop_foldBlocks :: H.Property
prop_foldBlocks = U.integration . H.runFinallies . H.workspace "chairman" $ \tempAbsBasePath' -> do

-- Start testnet
base <- HE.noteM $ liftIO . IO.canonicalizePath =<< HE.getProjectBase
configurationTemplate <- H.noteShow $ base </> "configuration/defaults/byron-mainnet/configuration.yaml"
conf <- HE.noteShowM $
TC.mkConf (TC.ProjectBase base) (TC.YamlFilePath configurationTemplate)
(tempAbsBasePath' <> "/")
Nothing

let options = TN.defaultTestnetOptions
-- NB! The `activeSlotsCoeff` value is very important for
-- chain extension for the two-node/one-pool testnet that
-- `defaultTestnetOptions` define. The default 0.2 often fails
-- to extend the chain in a reasonable time (< 90s, e.g as the
-- deadline is defined in Testnet.Cardano).
{ TN.activeSlotsCoeff = 0.9 }
runtime <- TN.cardanoTestnet options conf

-- Get socketPath
socketPathAbs <- do
socketPath' <- HE.sprocketArgumentName <$> HE.headM (U.nodeSprocket <$> TN.bftNodes runtime)
H.note =<< liftIO (IO.canonicalizePath $ TC.tempAbsPath conf </> socketPath')

configurationFile <- H.noteShow $ TC.tempAbsPath conf </> "configuration.yaml"

-- Start foldBlocks in a separate thread
lock <- liftIO IO.newEmptyMVar
liftIO $ do
a <- async $
-- The `forever` is here because `foldBlocks` drains blocks
-- until current slot and then quits -- even if there are no
-- permanent (= older than the k parameter) blocks created. In
-- that case we simply restart `foldBlocks` again.
forever $ do
let handler _env _ledgerState _ledgerEvents _blockInCardanoMode _ = IO.putMVar lock ()
e <- runExceptT (C.foldBlocks configurationFile socketPathAbs C.QuickValidation () handler)
either (throw . FoldBlocksException) (\_ -> pure ()) e
link a -- Throw async thread's exceptions in main thread

-- The `lock` is written to from within the `handler` above. It
-- tests that `foldBlocks` receives ledger state; once that happens,
-- handler is called, which then writes to the `lock` and allows the
-- test to finish.
_ <- liftIO $ IO.readMVar lock
H.assert True