Merge pull request #123 from mlabs-haskell/vasil-waiting-for-index

Vasil waiting for index

local-cluster/Main.hs

@@ -37,6 +37,7 @@ main = do
           workingDir = maybe Temporary (`Fixed` False) workDir
           plutipConfig = def {clusterWorkingDir = workingDir}
 
+      putStrLn "Starting cluster..."
       (st, _) <- startCluster plutipConfig $ do
         ws <- initWallets numWallets numUtxos amt dirWallets
         waitSeconds 2 -- let wallet Tx finish, it can take more time with bigger slot length

src/Test/Plutip/Internal/LocalCluster.hs

@@ -39,7 +39,7 @@ import Paths_plutip (getDataFileName)
 import Plutus.ChainIndex.App qualified as ChainIndex
 import Plutus.ChainIndex.Config qualified as ChainIndex
 import Plutus.ChainIndex.Logging (defaultConfig)
-import Servant.Client (BaseUrl (BaseUrl), Scheme (Http))
+import Servant.Client (BaseUrl (BaseUrl), Scheme (Http), mkClientEnv, runClientM)
 import System.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, doesPathExist, findExecutable, removeDirectoryRecursive)
 import System.Environment (setEnv)
 import System.Exit (die)
@@ -70,7 +70,7 @@ import Test.Plutip.Internal.Types (
 import Test.Plutip.Tools.CardanoApi qualified as Tools
 import Text.Printf (printf)
 import UnliftIO.Concurrent (forkFinally, myThreadId, throwTo)
-import UnliftIO.Exception (bracket, catchIO, finally)
+import UnliftIO.Exception (bracket, catchIO, finally, throwString)
 import UnliftIO.STM (TVar, atomically, newTVarIO, readTVar, retrySTM, writeTVar)
 
 import Cardano.Wallet.Primitive.Types (
@@ -81,7 +81,11 @@ import Cardano.Wallet.Primitive.Types (
 import Data.Default (Default (def))
 import Data.Function ((&))
 import Data.Time (nominalDiffTimeToSeconds)
+import Ledger (Slot (Slot))
 import Ledger.TimeSlot (SlotConfig (scSlotLength))
+import Network.HTTP.Client (defaultManagerSettings, newManager)
+import Plutus.ChainIndex (Tip (Tip))
+import Plutus.ChainIndex.Client qualified as ChainIndexClient
 import Plutus.ChainIndex.Config qualified as CIC
 import PlutusPrelude ((.~), (^.))
 
@@ -145,7 +149,7 @@ withPlutusInterface conf action = do
     runActionWthSetup rn dir trCluster userActon = do
       let tracer' = trMessageText trCluster
       waitForRelayNode tracer' rn
-      -- launch chain index in seperate thread, logs to stdout
+      -- launch chain index in separate thread
       ciPort <- launchChainIndex conf rn dir
       traceWith tracer' (ChaiIndexStartedAt ciPort)
       let cEnv =
@@ -250,8 +254,10 @@ waitForRelayNode trCluster rn =
     getTip = trace >> Tools.queryTip rn
     trace = traceWith trCluster WaitingRelayNode
     wait _ = do
-      -- give some time for setup
-      (ChainTip (SlotNo ((> 5) -> True)) _ _) <- getTip
+      tip <- getTip
+      case tip of
+        (ChainTip (SlotNo _) _ _) -> pure ()
+        a -> throwString $ "Timeout waiting for node to start. Last 'tip' response:\n" <> show a
       pure ()
 
 -- | Launch the chain index in a separate thread.
@@ -262,6 +268,7 @@ launchChainIndex conf (RunningNode sp _block0 (netParams, _vData) _) dir = do
   config <- defaultConfig
   CM.setMinSeverity config Severity.Notice
   let dbPath = dir </> "chain-index.db"
+      port = maybe (CIC.cicPort ChainIndex.defaultConfig) fromEnum (chainIndexPort conf)
       chainIndexConfig =
         CIC.defaultConfig
           & CIC.socketPath .~ nodeSocketFile sp
@@ -271,10 +278,26 @@ launchChainIndex conf (RunningNode sp _block0 (netParams, _vData) _) dir = do
           & CIC.slotConfig .~ (def {scSlotLength = toMilliseconds slotLen})
 
   void . async $ void $ ChainIndex.runMainWithLog (const $ return ()) config chainIndexConfig
+  waitForChainIndex port
   return $ chainIndexConfig ^. CIC.port
   where
     toMilliseconds = floor . (1e3 *) . nominalDiffTimeToSeconds
 
+    waitForChainIndex port = do
+      let policy = constantDelay 1_000_000 <> limitRetries 60
+      recoverAll policy $ \_ -> do
+        tip <- queryTipWithChIndex port
+        case tip of
+          Right (Tip (Slot _) _ _) -> pure ()
+          a ->
+            throwString $
+              "Timeout waiting for chain-index to start indexing. Last response:\n"
+                <> show a
+
+    queryTipWithChIndex port = do
+      manager' <- newManager defaultManagerSettings
+      runClientM ChainIndexClient.getTip $ mkClientEnv manager' (BaseUrl Http "localhost" port "")
+
 handleLogs :: HasCallStack => FilePath -> PlutipConfig -> IO ()
 handleLogs clusterDir conf =
   copyRelayLog `catchIO` (error . printf "Failed to save relay node log: %s" . show)