From 1a650f2de1add73f79bccbd5f3cb6c22a2ed2200 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 24 Feb 2022 19:09:48 +0100 Subject: [PATCH] Get rid of unsafePerformIO --- hydra-cluster/src/CardanoCluster.hs | 52 ++++++++++++------------ hydra-cluster/src/Hydra/Generator.hs | 20 +++++---- hydra-cluster/test/Test/EndToEndSpec.hs | 2 +- hydra-cluster/test/Test/GeneratorSpec.hs | 28 +++++++------ hydra-node/src/Hydra/Ledger/Cardano.hs | 17 ++++---- 5 files changed, 65 insertions(+), 54 deletions(-) diff --git a/hydra-cluster/src/CardanoCluster.hs b/hydra-cluster/src/CardanoCluster.hs index db972fbd320..b80a944b156 100644 --- a/hydra-cluster/src/CardanoCluster.hs +++ b/hydra-cluster/src/CardanoCluster.hs @@ -42,8 +42,6 @@ import System.Posix.Files ( ) import Test.Network.Ports (randomUnusedTCPPort, randomUnusedTCPPorts) -data RunningCluster = RunningCluster ClusterConfig [RunningNode] - -- | TODO: This is hard-coded and must match what's in the genesis file, so -- ideally, we want to either: -- @@ -57,29 +55,6 @@ defaultNetworkId = Testnet (NetworkMagic 42) availableInitialFunds :: Num a => a availableInitialFunds = 900_000_000_000 --- | Configuration parameters for the cluster. -data ClusterConfig = ClusterConfig - { parentStateDirectory :: FilePath - , networkId :: NetworkId - } - -asSigningKey :: AsType (SigningKey PaymentKey) -asSigningKey = AsSigningKey AsPaymentKey - -withCluster :: - Tracer IO ClusterLog -> ClusterConfig -> (RunningCluster -> IO ()) -> IO () -withCluster tr cfg@ClusterConfig{parentStateDirectory} action = do - systemStart <- initSystemStart - (cfgA, cfgB, cfgC) <- - makeNodesConfig parentStateDirectory systemStart - <$> randomUnusedTCPPorts 3 - - withBFTNode tr cfgA $ \nodeA -> do - withBFTNode tr cfgB $ \nodeB -> do - withBFTNode tr cfgC $ \nodeC -> do - let nodes = [nodeA, nodeB, nodeC] - action (RunningCluster cfg nodes) - -- | Enumeration of known actors for which we can get the 'keysFor' and 'writeKeysFor'. data Actor = Alice @@ -129,6 +104,33 @@ writeKeysFor targetDir actor = do vkName = actorName actor <.> ".vk" +-- * Starting a cluster or single nodes + +data RunningCluster = RunningCluster ClusterConfig [RunningNode] + +-- | Configuration parameters for the cluster. +data ClusterConfig = ClusterConfig + { parentStateDirectory :: FilePath + , networkId :: NetworkId + } + +asSigningKey :: AsType (SigningKey PaymentKey) +asSigningKey = AsSigningKey AsPaymentKey + +withCluster :: + Tracer IO ClusterLog -> ClusterConfig -> (RunningCluster -> IO ()) -> IO () +withCluster tr cfg@ClusterConfig{parentStateDirectory} action = do + systemStart <- initSystemStart + (cfgA, cfgB, cfgC) <- + makeNodesConfig parentStateDirectory systemStart + <$> randomUnusedTCPPorts 3 + + withBFTNode tr cfgA $ \nodeA -> do + withBFTNode tr cfgB $ \nodeB -> do + withBFTNode tr cfgC $ \nodeC -> do + let nodes = [nodeA, nodeB, nodeC] + action (RunningCluster cfg nodes) + -- | Start a cardano-node in BFT mode using the config from config/ and -- credentials from config/credentials/ using given 'nodeId'. NOTE: This means -- that nodeId should only be 1,2 or 3 and that only the faucet receives diff --git a/hydra-cluster/src/Hydra/Generator.hs b/hydra-cluster/src/Hydra/Generator.hs index e8c07208939..75a481741be 100644 --- a/hydra-cluster/src/Hydra/Generator.hs +++ b/hydra-cluster/src/Hydra/Generator.hs @@ -12,9 +12,8 @@ import CardanoCluster (Actor (Faucet), availableInitialFunds, keysFor) import Control.Monad (foldM) import Data.Aeson (object, withObject, (.:), (.=)) import Data.Default (def) -import GHC.IO (unsafePerformIO) import Hydra.Ledger (IsTx (..)) -import Hydra.Ledger.Cardano (genKeyPair, mkSimpleTx) +import Hydra.Ledger.Cardano (genKeyPair, genSigningKey, mkSimpleTx) import Test.QuickCheck (choose, generate, sized) networkId :: NetworkId @@ -30,8 +29,9 @@ data Dataset = Dataset deriving (Show, Generic, ToJSON, FromJSON) instance Arbitrary Dataset where - arbitrary = sized $ \n -> - genConstantUTxODataset defaultProtocolParameters (n `div` 10) n + arbitrary = sized $ \n -> do + sk <- genSigningKey + genDatasetConstantUTxO sk defaultProtocolParameters (n `div` 10) n data ClientDataset = ClientDataset { signingKey :: SigningKey PaymentKey @@ -72,23 +72,25 @@ generateConstantUTxODataset :: -- | Number of transactions Int -> IO Dataset -generateConstantUTxODataset pparams nClients = - generate . genConstantUTxODataset pparams nClients +generateConstantUTxODataset pparams nClients nTxs = do + (_, faucetSk) <- keysFor Faucet + generate $ genDatasetConstantUTxO faucetSk pparams nClients nTxs -genConstantUTxODataset :: +genDatasetConstantUTxO :: + -- | The faucet signing key + SigningKey PaymentKey -> ProtocolParameters -> -- | Number of clients Int -> -- | Number of transactions Int -> Gen Dataset -genConstantUTxODataset pparams nClients nTxs = do +genDatasetConstantUTxO faucetSk pparams nClients nTxs = do clientFunds <- replicateM nClients $ do (_vk, sk) <- genKeyPair amount <- Lovelace . fromIntegral <$> choose (1, availableInitialFunds `div` nClients) pure (sk, amount) -- Prepare funding transaction as it will be posted - let (_, faucetSk) = unsafePerformIO $ keysFor Faucet -- HACK let fundingTransaction = mkGenesisTx networkId diff --git a/hydra-cluster/test/Test/EndToEndSpec.hs b/hydra-cluster/test/Test/EndToEndSpec.hs index 6a40bb73e73..94242568185 100644 --- a/hydra-cluster/test/Test/EndToEndSpec.hs +++ b/hydra-cluster/test/Test/EndToEndSpec.hs @@ -106,7 +106,7 @@ spec = around showLogsOnFailure $ withTempDir "end-to-end-two-heads" $ \tmpDir -> do config <- newNodeConfig tmpDir withBFTNode (contramap FromCluster tracer) config $ \node@(RunningNode _ nodeSocket) -> do - (aliceCardanoVk, aliceCardanoSk) <- keysFor Alice + (aliceCardanoVk, _aliceCardanoSk) <- keysFor Alice (bobCardanoVk, _bobCardanoSk) <- keysFor Bob (aliceVkPath, aliceSkPath) <- writeKeysFor tmpDir Alice (_, bobSkPath) <- writeKeysFor tmpDir Bob diff --git a/hydra-cluster/test/Test/GeneratorSpec.hs b/hydra-cluster/test/Test/GeneratorSpec.hs index 58ff67d8bad..b71fdabf34e 100644 --- a/hydra-cluster/test/Test/GeneratorSpec.hs +++ b/hydra-cluster/test/Test/GeneratorSpec.hs @@ -6,18 +6,19 @@ module Test.GeneratorSpec where import Hydra.Prelude import Test.Hydra.Prelude +import CardanoCluster (Actor (Faucet), keysFor) import Data.Text (unpack) import Hydra.Cardano.Api (UTxO, prettyPrintJSON, utxoFromTx) import Hydra.Generator ( ClientDataset (..), Dataset (..), defaultProtocolParameters, - genConstantUTxODataset, + genDatasetConstantUTxO, ) import Hydra.Ledger (applyTransactions, balance) import Hydra.Ledger.Cardano (Tx, cardanoLedger, genUTxO) import Test.Aeson.GenericSpecs (roundtripSpecs) -import Test.QuickCheck (Positive (Positive), Property, counterexample, forAll) +import Test.QuickCheck (Positive (Positive), Property, counterexample, forAll, idempotentIOProperty) spec :: Spec spec = parallel $ do @@ -32,16 +33,19 @@ prop_computeValueFromUTxO = prop_keepsUTxOConstant :: Property prop_keepsUTxOConstant = - forAll arbitrary $ \(Positive n) -> - -- XXX: non-exhaustive pattern match - forAll (genConstantUTxODataset defaultProtocolParameters 1 n) $ - \Dataset{fundingTransaction, clientDatasets = [ClientDataset{txSequence}]} -> - let initialUTxO = utxoFromTx fundingTransaction - finalUTxO = foldl' apply initialUTxO txSequence - in length finalUTxO == length initialUTxO - & counterexample ("transactions: " <> prettyJSONString txSequence) - & counterexample ("utxo: " <> prettyJSONString initialUTxO) - & counterexample ("funding tx: " <> prettyJSONString fundingTransaction) + forAll arbitrary $ \(Positive n) -> do + idempotentIOProperty $ do + faucetSk <- snd <$> keysFor Faucet + -- XXX: non-exhaustive pattern match + pure $ + forAll (genDatasetConstantUTxO faucetSk defaultProtocolParameters 1 n) $ + \Dataset{fundingTransaction, clientDatasets = [ClientDataset{txSequence}]} -> + let initialUTxO = utxoFromTx fundingTransaction + finalUTxO = foldl' apply initialUTxO txSequence + in length finalUTxO == length initialUTxO + & counterexample ("transactions: " <> prettyJSONString txSequence) + & counterexample ("utxo: " <> prettyJSONString initialUTxO) + & counterexample ("funding tx: " <> prettyJSONString fundingTransaction) apply :: UTxO -> Tx -> UTxO apply utxo tx = diff --git a/hydra-node/src/Hydra/Ledger/Cardano.hs b/hydra-node/src/Hydra/Ledger/Cardano.hs index 38d6eab91e6..4d8eb9f1a6c 100644 --- a/hydra-node/src/Hydra/Ledger/Cardano.hs +++ b/hydra-node/src/Hydra/Ledger/Cardano.hs @@ -28,7 +28,6 @@ import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Credential as Ledger import qualified Cardano.Ledger.Crypto as Ledger (StandardCrypto) -import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.Mary as Ledger.Mary hiding (Value) import qualified Cardano.Ledger.Shelley.API.Mempool as Ledger import qualified Cardano.Ledger.Shelley.Genesis as Ledger @@ -210,16 +209,20 @@ instance Arbitrary UTxO where -- * Generators +genSigningKey :: Gen (SigningKey PaymentKey) +genSigningKey = do + -- NOTE: not using 'genKeyDSIGN' purposely here, it is not pure and does not + -- play well with pure generation from seed. + sk <- fromJust . CC.rawDeserialiseSignKeyDSIGN . fromList <$> vectorOf 64 arbitrary + pure (PaymentSigningKey sk) + genVerificationKey :: Gen (VerificationKey PaymentKey) -genVerificationKey = fst <$> genKeyPair +genVerificationKey = getVerificationKey <$> genSigningKey genKeyPair :: Gen (VerificationKey PaymentKey, SigningKey PaymentKey) genKeyPair = do - -- NOTE: not using 'genKeyDSIGN' purposely here, it is not pure and does not - -- play well with pure generation from seed. - sk <- fromJust . CC.rawDeserialiseSignKeyDSIGN . fromList <$> vectorOf 64 arbitrary - let vk = CC.deriveVerKeyDSIGN sk - pure (PaymentVerificationKey (Ledger.VKey vk), PaymentSigningKey sk) + sk <- genSigningKey + pure (getVerificationKey sk, sk) -- TODO: Generate non-genesis transactions for better coverage. -- TODO: Enable Alonzo-specific features. We started off in the Mary era, and