diff --git a/src/Internal/Spawn.purs b/src/Internal/Spawn.purs index b208b0a52..f4f65c05a 100644 --- a/src/Internal/Spawn.purs +++ b/src/Internal/Spawn.purs @@ -90,13 +90,15 @@ spawn' cmd args opts mbFilter cont = do child <- ChildProcess.spawn cmd args opts let fullCmd = cmd <> foldMap (" " <> _) args closedAVar <- AVar.empty - interface <- RL.createInterface (stdout child) mempty + stdoutInterfaceRef <- Ref.new Nothing stderrInterface <- RL.createInterface (stderr child) mempty flip RL.setLineHandler stderrInterface \str -> do traceM $ "stderr: " <> str outputRef <- Ref.new "" ChildProcess.onClose child \code -> do - RL.close interface + stdoutInterface <- Ref.read stdoutInterfaceRef + traverse_ RL.close stdoutInterface + RL.close stderrInterface void $ AVar.tryPut code closedAVar output <- Ref.read outputRef cont $ Left $ error @@ -113,16 +115,18 @@ spawn' cmd args opts mbFilter cont = do case mbFilter of Nothing -> cont (pure mp) Just filter -> do - flip RL.setLineHandler interface + stdoutInterface <- RL.createInterface (stdout child) mempty + Ref.write (Just stdoutInterface) stdoutInterfaceRef + flip RL.setLineHandler stdoutInterface \str -> do output <- Ref.modify (_ <> str <> "\n") outputRef filter { output, line: str } >>= case _ of Success -> do - clearLineHandler interface + clearLineHandler stdoutInterface cont (pure mp) Cancel -> do kill SIGINT child - clearLineHandler interface + clearLineHandler stdoutInterface cont $ Left $ error $ "Process cancelled because output received: " <> str diff --git a/src/Internal/Testnet/Server.purs b/src/Internal/Testnet/Server.purs index 5611f445f..c38444eb2 100644 --- a/src/Internal/Testnet/Server.purs +++ b/src/Internal/Testnet/Server.purs @@ -55,7 +55,6 @@ import Ctl.Internal.Testnet.Utils , suppressAndLogErrors , tmpdirUnique , tryAndLogErrors - , waitFor , waitForClose , waitForError , waitForEvent @@ -66,15 +65,16 @@ import Data.Array (head) as Array import Data.Log.Message (Message) import Data.Maybe (Maybe(Nothing, Just)) import Data.Set as Set -import Data.String (stripPrefix, trim) as String +import Data.String (split, stripPrefix, trim) as String import Data.String.CodeUnits (indexOf) as String import Data.String.Pattern (Pattern(Pattern)) import Data.Time.Duration (Milliseconds(Milliseconds)) import Data.UInt (UInt) import Data.UInt (toString) as UInt +import Effect.AVar (tryPut) as AVarSync import Effect.Aff (Aff) import Effect.Aff as Aff -import Effect.Aff.Class (class MonadAff) +import Effect.Aff.AVar (empty, take) as AVar import Effect.Aff.Retry ( RetryPolicy , constantDelay @@ -82,17 +82,19 @@ import Effect.Aff.Retry , recovering ) import Effect.Class (class MonadEffect) +import Effect.Console (log) import Effect.Exception (Error, error, throw) import Effect.Ref (Ref) import Effect.Ref (modify_, new) as Ref import Foreign.Object as Object -import Node.ChildProcess (defaultSpawnOptions) +import Node.ChildProcess (defaultSpawnOptions, stdout) import Node.ChildProcess as Node.ChildProcess import Node.Encoding (Encoding(UTF8)) import Node.FS.Sync (readdir) as FSSync import Node.FS.Sync as Node.FS import Node.Path (FilePath) import Node.Process as Node.Process +import Node.Stream (onDataString) type Channels a = { stderr :: EventSource a @@ -322,20 +324,41 @@ startCardanoTestnet } startCardanoTestnet params cleanupRef = annotateError "startCardanoTestnet" do workdir <- tmpdirUnique "cardano-testnet" - testnet <- scheduleCleanup + testnet@(ManagedProcess _ testnetProcess _) <- scheduleCleanup cleanupRef (spawnCardanoTestnet workdir params) stopProcessWithChildren - channels <- liftEffect $ getChannels testnet + + workspaceFromLogsAvar <- AVar.empty + liftEffect $ onDataString (stdout testnetProcess) UTF8 \str -> do + let lines = String.split (Pattern "\n") str + traverse_ + ( \line -> do + log $ "[cardano-testnet:stdout] " <> line + let + mWorkspace = String.stripPrefix (Pattern "Workspace: ") $ + String.trim line + maybe (pure unit) + (void <<< flip AVarSync.tryPut workspaceFromLogsAvar) + mWorkspace + ) + lines + workspace <- waitUntil (Milliseconds 100.0) $ findWorkspaceDir workdir + -- Schedule a cleanup immediately after the workspace + -- directory is created. scheduleWorkspaceCleanup workspace - redirectStreams channels workspace - workspaceFromLogs <- waitForCardanoTestnetWorkspace channels.stdout + -- Wait for cardano-testnet to output the workspace, indicating + -- that initialization is complete. + workspaceFromLogs <- AVar.take workspaceFromLogsAvar + when (workspace /= workspaceFromLogs) do runCleanup cleanupRef + -- this error should never happen throwError $ error "cardano-testnet workspace mismatch" + + channels <- liftEffect $ getChannels testnet attachStdoutMonitors testnet - log "startCardanoTestnet:done" pure { testnet, workdirAbsolute: workspace, channels } where findWorkspaceDir :: forall m. MonadEffect m => FilePath -> m (Maybe FilePath) @@ -343,29 +366,6 @@ startCardanoTestnet params cleanupRef = annotateError "startCardanoTestnet" do liftEffect $ map (concatPaths workdir) <<< Array.head <$> FSSync.readdir workdir - redirectStreams :: StdStreams -> FilePath -> Aff Unit - redirectStreams channels workspace = - void $ redirectChannels channels - { stdoutTo: - { log: Just $ workspace <> "cardano-testnet.stdout.log" - , console: Nothing - } - , stderrTo: - { log: Just $ workspace <> "cardano-testnet.stderr.log" - , console: Nothing - } - } - - waitForCardanoTestnetWorkspace - :: forall m - . MonadAff m - => EventSource String - -> m FilePath - waitForCardanoTestnetWorkspace = - liftAff - <<< flip waitFor - (String.stripPrefix (Pattern "Workspace: ") <<< String.trim) - attachStdoutMonitors :: ManagedProcess -> Aff Unit attachStdoutMonitors testnet = void $ Aff.forkAff $ @@ -588,8 +588,3 @@ stopChildProcessWithPort port childProcess = do defaultRetryPolicy :: RetryPolicy defaultRetryPolicy = limitRetriesByCumulativeDelay (Milliseconds 3000.00) $ constantDelay (Milliseconds 100.0) - --- replace with Effect.Console.log to debug. Not providing an option at runtime, --- because it's just for the CTL developers. -log :: forall m. Monad m => String -> m Unit -log _ = pure unit