From 9623bc6c22dc245be40d89d877507cf3e453b3ee Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Tue, 2 Sep 2025 09:37:37 +0200 Subject: [PATCH 1/2] Improve Blockfrost integration Some fixes for the blockfrost tests to pass --- hydra-cluster/exe/hydra-cluster/Main.hs | 11 ++++- hydra-cluster/src/CardanoNode.hs | 40 +++++++++++++++++-- hydra-cluster/src/Hydra/Cluster/Faucet.hs | 2 +- hydra-cluster/src/Hydra/Cluster/Scenarios.hs | 8 ++-- .../test/Test/BlockfrostChainSpec.hs | 5 ++- hydra-node/src/Hydra/Chain/Backend.hs | 2 +- .../src/Hydra/Chain/Blockfrost/Client.hs | 14 ++++++- nohup.out | 0 8 files changed, 67 insertions(+), 15 deletions(-) create mode 100644 nohup.out diff --git a/hydra-cluster/exe/hydra-cluster/Main.hs b/hydra-cluster/exe/hydra-cluster/Main.hs index 303cbe1c10b..c70bacbfff2 100644 --- a/hydra-cluster/exe/hydra-cluster/Main.hs +++ b/hydra-cluster/exe/hydra-cluster/Main.hs @@ -4,7 +4,13 @@ module Main where import Hydra.Prelude -import CardanoNode (findRunningCardanoNode, waitForFullySynchronized, withCardanoNodeDevnet, withCardanoNodeOnKnownNetwork) +import CardanoNode ( + findFileStartingAtDirectory, + findRunningCardanoNode, + waitForFullySynchronized, + withCardanoNodeDevnet, + withCardanoNodeOnKnownNetwork, + ) import Hydra.Cardano.Api (TxId, serialiseToRawBytesHexText) import Hydra.Chain.Backend (ChainBackend, blockfrostProjectPath) import Hydra.Chain.Blockfrost (BlockfrostBackend (..)) @@ -39,7 +45,8 @@ run options = publishOrReuseHydraScripts tracer backend >>= singlePartyHeadFullLifeCycle tracer workDir backend else do - let backend = BlockfrostBackend $ BlockfrostOptions{projectPath = blockfrostProjectPath} + bfProjectPath <- findFileStartingAtDirectory 3 blockfrostProjectPath + let backend = BlockfrostBackend $ BlockfrostOptions{projectPath = bfProjectPath} publishOrReuseHydraScripts tracer backend >>= singlePartyHeadFullLifeCycle tracer workDir backend Nothing -> do diff --git a/hydra-cluster/src/CardanoNode.hs b/hydra-cluster/src/CardanoNode.hs index fbe0506b1e2..28b650b886c 100644 --- a/hydra-cluster/src/CardanoNode.hs +++ b/hydra-cluster/src/CardanoNode.hs @@ -12,6 +12,7 @@ import Data.Aeson (Value (String), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Lens (atKey, key, _Number) import Data.Fixed (Centi) +import Data.Text (pack) import Data.Text qualified as Text import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Hydra.Cardano.Api ( @@ -30,9 +31,17 @@ import Hydra.Cluster.Fixture (KnownNetwork (..), toNetworkId) import Hydra.Cluster.Util (readConfigFile) import Hydra.Options (BlockfrostOptions (..), DirectOptions (..)) import Network.HTTP.Simple (getResponseBody, httpBS, parseRequestThrow) -import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) +import System.Directory ( + createDirectoryIfMissing, + doesFileExist, + getCurrentDirectory, + removeFile, + ) import System.Exit (ExitCode (..)) -import System.FilePath (takeDirectory, ()) +import System.FilePath ( + takeDirectory, + (), + ) import System.Posix (ownerReadMode, setFileMode) import System.Process ( CreateProcess (..), @@ -169,9 +178,34 @@ withBlockfrostBackend :: withBlockfrostBackend _tracer stateDirectory action = do args <- setupCardanoDevnet stateDirectory shelleyGenesis <- readFileBS >=> unsafeDecodeJson $ stateDirectory nodeShelleyGenesisFile args - let backend = BlockfrostBackend $ BlockfrostOptions{projectPath = Backend.blockfrostProjectPath} + bfProjectPath <- findFileStartingAtDirectory 3 Backend.blockfrostProjectPath + let backend = BlockfrostBackend $ BlockfrostOptions{projectPath = bfProjectPath} action (getShelleyGenesisBlockTime shelleyGenesis) backend +-- | Find the given file in the current directory or its parents. +-- +-- This function starts from the current working directory and checks if the specified file exists there. +-- If not found, it recursively checks the parent directories up to the given maximum depth. +findFileStartingAtDirectory :: Int -> FilePath -> IO FilePath +findFileStartingAtDirectory maxDepth fileName = do + cwd <- getCurrentDirectory + findInDir maxDepth cwd + where + findInDir :: Int -> FilePath -> IO FilePath + findInDir depth dir = do + let path = dir fileName + exists <- doesFileExist path + if exists + then pure path + else + if depth <= 0 + then error $ "Could not locate the Blockfrost project file at or above: " <> pack dir + else do + let parent = ".." takeDirectory dir + if parent == dir + then error "Reached root directory without finding the Blockfrost project file." + else findInDir (depth - 1) parent + withBackend :: forall a. Tracer IO NodeLog -> diff --git a/hydra-cluster/src/Hydra/Cluster/Faucet.hs b/hydra-cluster/src/Hydra/Cluster/Faucet.hs index 3ef33949034..c004486e120 100644 --- a/hydra-cluster/src/Hydra/Cluster/Faucet.hs +++ b/hydra-cluster/src/Hydra/Cluster/Faucet.hs @@ -208,7 +208,7 @@ createOutputAtAddress :: IO (TxIn, TxOut CtxUTxO) createOutputAtAddress networkId backend atAddress datum val = do (faucetVk, faucetSk) <- keysFor Faucet - utxo <- findFaucetUTxO networkId backend 0 + utxo <- findFaucetUTxO networkId backend (selectLovelace val) let collateralTxIns = mempty let output = TxOut atAddress val datum ReferenceScriptNone buildTransaction backend (mkVkAddress networkId faucetVk) utxo collateralTxIns [output] >>= \case diff --git a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs index 373b8eb6094..17cf7609c5f 100644 --- a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs +++ b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs @@ -477,20 +477,20 @@ singlePartyHeadFullLifeCycle tracer workDir backend hydraScriptsTxId = utxoToCommit <- seedFromFaucet backend walletVk (lovelaceToValue amount) (contramap FromFaucet tracer) requestCommitTx n1 utxoToCommit <&> signTx walletSk >>= Backend.submitTransaction backend - waitFor hydraTracer (10 * blockTime) [n1] $ + waitFor hydraTracer (50 * blockTime) [n1] $ output "HeadIsOpen" ["utxo" .= toJSON utxoToCommit, "headId" .= headId] -- Close head send n1 $ input "Close" [] - deadline <- waitMatch (10 * blockTime) n1 $ \v -> do + deadline <- waitMatch (50 * blockTime) n1 $ \v -> do guard $ v ^? key "tag" == Just "HeadIsClosed" guard $ v ^? key "headId" == Just (toJSON headId) v ^? key "contestationDeadline" . _JSON remainingTime <- diffUTCTime deadline <$> getCurrentTime - waitFor hydraTracer (remainingTime + 3 * blockTime) [n1] $ + waitFor hydraTracer (remainingTime + 10 * blockTime) [n1] $ output "ReadyToFanout" ["headId" .= headId] send n1 $ input "Fanout" [] - waitForAllMatch (10 * blockTime) [n1] $ checkFanout headId utxoToCommit + waitForAllMatch (50 * blockTime) [n1] $ checkFanout headId utxoToCommit traceRemainingFunds Alice traceRemainingFunds AliceFunds where diff --git a/hydra-cluster/test/Test/BlockfrostChainSpec.hs b/hydra-cluster/test/Test/BlockfrostChainSpec.hs index 9924c62f0a8..b0963e7bd0a 100644 --- a/hydra-cluster/test/Test/BlockfrostChainSpec.hs +++ b/hydra-cluster/test/Test/BlockfrostChainSpec.hs @@ -9,6 +9,7 @@ import Cardano.Api.UTxO qualified as UTxO import Control.Concurrent.STM (takeTMVar) import Control.Concurrent.STM.TMVar (putTMVar) import Control.Exception (IOException) +import Data.Time (secondsToNominalDiffTime) import Hydra.Chain ( Chain (Chain, draftCommitTx, postTx), ChainEvent (..), @@ -91,7 +92,7 @@ spec = around (onlyWithBlockfrostProjectFile . showLogsOnFailure "BlockfrostChai participants <- loadParticipants [Alice] let headParameters = HeadParameters blockfrostcperiod [alice] postTx $ InitTx{participants, headParameters} - (headId, headSeed) <- observesInTimeSatisfying' aliceChain 500 $ hasInitTxWith headParameters participants + (headId, headSeed) <- observesInTimeSatisfying' aliceChain (secondsToNominalDiffTime $ fromIntegral Blockfrost.queryTimeout) $ hasInitTxWith headParameters participants let blueprintTx = txSpendingUTxO someUTxO externalCommit' backend aliceChain [aliceExternalSk] headId someUTxO blueprintTx @@ -134,7 +135,7 @@ spec = around (onlyWithBlockfrostProjectFile . showLogsOnFailure "BlockfrostChai let expectedUTxO = (Snapshot.utxo snapshot <> fromMaybe mempty (Snapshot.utxoToCommit snapshot)) `withoutUTxO` fromMaybe mempty (Snapshot.utxoToDecommit snapshot) - observesInTimeSatisfying' aliceChain 500 $ \case + observesInTimeSatisfying' aliceChain (secondsToNominalDiffTime $ fromIntegral Blockfrost.queryTimeout) $ \case OnFanoutTx{headId = headId', fanoutUTxO} | headId' == headId -> if UTxO.containsOutputs fanoutUTxO expectedUTxO diff --git a/hydra-node/src/Hydra/Chain/Backend.hs b/hydra-node/src/Hydra/Chain/Backend.hs index 149687bc1ec..e2f31454b31 100644 --- a/hydra-node/src/Hydra/Chain/Backend.hs +++ b/hydra-node/src/Hydra/Chain/Backend.hs @@ -11,7 +11,7 @@ import Hydra.Options (ChainBackendOptions) import Hydra.Tx (ScriptRegistry) blockfrostProjectPath :: FilePath -blockfrostProjectPath = "./blockfrost-project.txt" +blockfrostProjectPath = "blockfrost-project.txt" class ChainBackend a where queryGenesisParameters :: (MonadIO m, MonadThrow m) => a -> m (GenesisParameters ShelleyEra) diff --git a/hydra-node/src/Hydra/Chain/Blockfrost/Client.hs b/hydra-node/src/Hydra/Chain/Blockfrost/Client.hs index 5e01aec705b..0746c0f303c 100644 --- a/hydra-node/src/Hydra/Chain/Blockfrost/Client.hs +++ b/hydra-node/src/Hydra/Chain/Blockfrost/Client.hs @@ -378,6 +378,13 @@ submitTransaction tx = Blockfrost.submitTx $ Blockfrost.CBORString $ fromStrict -- Queries -- ---------------- +-- NOTE: Is this value good enough for all cardano networks? +queryTimeout :: Int +queryTimeout = 10 + +retryTimeout :: Int +retryTimeout = 300 + queryEraHistory :: BlockfrostClientT IO EraHistory queryEraHistory = do eras' <- Blockfrost.getNetworkEras @@ -417,7 +424,7 @@ queryEraHistory = do -- | Query the Blockfrost API to get the 'UTxO' for 'TxIn' and convert to cardano 'UTxO'. -- FIXME: make blockfrost wait times configurable. queryUTxOByTxIn :: NetworkId -> [TxIn] -> BlockfrostClientT IO UTxO -queryUTxOByTxIn networkId = foldMapM (\(TxIn txid _) -> go (300 :: Int) (serialiseToRawBytesHexText txid)) +queryUTxOByTxIn networkId = foldMapM (\(TxIn txid _) -> go retryTimeout (serialiseToRawBytesHexText txid)) where go 0 txHash = liftIO $ throwIO $ BlockfrostError $ FailedUTxOForHash txHash go n txHash = do @@ -450,6 +457,9 @@ queryScript scriptHashTxt = do -- fact this is a single address query always. queryUTxO :: NetworkId -> [Address ShelleyAddr] -> BlockfrostClientT IO UTxO queryUTxO networkId addresses = do + -- NOTE: We can't know at the time of doing a query if the information on specific address UTxO is _fresh_ or not + -- so we try to wait for sufficient period of time and hope for best. + liftIO $ threadDelay $ fromIntegral queryTimeout let address' = Blockfrost.Address . serialiseAddress $ List.head addresses utxoWithAddresses <- Blockfrost.getAddressUtxos address' @@ -525,7 +535,7 @@ awaitTransaction :: Tx -> VerificationKey PaymentKey -> BlockfrostClientT IO UTx awaitTransaction tx vk = do Blockfrost.Genesis{_genesisNetworkMagic} <- queryGenesisParameters let networkId = toCardanoNetworkId _genesisNetworkMagic - awaitUTxO networkId [makeShelleyAddress networkId (PaymentCredentialByKey $ verificationKeyHash vk) NoStakeAddress] (getTxId $ getTxBody tx) 300 + awaitUTxO networkId [makeShelleyAddress networkId (PaymentCredentialByKey $ verificationKeyHash vk) NoStakeAddress] (getTxId $ getTxBody tx) retryTimeout -- | Await for specific UTxO at address - the one that is produced by the given 'TxId'. awaitUTxO :: diff --git a/nohup.out b/nohup.out new file mode 100644 index 00000000000..e69de29bb2d From 4d1df6aa5596b0ecb8857a5e53efea1b7eee0188 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Mon, 22 Sep 2025 11:13:19 +0200 Subject: [PATCH 2/2] PR review changes --- hydra-cluster/src/CardanoNode.hs | 2 +- nohup.out | 0 2 files changed, 1 insertion(+), 1 deletion(-) delete mode 100644 nohup.out diff --git a/hydra-cluster/src/CardanoNode.hs b/hydra-cluster/src/CardanoNode.hs index 28b650b886c..322b87fb5a0 100644 --- a/hydra-cluster/src/CardanoNode.hs +++ b/hydra-cluster/src/CardanoNode.hs @@ -199,7 +199,7 @@ findFileStartingAtDirectory maxDepth fileName = do then pure path else if depth <= 0 - then error $ "Could not locate the Blockfrost project file at or above: " <> pack dir + then error $ "Could not locate the Blockfrost project file at " <> pack dir <> " or " <> show depth <> " above." else do let parent = ".." takeDirectory dir if parent == dir diff --git a/nohup.out b/nohup.out deleted file mode 100644 index e69de29bb2d..00000000000