From 41815e15794b506caeff692d71a6199e663714d7 Mon Sep 17 00:00:00 2001 From: zmrocze Date: Mon, 21 Nov 2022 14:33:23 +0100 Subject: [PATCH 1/7] Plutip-server handles multiple stop requests properly --- plutip-server/Api/Handlers.hs | 11 +++++------ src/Test/Plutip/Internal/LocalCluster.hs | 2 +- test/Spec/Integration.hs | 2 +- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/plutip-server/Api/Handlers.hs b/plutip-server/Api/Handlers.hs index 7e2614ef..c1226931 100644 --- a/plutip-server/Api/Handlers.hs +++ b/plutip-server/Api/Handlers.hs @@ -6,7 +6,7 @@ module Api.Handlers ( import Cardano.Api (serialiseToCBOR) import Cardano.Launcher.Node (nodeSocketFile) import Cardano.Wallet.Shelley.Launch.Cluster (RunningNode (RunningNode)) -import Control.Concurrent.MVar (isEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.MVar (isEmptyMVar, putMVar, tryTakeMVar) import Control.Monad (unless) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Extra (unlessM) @@ -98,10 +98,9 @@ startClusterHandler stopClusterHandler :: StopClusterRequest -> AppM StopClusterResponse stopClusterHandler StopClusterRequest = do statusMVar <- asks status - isClusterDown <- liftIO $ isEmptyMVar statusMVar - if isClusterDown - then pure $ StopClusterFailure "Cluster is not running" - else do - statusTVar <- liftIO $ takeMVar statusMVar + maybeClusterStatus <- liftIO $ tryTakeMVar statusMVar + case maybeClusterStatus of + Nothing -> pure $ StopClusterFailure "Cluster is not running" + Just statusTVar -> do liftIO $ stopCluster statusTVar pure $ StopClusterSuccess diff --git a/src/Test/Plutip/Internal/LocalCluster.hs b/src/Test/Plutip/Internal/LocalCluster.hs index 78d816fe..cd460617 100644 --- a/src/Test/Plutip/Internal/LocalCluster.hs +++ b/src/Test/Plutip/Internal/LocalCluster.hs @@ -11,9 +11,9 @@ module Test.Plutip.Internal.LocalCluster ( ) where import Cardano.Api qualified as CAPI +import Cardano.BM.Configuration.Model qualified as CM import Cardano.BM.Data.Severity qualified as Severity import Cardano.BM.Data.Tracer (HasPrivacyAnnotation, HasSeverityAnnotation (getSeverityAnnotation)) -import Cardano.BM.Configuration.Model qualified as CM import Cardano.CLI (LogOutput (LogToFile), withLoggingNamed) import Cardano.Launcher.Node (nodeSocketFile) import Cardano.Startup (installSignalHandlers, setDefaultFilePermissions, withUtf8Encoding) diff --git a/test/Spec/Integration.hs b/test/Spec/Integration.hs index 55a94f6c..60adb11c 100644 --- a/test/Spec/Integration.hs +++ b/test/Spec/Integration.hs @@ -188,7 +188,7 @@ test = (initAda [100]) (withContract $ const failingTimeContract) [shouldFail] -- FIXME: add check that "OutsideValidityIntervalUTxO" is in error message - -- [shouldSucceed] + -- [shouldSucceed] , assertExecution "Passes validation with exact time range checks" (initAda [100]) From 4e2d9138743b80826128a25130272a92139e0b35 Mon Sep 17 00:00:00 2001 From: zmrocze Date: Mon, 21 Nov 2022 15:06:57 +0100 Subject: [PATCH 2/7] Stop chain-index at stopCluster --- src/Test/Plutip/Internal/LocalCluster.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Test/Plutip/Internal/LocalCluster.hs b/src/Test/Plutip/Internal/LocalCluster.hs index cd460617..b631b1ab 100644 --- a/src/Test/Plutip/Internal/LocalCluster.hs +++ b/src/Test/Plutip/Internal/LocalCluster.hs @@ -20,7 +20,7 @@ import Cardano.Startup (installSignalHandlers, setDefaultFilePermissions, withUt import Cardano.Wallet.Logging (stdoutTextTracer, trMessageText) import Cardano.Wallet.Shelley.Launch (TempDirLog, withSystemTempDir) import Cardano.Wallet.Shelley.Launch.Cluster (ClusterLog, localClusterConfigFromEnv, testMinSeverityFromEnv, walletMinSeverityFromEnv, withCluster) -import Control.Concurrent.Async (async) +import Control.Concurrent.Async (Async, async, cancel) import Control.Monad (unless, void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO) @@ -130,11 +130,11 @@ withPlutusInterface conf action = do handleLogs dir conf return result where - runActionWthSetup rn dir trCluster userActon = do + runActionWthSetup rn dir trCluster userAction = do let tracer' = trMessageText trCluster waitForRelayNode tracer' rn -- launch chain index in seperate thread, logs to stdout - ciPort <- launchChainIndex conf rn dir + (ciPort, runningChainIndex) <- launchChainIndex conf rn dir traceWith tracer' (ChaiIndexStartedAt ciPort) let cEnv = ClusterEnv @@ -147,7 +147,7 @@ withPlutusInterface conf action = do } BotSetup.runSetup cEnv -- run preparations to use `bot-plutus-interface` - userActon cEnv -- executing user action on cluster + userAction cEnv `finally` cancel runningChainIndex -- executing user action on cluster -- Redirect stdout to a provided handle providing mask to temporarily revert back to initial stdout. withRedirectedStdoutHdl :: Handle -> ((forall b. IO b -> IO b) -> IO a) -> IO a @@ -240,7 +240,7 @@ waitForRelayNode trCluster rn = do trace = traceWith trCluster WaitingRelayNode -- | Launch the chain index in a separate thread. -launchChainIndex :: PlutipConfig -> RunningNode -> FilePath -> IO Int +launchChainIndex :: PlutipConfig -> RunningNode -> FilePath -> IO (Int, Async ()) launchChainIndex conf (RunningNode sp _block0 (_gp, _vData) _) dir = do config <- defaultConfig CM.setMinSeverity config Severity.Notice @@ -256,8 +256,8 @@ launchChainIndex conf (RunningNode sp _block0 (_gp, _vData) _) dir = do fromEnum (chainIndexPort conf) } - void . async $ void $ ChainIndex.runMainWithLog (const $ return ()) config chainIndexConfig - return $ cicPort chainIndexConfig + running <- async $ ChainIndex.runMainWithLog (const $ return ()) config chainIndexConfig + return (cicPort chainIndexConfig, running) handleLogs :: HasCallStack => FilePath -> PlutipConfig -> IO () handleLogs clusterDir conf = From c01a9b625ae61ab308099dbd748a34c32769b267 Mon Sep 17 00:00:00 2001 From: zmrocze Date: Wed, 23 Nov 2022 00:37:15 +0100 Subject: [PATCH 3/7] Wait for wallets being funded in plutip-server Uses node query and waits till node queries for all wallets return any utxos at the cluster startup in plutip-server. --- plutip-server/Api/Handlers.hs | 39 ++++++++++++++++++----------- plutip-server/Types.hs | 15 ++++------- src/Test/Plutip/Tools/CardanoApi.hs | 35 ++++++++++++++++++++++++++ 3 files changed, 65 insertions(+), 24 deletions(-) diff --git a/plutip-server/Api/Handlers.hs b/plutip-server/Api/Handlers.hs index c1226931..7efb5c97 100644 --- a/plutip-server/Api/Handlers.hs +++ b/plutip-server/Api/Handlers.hs @@ -15,6 +15,7 @@ import Control.Monad.Reader (ReaderT, ask, asks) import Data.ByteString.Base16 qualified as Base16 import Data.Default (def) import Data.Foldable (for_) +import Data.Text (Text) import Data.Text.Encoding qualified as Text import Data.Traversable (for) import System.Directory (doesFileExist) @@ -24,13 +25,15 @@ import Test.Plutip.Internal.BotPlutusInterface.Setup (keysDir) import Test.Plutip.Internal.BotPlutusInterface.Wallet (BpiWallet (signKey), addSomeWallet) import Test.Plutip.Internal.LocalCluster (startCluster, stopCluster) import Test.Plutip.Internal.Types (ClusterEnv (runningNode)) -import Test.Plutip.LocalCluster (waitSeconds) +import Test.Plutip.LocalCluster (cardanoMainnetAddress) +import Test.Plutip.Tools.CardanoApi (awaitWalletFunded) import Types ( AppM, ClusterStartupFailureReason ( ClusterIsRunningAlready, NegativeLovelaces, - NodeConfigNotFound + NodeConfigNotFound, + WaitingForFundedWalletsFailed ), ClusterStartupParameters ( ClusterStartupParameters, @@ -65,32 +68,40 @@ startClusterHandler isClusterDown <- liftIO $ isEmptyMVar statusMVar unless isClusterDown $ throwError ClusterIsRunningAlready let cfg = def {relayNodeLogs = nodeLogs, chainIndexPort = Nothing} - (statusTVar, res@(clusterEnv, _)) <- liftIO $ startCluster cfg setup + (statusTVar, (clusterEnv, ewallets)) <- liftIO $ startCluster cfg setup liftIO $ putMVar statusMVar statusTVar let nodeConfigPath = getNodeConfigFile clusterEnv -- safeguard against directory tree structure changes unlessM (liftIO $ doesFileExist nodeConfigPath) $ throwError NodeConfigNotFound - pure $ - ClusterStartupSuccess $ - ClusterStartupParameters - { privateKeys = getWalletPrivateKey <$> snd res - , nodeSocketPath = getNodeSocketFile clusterEnv - , nodeConfigPath = nodeConfigPath - , keysDirectory = keysDir clusterEnv - } + case ewallets of + Left e -> throwError $ WaitingForFundedWalletsFailed e + Right wallets -> + pure $ + ClusterStartupSuccess $ + ClusterStartupParameters + { privateKeys = getWalletPrivateKey <$> wallets + , nodeSocketPath = getNodeSocketFile clusterEnv + , nodeConfigPath = nodeConfigPath + , keysDirectory = keysDir clusterEnv + } where - setup :: ReaderT ClusterEnv IO (ClusterEnv, [BpiWallet]) + setup :: ReaderT ClusterEnv IO (ClusterEnv, Either Text [BpiWallet]) setup = do env <- ask wallets <- do for keysToGenerate $ \lovelaceAmounts -> do addSomeWallet (fromInteger . unLovelace <$> lovelaceAmounts) - waitSeconds 2 -- wait for transactions to submit - pure (env, wallets) + waitRes <- for wallets $ \w -> awaitWalletFunded (cardanoMainnetAddress w) + case sequence_ waitRes of + Left e -> pure (env, Left e) + Right () -> do + pure $ (env, Right wallets) + getNodeSocketFile (runningNode -> RunningNode conn _ _ _) = nodeSocketFile conn getNodeConfigFile = -- assumption is that node.config lies in the same directory as node.socket flip replaceFileName "node.config" . getNodeSocketFile + getWalletPrivateKey :: BpiWallet -> PrivateKey getWalletPrivateKey = Text.decodeUtf8 . Base16.encode . serialiseToCBOR . signKey interpret = fmap (either ClusterStartupFailure id) . runExceptT diff --git a/plutip-server/Types.hs b/plutip-server/Types.hs index 1458491c..22a486c1 100644 --- a/plutip-server/Types.hs +++ b/plutip-server/Types.hs @@ -3,7 +3,8 @@ module Types ( ClusterStartupFailureReason ( ClusterIsRunningAlready, NegativeLovelaces, - NodeConfigNotFound + NodeConfigNotFound, + WaitingForFundedWalletsFailed ), Env (Env, status, options), ErrorMessage, @@ -37,14 +38,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import Network.Wai.Handler.Warp (Port) import Test.Plutip.Internal.BotPlutusInterface.Wallet (BpiWallet) -import Test.Plutip.Internal.LocalCluster ( - ClusterStatus ( - ClusterClosed, - ClusterClosing, - ClusterStarted, - ClusterStarting - ), - ) +import Test.Plutip.Internal.LocalCluster (ClusterStatus) import Test.Plutip.Internal.Types (ClusterEnv) import UnliftIO.STM (TVar) @@ -54,7 +48,7 @@ import UnliftIO.STM (TVar) -- cluster at any given moment). -- This MVar is used by start/stop handlers. -- The payload of ClusterStatus is irrelevant. -type ClusterStatusRef = MVar (TVar (ClusterStatus (ClusterEnv, [BpiWallet]))) +type ClusterStatusRef = MVar (TVar (ClusterStatus (ClusterEnv, Either Text [BpiWallet]))) data Env = Env { status :: ClusterStatusRef @@ -111,6 +105,7 @@ data ClusterStartupFailureReason = ClusterIsRunningAlready | NegativeLovelaces | NodeConfigNotFound + | WaitingForFundedWalletsFailed Text deriving stock (Show, Eq, Generic) deriving anyclass (FromJSON, ToJSON) diff --git a/src/Test/Plutip/Tools/CardanoApi.hs b/src/Test/Plutip/Tools/CardanoApi.hs index abdff05e..53387fcb 100644 --- a/src/Test/Plutip/Tools/CardanoApi.hs +++ b/src/Test/Plutip/Tools/CardanoApi.hs @@ -4,6 +4,7 @@ module Test.Plutip.Tools.CardanoApi ( utxosAtAddress, queryProtocolParams, queryTip, + awaitWalletFunded, ) where import Cardano.Api qualified as C @@ -11,8 +12,16 @@ import Cardano.Api.Shelley (ProtocolParameters) import Cardano.Launcher.Node (nodeSocketFile) import Cardano.Slotting.Slot (WithOrigin) import Cardano.Wallet.Shelley.Launch.Cluster (RunningNode (RunningNode)) +import Control.Arrow (right) import Control.Exception (Exception) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, ask) +import Control.Retry (constantDelay, limitRetries, retrying) +import Data.Either (fromRight) +import Data.Map qualified as M import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T import GHC.Generics (Generic) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure) @@ -71,3 +80,29 @@ flattenQueryResult :: flattenQueryResult = \case Right (Right res) -> Right res err -> Left $ SomeError (show err) + +-- | Waits till specified address is funded using cardano-node query. +-- Performs 20 tries with 0.2 seconds between tries, which should be a sane default. +-- Waits till there's any utxos at an address - works for us as funds will be send with tx per address. +awaitWalletFunded :: + C.AddressAny -> + ReaderT ClusterEnv IO (Either Text ()) +awaitWalletFunded addr = toErrorMsg <$> retrying policy checkResponse action + where + -- With current defaults the slot length is 0.2s and block gets produced about every second slot. + -- We are expected to wait 0.4s, waiting 4s we are almost guaranteed (p>0.9999) + delay = 200_000 -- in microseconds, 0.2s. + policy = constantDelay delay <> limitRetries 20 + + action _ = do + cenv <- ask + liftIO $ right (M.null . C.unUTxO) <$> utxosAtAddress cenv addr + + checkResponse _ = return . fromRight False + + toErrorMsg = \case + Left (SomeError e) -> Left $ T.pack e + Right noUtxos -> + if noUtxos + then Left "Funding transaction wasn't submitted yet and we're done waiting." + else Right () From ae7f59c5e54befb30fd075e3c79a7821167ea5d9 Mon Sep 17 00:00:00 2001 From: zmrocze Date: Wed, 23 Nov 2022 19:19:15 +0100 Subject: [PATCH 4/7] Refactor --- plutip-server/Api/Handlers.hs | 42 ++++++++++++++--------------- plutip-server/Types.hs | 2 +- src/Test/Plutip/Tools/CardanoApi.hs | 11 +++----- 3 files changed, 26 insertions(+), 29 deletions(-) diff --git a/plutip-server/Api/Handlers.hs b/plutip-server/Api/Handlers.hs index 7efb5c97..d001a6ef 100644 --- a/plutip-server/Api/Handlers.hs +++ b/plutip-server/Api/Handlers.hs @@ -6,16 +6,16 @@ module Api.Handlers ( import Cardano.Api (serialiseToCBOR) import Cardano.Launcher.Node (nodeSocketFile) import Cardano.Wallet.Shelley.Launch.Cluster (RunningNode (RunningNode)) +import Control.Arrow (left) import Control.Concurrent.MVar (isEmptyMVar, putMVar, tryTakeMVar) import Control.Monad (unless) -import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Except (ExceptT (ExceptT), runExceptT, throwError) import Control.Monad.Extra (unlessM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, ask, asks) import Data.ByteString.Base16 qualified as Base16 import Data.Default (def) import Data.Foldable (for_) -import Data.Text (Text) import Data.Text.Encoding qualified as Text import Data.Traversable (for) import System.Directory (doesFileExist) @@ -68,34 +68,34 @@ startClusterHandler isClusterDown <- liftIO $ isEmptyMVar statusMVar unless isClusterDown $ throwError ClusterIsRunningAlready let cfg = def {relayNodeLogs = nodeLogs, chainIndexPort = Nothing} - (statusTVar, (clusterEnv, ewallets)) <- liftIO $ startCluster cfg setup + (statusTVar, (clusterEnv, wallets)) <- liftIO $ startCluster cfg setup liftIO $ putMVar statusMVar statusTVar + waitForFundingTxs clusterEnv wallets let nodeConfigPath = getNodeConfigFile clusterEnv -- safeguard against directory tree structure changes unlessM (liftIO $ doesFileExist nodeConfigPath) $ throwError NodeConfigNotFound - case ewallets of - Left e -> throwError $ WaitingForFundedWalletsFailed e - Right wallets -> - pure $ - ClusterStartupSuccess $ - ClusterStartupParameters - { privateKeys = getWalletPrivateKey <$> wallets - , nodeSocketPath = getNodeSocketFile clusterEnv - , nodeConfigPath = nodeConfigPath - , keysDirectory = keysDir clusterEnv - } + pure $ + ClusterStartupSuccess $ + ClusterStartupParameters + { privateKeys = getWalletPrivateKey <$> wallets + , nodeSocketPath = getNodeSocketFile clusterEnv + , nodeConfigPath = nodeConfigPath + , keysDirectory = keysDir clusterEnv + } where - setup :: ReaderT ClusterEnv IO (ClusterEnv, Either Text [BpiWallet]) + setup :: ReaderT ClusterEnv IO (ClusterEnv, [BpiWallet]) setup = do - env <- ask wallets <- do for keysToGenerate $ \lovelaceAmounts -> do addSomeWallet (fromInteger . unLovelace <$> lovelaceAmounts) - waitRes <- for wallets $ \w -> awaitWalletFunded (cardanoMainnetAddress w) - case sequence_ waitRes of - Left e -> pure (env, Left e) - Right () -> do - pure $ (env, Right wallets) + env <- ask + return (env, wallets) + + -- wait for confirmation of funding txs, throw the first error if there's any + waitForFundingTxs clusterEnv wallets = + ExceptT . liftIO . fmap (left WaitingForFundedWalletsFailed . sequence_) $ + for wallets $ \w -> + awaitWalletFunded clusterEnv (cardanoMainnetAddress w) getNodeSocketFile (runningNode -> RunningNode conn _ _ _) = nodeSocketFile conn getNodeConfigFile = diff --git a/plutip-server/Types.hs b/plutip-server/Types.hs index 22a486c1..1252e8de 100644 --- a/plutip-server/Types.hs +++ b/plutip-server/Types.hs @@ -48,7 +48,7 @@ import UnliftIO.STM (TVar) -- cluster at any given moment). -- This MVar is used by start/stop handlers. -- The payload of ClusterStatus is irrelevant. -type ClusterStatusRef = MVar (TVar (ClusterStatus (ClusterEnv, Either Text [BpiWallet]))) +type ClusterStatusRef = MVar (TVar (ClusterStatus (ClusterEnv, [BpiWallet]))) data Env = Env { status :: ClusterStatusRef diff --git a/src/Test/Plutip/Tools/CardanoApi.hs b/src/Test/Plutip/Tools/CardanoApi.hs index 53387fcb..5c2bf42c 100644 --- a/src/Test/Plutip/Tools/CardanoApi.hs +++ b/src/Test/Plutip/Tools/CardanoApi.hs @@ -14,8 +14,6 @@ import Cardano.Slotting.Slot (WithOrigin) import Cardano.Wallet.Shelley.Launch.Cluster (RunningNode (RunningNode)) import Control.Arrow (right) import Control.Exception (Exception) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ReaderT, ask) import Control.Retry (constantDelay, limitRetries, retrying) import Data.Either (fromRight) import Data.Map qualified as M @@ -85,18 +83,17 @@ flattenQueryResult = \case -- Performs 20 tries with 0.2 seconds between tries, which should be a sane default. -- Waits till there's any utxos at an address - works for us as funds will be send with tx per address. awaitWalletFunded :: + ClusterEnv -> C.AddressAny -> - ReaderT ClusterEnv IO (Either Text ()) -awaitWalletFunded addr = toErrorMsg <$> retrying policy checkResponse action + IO (Either Text ()) +awaitWalletFunded cenv addr = toErrorMsg <$> retrying policy checkResponse action where -- With current defaults the slot length is 0.2s and block gets produced about every second slot. -- We are expected to wait 0.4s, waiting 4s we are almost guaranteed (p>0.9999) delay = 200_000 -- in microseconds, 0.2s. policy = constantDelay delay <> limitRetries 20 - action _ = do - cenv <- ask - liftIO $ right (M.null . C.unUTxO) <$> utxosAtAddress cenv addr + action _ = right (M.null . C.unUTxO) <$> utxosAtAddress cenv addr checkResponse _ = return . fromRight False From 72888d34af132141f63ee920cadbe343d5ce3146 Mon Sep 17 00:00:00 2001 From: zmrocze Date: Fri, 25 Nov 2022 15:32:52 +0100 Subject: [PATCH 5/7] Retry failed cluster startup --- src/Test/Plutip/Internal/LocalCluster.hs | 32 +++++++++++++++++------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/src/Test/Plutip/Internal/LocalCluster.hs b/src/Test/Plutip/Internal/LocalCluster.hs index b631b1ab..726ead99 100644 --- a/src/Test/Plutip/Internal/LocalCluster.hs +++ b/src/Test/Plutip/Internal/LocalCluster.hs @@ -25,7 +25,7 @@ import Control.Monad (unless, void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader (ReaderT (runReaderT)) -import Control.Retry (constantDelay, limitRetries, recoverAll) +import Control.Retry (constantDelay, limitRetries, recoverAll, recovering, logRetries) import Control.Tracer (Tracer, contramap, traceWith) import Data.Foldable (for_) import Data.Kind (Type) @@ -44,7 +44,7 @@ import System.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, d import System.Environment (setEnv) import System.Exit (die) import System.FilePath (()) -import System.IO (IOMode (WriteMode), hClose, openFile, stdout) +import System.IO (IOMode (WriteMode), hClose, openFile, stdout, stderr) import Test.Plutip.Config ( PlutipConfig ( chainIndexPort, @@ -72,6 +72,8 @@ import Text.Printf (printf) import UnliftIO.Concurrent (forkFinally, myThreadId, throwTo) import UnliftIO.Exception (bracket, catchIO, finally) import UnliftIO.STM (TVar, atomically, newTVarIO, readTVar, retrySTM, writeTVar) +import Cardano.Launcher (ProcessHasExited(ProcessHasExited)) +import qualified Data.ByteString.Char8 as B -- | Starting a cluster with a setup action -- We're heavily depending on cardano-wallet local cluster tooling, however they don't allow the @@ -115,18 +117,18 @@ withPlutusInterface :: forall (a :: Type). PlutipConfig -> (ClusterEnv -> IO a) withPlutusInterface conf action = do -- current setup requires `cardano-node` and `cardano-cli` as external processes checkProcessesAvailable ["cardano-node", "cardano-cli"] - withLocalClusterSetup conf $ \dir clusterLogs _walletLogs nodeConfigLogHdl -> do result <- withLoggingNamed "cluster" clusterLogs $ \(_, (_, trCluster)) -> do let tr' = contramap MsgCluster $ trMessageText trCluster clusterCfg <- localClusterConfigFromEnv withRedirectedStdoutHdl nodeConfigLogHdl $ \restoreStdout -> - withCluster - tr' - dir - clusterCfg - [] - (\rn -> restoreStdout $ runActionWthSetup rn dir trCluster action) + retryClusterFailedStartup $ + withCluster + tr' + dir + clusterCfg + [] + (\rn -> restoreStdout $ runActionWthSetup rn dir trCluster action) handleLogs dir conf return result where @@ -149,6 +151,18 @@ withPlutusInterface conf action = do BotSetup.runSetup cEnv -- run preparations to use `bot-plutus-interface` userAction cEnv `finally` cancel runningChainIndex -- executing user action on cluster + -- | withCluster has a race condition between checking for available ports and claiming the ports. + -- This may cause failure at the cluster startup (the "resource busy (Address already in use)" error) + -- Given this is rare and the problem root sits in cardano-wallet, lets simply retry the startup few times full of hope. + retryClusterFailedStartup = + let msg err = B.pack $ "Retrying cluster startup due to: " <> show err <> "\n" + shouldRetry = pure . \case + ProcessHasExited _ _ -> True + _ -> False + in recovering (limitRetries 5) + [logRetries shouldRetry (\_ y _ -> B.hPutStr stderr $ msg y)] + . const + -- Redirect stdout to a provided handle providing mask to temporarily revert back to initial stdout. withRedirectedStdoutHdl :: Handle -> ((forall b. IO b -> IO b) -> IO a) -> IO a withRedirectedStdoutHdl hdl action = do From 2bd26dbccde21c901aaf2bd28b519aaf62d3fd6b Mon Sep 17 00:00:00 2001 From: zmrocze Date: Sun, 27 Nov 2022 15:15:06 +0100 Subject: [PATCH 6/7] Ignore waiting for funding timeout --- plutip-server/Api/Handlers.hs | 30 ++++++++++++++++-------- plutip-server/Types.hs | 4 +--- src/Test/Plutip/Internal/LocalCluster.hs | 26 ++++++++++---------- src/Test/Plutip/Tools/CardanoApi.hs | 17 ++++++++++---- 4 files changed, 47 insertions(+), 30 deletions(-) diff --git a/plutip-server/Api/Handlers.hs b/plutip-server/Api/Handlers.hs index d001a6ef..99468dac 100644 --- a/plutip-server/Api/Handlers.hs +++ b/plutip-server/Api/Handlers.hs @@ -6,16 +6,16 @@ module Api.Handlers ( import Cardano.Api (serialiseToCBOR) import Cardano.Launcher.Node (nodeSocketFile) import Cardano.Wallet.Shelley.Launch.Cluster (RunningNode (RunningNode)) -import Control.Arrow (left) import Control.Concurrent.MVar (isEmptyMVar, putMVar, tryTakeMVar) import Control.Monad (unless) -import Control.Monad.Except (ExceptT (ExceptT), runExceptT, throwError) +import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Extra (unlessM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, ask, asks) import Data.ByteString.Base16 qualified as Base16 import Data.Default (def) import Data.Foldable (for_) +import Data.List.Extra (firstJust) import Data.Text.Encoding qualified as Text import Data.Traversable (for) import System.Directory (doesFileExist) @@ -26,14 +26,13 @@ import Test.Plutip.Internal.BotPlutusInterface.Wallet (BpiWallet (signKey), addS import Test.Plutip.Internal.LocalCluster (startCluster, stopCluster) import Test.Plutip.Internal.Types (ClusterEnv (runningNode)) import Test.Plutip.LocalCluster (cardanoMainnetAddress) -import Test.Plutip.Tools.CardanoApi (awaitWalletFunded) +import Test.Plutip.Tools.CardanoApi (AwaitWalletFundedError (AwaitingCapiError, AwaitingTimeoutError), awaitWalletFunded) import Types ( AppM, ClusterStartupFailureReason ( ClusterIsRunningAlready, NegativeLovelaces, - NodeConfigNotFound, - WaitingForFundedWalletsFailed + NodeConfigNotFound ), ClusterStartupParameters ( ClusterStartupParameters, @@ -54,6 +53,7 @@ import Types ( StopClusterRequest (StopClusterRequest), StopClusterResponse (StopClusterFailure, StopClusterSuccess), ) +import UnliftIO.Exception (throwString) startClusterHandler :: ServerOptions -> StartClusterRequest -> AppM StartClusterResponse startClusterHandler @@ -70,7 +70,10 @@ startClusterHandler let cfg = def {relayNodeLogs = nodeLogs, chainIndexPort = Nothing} (statusTVar, (clusterEnv, wallets)) <- liftIO $ startCluster cfg setup liftIO $ putMVar statusMVar statusTVar - waitForFundingTxs clusterEnv wallets + res <- liftIO $ waitForFundingTxs clusterEnv wallets + -- throw Exception for cardano-cli errors. + -- Ignore wait timeout error - return from this handler doesn't guarantee funded wallets immedietely. + maybe (return ()) throwString res let nodeConfigPath = getNodeConfigFile clusterEnv -- safeguard against directory tree structure changes unlessM (liftIO $ doesFileExist nodeConfigPath) $ throwError NodeConfigNotFound @@ -92,10 +95,17 @@ startClusterHandler return (env, wallets) -- wait for confirmation of funding txs, throw the first error if there's any - waitForFundingTxs clusterEnv wallets = - ExceptT . liftIO . fmap (left WaitingForFundedWalletsFailed . sequence_) $ - for wallets $ \w -> - awaitWalletFunded clusterEnv (cardanoMainnetAddress w) + waitForFundingTxs clusterEnv wallets = do + res <- for wallets $ \w -> + awaitWalletFunded clusterEnv (cardanoMainnetAddress w) + return $ + firstJust + ( \case + Left (AwaitingCapiError e) -> Just $ show e + Left AwaitingTimeoutError -> Nothing + Right () -> Nothing + ) + res getNodeSocketFile (runningNode -> RunningNode conn _ _ _) = nodeSocketFile conn getNodeConfigFile = diff --git a/plutip-server/Types.hs b/plutip-server/Types.hs index 1252e8de..e8be5143 100644 --- a/plutip-server/Types.hs +++ b/plutip-server/Types.hs @@ -3,8 +3,7 @@ module Types ( ClusterStartupFailureReason ( ClusterIsRunningAlready, NegativeLovelaces, - NodeConfigNotFound, - WaitingForFundedWalletsFailed + NodeConfigNotFound ), Env (Env, status, options), ErrorMessage, @@ -105,7 +104,6 @@ data ClusterStartupFailureReason = ClusterIsRunningAlready | NegativeLovelaces | NodeConfigNotFound - | WaitingForFundedWalletsFailed Text deriving stock (Show, Eq, Generic) deriving anyclass (FromJSON, ToJSON) diff --git a/src/Test/Plutip/Internal/LocalCluster.hs b/src/Test/Plutip/Internal/LocalCluster.hs index 726ead99..94721da1 100644 --- a/src/Test/Plutip/Internal/LocalCluster.hs +++ b/src/Test/Plutip/Internal/LocalCluster.hs @@ -15,6 +15,7 @@ import Cardano.BM.Configuration.Model qualified as CM import Cardano.BM.Data.Severity qualified as Severity import Cardano.BM.Data.Tracer (HasPrivacyAnnotation, HasSeverityAnnotation (getSeverityAnnotation)) import Cardano.CLI (LogOutput (LogToFile), withLoggingNamed) +import Cardano.Launcher (ProcessHasExited (ProcessHasExited)) import Cardano.Launcher.Node (nodeSocketFile) import Cardano.Startup (installSignalHandlers, setDefaultFilePermissions, withUtf8Encoding) import Cardano.Wallet.Logging (stdoutTextTracer, trMessageText) @@ -25,8 +26,9 @@ import Control.Monad (unless, void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader (ReaderT (runReaderT)) -import Control.Retry (constantDelay, limitRetries, recoverAll, recovering, logRetries) +import Control.Retry (constantDelay, limitRetries, logRetries, recoverAll, recovering) import Control.Tracer (Tracer, contramap, traceWith) +import Data.ByteString.Char8 qualified as B import Data.Foldable (for_) import Data.Kind (Type) import Data.Maybe (catMaybes, fromMaybe, isJust) @@ -44,7 +46,7 @@ import System.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, d import System.Environment (setEnv) import System.Exit (die) import System.FilePath (()) -import System.IO (IOMode (WriteMode), hClose, openFile, stdout, stderr) +import System.IO (IOMode (WriteMode), hClose, openFile, stderr, stdout) import Test.Plutip.Config ( PlutipConfig ( chainIndexPort, @@ -72,8 +74,6 @@ import Text.Printf (printf) import UnliftIO.Concurrent (forkFinally, myThreadId, throwTo) import UnliftIO.Exception (bracket, catchIO, finally) import UnliftIO.STM (TVar, atomically, newTVarIO, readTVar, retrySTM, writeTVar) -import Cardano.Launcher (ProcessHasExited(ProcessHasExited)) -import qualified Data.ByteString.Char8 as B -- | Starting a cluster with a setup action -- We're heavily depending on cardano-wallet local cluster tooling, however they don't allow the @@ -151,17 +151,19 @@ withPlutusInterface conf action = do BotSetup.runSetup cEnv -- run preparations to use `bot-plutus-interface` userAction cEnv `finally` cancel runningChainIndex -- executing user action on cluster - -- | withCluster has a race condition between checking for available ports and claiming the ports. + -- withCluster has a race condition between checking for available ports and claiming the ports. -- This may cause failure at the cluster startup (the "resource busy (Address already in use)" error) -- Given this is rare and the problem root sits in cardano-wallet, lets simply retry the startup few times full of hope. - retryClusterFailedStartup = + retryClusterFailedStartup = let msg err = B.pack $ "Retrying cluster startup due to: " <> show err <> "\n" - shouldRetry = pure . \case - ProcessHasExited _ _ -> True - _ -> False - in recovering (limitRetries 5) - [logRetries shouldRetry (\_ y _ -> B.hPutStr stderr $ msg y)] - . const + shouldRetry = + pure . \case + ProcessHasExited _ _ -> True + _ -> False + in recovering + (limitRetries 5) + [logRetries shouldRetry (\_ y _ -> B.hPutStr stderr $ msg y)] + . const -- Redirect stdout to a provided handle providing mask to temporarily revert back to initial stdout. withRedirectedStdoutHdl :: Handle -> ((forall b. IO b -> IO b) -> IO a) -> IO a diff --git a/src/Test/Plutip/Tools/CardanoApi.hs b/src/Test/Plutip/Tools/CardanoApi.hs index 5c2bf42c..3be4f69d 100644 --- a/src/Test/Plutip/Tools/CardanoApi.hs +++ b/src/Test/Plutip/Tools/CardanoApi.hs @@ -5,6 +5,7 @@ module Test.Plutip.Tools.CardanoApi ( queryProtocolParams, queryTip, awaitWalletFunded, + AwaitWalletFundedError (AwaitingCapiError, AwaitingTimeoutError), ) where import Cardano.Api qualified as C @@ -18,8 +19,6 @@ import Control.Retry (constantDelay, limitRetries, retrying) import Data.Either (fromRight) import Data.Map qualified as M import Data.Set qualified as Set -import Data.Text (Text) -import Data.Text qualified as T import GHC.Generics (Generic) import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure) @@ -79,13 +78,21 @@ flattenQueryResult = \case Right (Right res) -> Right res err -> Left $ SomeError (show err) +data AwaitWalletFundedError + = AwaitingCapiError CardanoApiError + | AwaitingTimeoutError + +instance Show AwaitWalletFundedError where + show (AwaitingCapiError (SomeError e)) = e + show AwaitingTimeoutError = "Awaiting funding transaction timed out." + -- | Waits till specified address is funded using cardano-node query. -- Performs 20 tries with 0.2 seconds between tries, which should be a sane default. -- Waits till there's any utxos at an address - works for us as funds will be send with tx per address. awaitWalletFunded :: ClusterEnv -> C.AddressAny -> - IO (Either Text ()) + IO (Either AwaitWalletFundedError ()) awaitWalletFunded cenv addr = toErrorMsg <$> retrying policy checkResponse action where -- With current defaults the slot length is 0.2s and block gets produced about every second slot. @@ -98,8 +105,8 @@ awaitWalletFunded cenv addr = toErrorMsg <$> retrying policy checkResponse actio checkResponse _ = return . fromRight False toErrorMsg = \case - Left (SomeError e) -> Left $ T.pack e + Left e -> Left $ AwaitingCapiError e Right noUtxos -> if noUtxos - then Left "Funding transaction wasn't submitted yet and we're done waiting." + then Left AwaitingTimeoutError else Right () From 1c9dd05697d7cf55de8ca26f0756a75ed821bdfb Mon Sep 17 00:00:00 2001 From: zmrocze Date: Sun, 27 Nov 2022 15:55:43 +0100 Subject: [PATCH 7/7] Limit waiting for funding to 2s --- plutip-server/Api/Handlers.hs | 7 +++++-- plutip.cabal | 1 + 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/plutip-server/Api/Handlers.hs b/plutip-server/Api/Handlers.hs index 99468dac..fcebe93f 100644 --- a/plutip-server/Api/Handlers.hs +++ b/plutip-server/Api/Handlers.hs @@ -6,6 +6,8 @@ module Api.Handlers ( import Cardano.Api (serialiseToCBOR) import Cardano.Launcher.Node (nodeSocketFile) import Cardano.Wallet.Shelley.Launch.Cluster (RunningNode (RunningNode)) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race) import Control.Concurrent.MVar (isEmptyMVar, putMVar, tryTakeMVar) import Control.Monad (unless) import Control.Monad.Except (runExceptT, throwError) @@ -14,6 +16,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, ask, asks) import Data.ByteString.Base16 qualified as Base16 import Data.Default (def) +import Data.Either (fromRight) import Data.Foldable (for_) import Data.List.Extra (firstJust) import Data.Text.Encoding qualified as Text @@ -70,10 +73,10 @@ startClusterHandler let cfg = def {relayNodeLogs = nodeLogs, chainIndexPort = Nothing} (statusTVar, (clusterEnv, wallets)) <- liftIO $ startCluster cfg setup liftIO $ putMVar statusMVar statusTVar - res <- liftIO $ waitForFundingTxs clusterEnv wallets + res <- liftIO $ race (threadDelay 2_000_000) $ waitForFundingTxs clusterEnv wallets -- throw Exception for cardano-cli errors. -- Ignore wait timeout error - return from this handler doesn't guarantee funded wallets immedietely. - maybe (return ()) throwString res + maybe (return ()) throwString $ fromRight Nothing res let nodeConfigPath = getNodeConfigFile clusterEnv -- safeguard against directory tree structure changes unlessM (liftIO $ doesFileExist nodeConfigPath) $ throwError NodeConfigNotFound diff --git a/plutip.cabal b/plutip.cabal index 39cf916c..805d9722 100644 --- a/plutip.cabal +++ b/plutip.cabal @@ -203,6 +203,7 @@ executable plutip-server default-language: Haskell2010 build-depends: , aeson + , async , base , base16-bytestring , bytestring