Improve Blockfrost integration

Some fixes for the blockfrost tests to pass

Author: v0d1ch

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

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 ->

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

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

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

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)

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 ::