Add test executable to local-cluster

.buildkite/pipeline.yml

@@ -58,11 +58,15 @@ steps:
   - label: Run local-cluster tests
     key: local-cluster-tests
     depends_on: linux-nix
-    command: nix shell .#local-cluster -c cabal test -O0 local-cluster
+    command: |
+      mkdir local-cluster-logs
+      nix shell "nixpkgs#just" -c just test-local-cluster
     agents:
       system: ${linux}
+    artifact_paths: [ "./local-cluster-logs/**" ]
     env:
       TMPDIR: "/cache"
+      CLUSTER_LOGS_DIR_PATH: local-cluster-logs
 
   - label: "Babbage integration tests (linux)"
     key: linux-tests-integration-babbage

flake.nix

@@ -239,6 +239,7 @@
                 inherit (project.hsPkgs.cardano-wallet.components.exes) mock-token-metadata-server;
                 inherit (project.hsPkgs.local-cluster.components.exes) local-cluster;
                 inherit (project.hsPkgs.cardano-wallet-integration.components.exes) integration-exe;
+                inherit (project.hsPkgs.local-cluster.components.exes) test-local-cluster-exe;
 
                 # Adrestia tool belt
                 inherit (project.hsPkgs.bech32.components.exes) bech32;

justfile

@@ -141,3 +141,13 @@ conway-integration-tests:
 latency-bench:
    cabal run -O2 -v0 cardano-wallet-benchmarks:latency -- \
    --cluster-configs lib/local-cluster/test/data/cluster-configs
+
+test-local-cluster:
+    LOCAL_CLUSTER_CONFIGS=lib/local-cluster/test/data/cluster-configs \
+    nix shell \
+        '.#local-cluster' \
+        '.#test-local-cluster-exe' \
+        '.#cardano-cli' \
+        '.#cardano-node' \
+        '.#cardano-wallet' \
+        -c test-local-cluster-exe

lib/launcher/src/Cardano/Launcher.hs

@@ -21,6 +21,8 @@ module Cardano.Launcher
     , ProcessHasExited(..)
     , withBackendProcess
     , withBackendCreateProcess
+    , IfToSendSigINT (..)
+    , TimeoutInSecs (..)
 
     -- * Logging
     , LauncherLog(..)
@@ -88,6 +90,10 @@ import System.Exit
 import System.IO
     ( Handle
     )
+import System.Posix
+    ( sigINT
+    , signalProcess
+    )
 import System.Process
     ( cleanupProcess
     , getPid
@@ -191,6 +197,14 @@ data ProcessHasExited
 
 instance Exception ProcessHasExited
 
+-- | Whether to send a SIGINT to the process before cleanup
+data IfToSendSigINT = SendSigINT | DoNotSendSigINT
+
+-- | Timeout in seconds to wait before killing the process, after termination
+-- Do not use NoTimeout if you are not sure the process will terminate with
+-- SIGTERM / SIGINT
+data TimeoutInSecs = NoTimeout | TimeoutInSecs Int
+
 data ProcessHandles = ProcessHandles
     { inputHandle :: Maybe Handle
     , outputHandle :: Maybe Handle
@@ -209,13 +223,23 @@ withBackendProcess
     -- ^ Logging
     -> Command
     -- ^ 'Command' description
+    -> TimeoutInSecs
+    -- ^ Seconds to wait before killing the process, after termination
+    -> IfToSendSigINT
+    -- ^ Whether to send a sigINT to the process before clenup
     -> (ProcessHandles -> m a)
     -- ^ Action to execute while process is running.
     -> m a
-withBackendProcess tr (Command name args before std_in std_out) action =
-    liftIO before >> withBackendCreateProcess tr process action
-  where
-    process = (proc name args) { std_in, std_out, std_err = std_out }
+withBackendProcess
+    tr
+    (Command name args before std_in std_out)
+    mTimeoutSecs
+    ifToSendSigINT
+    action = do
+        liftIO before
+        withBackendCreateProcess tr process mTimeoutSecs ifToSendSigINT action
+      where
+        process = (proc name args){std_in, std_out, std_err = std_out}
 
 -- | A variant of 'withBackendProcess' which accepts a general 'CreateProcess'
 -- object. This version also has nicer async properties than
@@ -237,27 +261,35 @@ withBackendProcess tr (Command name args before std_in std_out) action =
 -- 'System.Process.Typed.withProcessWait' (except for wait timeout). The
 -- launcher code should be converted to use @typed-process@.
 withBackendCreateProcess
-    :: forall m a. (MonadUnliftIO m)
+    :: forall m a
+     . MonadUnliftIO m
     => Tracer m LauncherLog
     -- ^ Logging
     -> CreateProcess
     -- ^ 'Command' description
+    -> TimeoutInSecs
+    -- ^ Seconds to wait before killing the process, after termination
+    -> IfToSendSigINT
+    -- ^ Whether to send a sigINT to the process before clenup
     -> (ProcessHandles -> m a)
     -- ^ Action to execute while process is running.
     -> m a
-withBackendCreateProcess tr process action = do
+withBackendCreateProcess tr process mTimeoutSecs ifToSendSigINT action = do
     traceWith tr $ MsgLauncherStart name args
     exitVar <- newEmptyMVar
-    res <- fmap join $ tryJust spawnPredicate $ bracket
-        (createProcess process)
-        (cleanupProcessAndWait (readMVar exitVar)) $
-            \(mstdin, mstdout, mstderr, ph) -> do
-                pid <- maybe "-" (T.pack . show) <$> liftIO (getPid ph)
-                let tr' = contramap (WithProcessInfo name pid) tr
-                let tr'' = contramap MsgLauncherWait tr'
-                traceWith tr' MsgLauncherStarted
-                interruptibleWaitForProcess tr'' ph (putMVar exitVar)
-                race (ProcessHasExited name <$> readMVar exitVar) $ bracket_
+    res <- fmap join
+        $ tryJust spawnPredicate
+        $ bracket
+            (createProcess process)
+            (cleanupProcessAndWait (readMVar exitVar))
+        $ \(mstdin, mstdout, mstderr, ph) -> do
+            pid <- maybe "-" (T.pack . show) <$> liftIO (getPid ph)
+            let tr' = contramap (WithProcessInfo name pid) tr
+            let tr'' = contramap MsgLauncherWait tr'
+            traceWith tr' MsgLauncherStarted
+            interruptibleWaitForProcess tr'' ph (putMVar exitVar)
+            race (ProcessHasExited name <$> readMVar exitVar)
+                $ bracket_
                     (traceWith tr' MsgLauncherAction)
                     (traceWith tr' MsgLauncherActionDone)
                     (action $ ProcessHandles mstdin mstdout mstderr ph)
@@ -279,16 +311,22 @@ withBackendCreateProcess tr process action = do
      -- doesn't exit after timeout, kill it, to avoid blocking indefinitely.
     cleanupProcessAndWait getExitStatus ps@(_, _, _, ph) = do
         traceWith tr MsgLauncherCleanup
+        -- we also send a sigINT to the process to make sure it terminates
+        case ifToSendSigINT of
+            SendSigINT -> liftIO $ getPid ph >>= mapM_ (signalProcess sigINT)
+            DoNotSendSigINT -> pure ()
         liftIO $ cleanupProcess ps
-        let timeoutSecs = 5
         -- Async exceptions are currently masked because this is running in a
         -- bracket cleanup handler. We fork a thread and unmask so that the
         -- timeout can be cancelled.
-        tid <- forkIOWithUnmask $ \unmask -> unmask $ do
-            threadDelay (timeoutSecs * 1000 * 1000)
-            traceWith tr (MsgLauncherCleanupTimedOut timeoutSecs)
-            liftIO (getPid ph >>= mapM_ killProcess)
-        void getExitStatus `finally` killThread tid
+        void $ case mTimeoutSecs of
+            NoTimeout -> getExitStatus
+            TimeoutInSecs timeoutSecs -> do
+                tid <- forkIOWithUnmask $ \unmask -> unmask $ do
+                    threadDelay (timeoutSecs * 1000 * 1000)
+                    traceWith tr (MsgLauncherCleanupTimedOut timeoutSecs)
+                    liftIO (getPid ph >>= mapM_ killProcess)
+                getExitStatus `finally` killThread tid
         traceWith tr MsgLauncherCleanupFinished
 
     -- Wraps 'waitForProcess' in another thread. This works around the unwanted

lib/launcher/src/Cardano/Launcher/Node.hs

@@ -1,12 +1,12 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE TupleSections #-}
+
 -- |
 -- Copyright: © 2018-2020 IOHK
 -- License: Apache-2.0
 --
 -- Provides a function to launch @cardano-node@.
-
 module Cardano.Launcher.Node
     ( -- * Startup
       withCardanoNode
@@ -16,21 +16,23 @@ module Cardano.Launcher.Node
     , maybeFromMaybeK
     , NodePort (..)
 
-    -- * cardano-node Snockets
+      -- * cardano-node Snockets
     , CardanoNodeConn
     , cardanoNodeConn
     , nodeSocketFile
     , isWindows
 
-    -- * Helpers
+      -- * Helpers
     , nodeSocketPath
     ) where
 
 import Prelude
 
 import Cardano.Launcher
-    ( LauncherLog
+    ( IfToSendSigINT (..)
+    , LauncherLog
     , StdStream (..)
+    , TimeoutInSecs (..)
     , withBackendCreateProcess
     )
 import Control.Tracer
@@ -90,19 +92,22 @@ nodeSocketFile (CardanoNodeConn name) = name
 -- 'isWindows') is valid.
 cardanoNodeConn :: FilePath -> Either String CardanoNodeConn
 cardanoNodeConn name
-    | isWindows = if isValidWindowsPipeName name
-        then Right $ CardanoNodeConn name
-        else Left "Invalid pipe name."
-    | otherwise = if isValid name
-        then Right $ CardanoNodeConn name
-        else Left "Invalid file path."
+    | isWindows =
+        if isValidWindowsPipeName name
+            then Right $ CardanoNodeConn name
+            else Left "Invalid pipe name."
+    | otherwise =
+        if isValid name
+            then Right $ CardanoNodeConn name
+            else Left "Invalid file path."
 
 isWindows :: Bool
 isWindows = os == "mingw32"
 
 isValidWindowsPipeName :: FilePath -> Bool
-isValidWindowsPipeName name = slashPipe `isPrefixOf` name
-    && isValid (drop (length slashPipe) name)
+isValidWindowsPipeName name =
+    slashPipe `isPrefixOf` name
+        && isValid (drop (length slashPipe) name)
   where
     slashPipe = "\\\\.\\pipe\\"
 
@@ -112,7 +117,7 @@ instance ToText CardanoNodeConn where
 instance FromText CardanoNodeConn where
     fromText = first TextDecodingError . cardanoNodeConn . T.unpack
 
-newtype NodePort = NodePort { unNodePort :: Int }
+newtype NodePort = NodePort {unNodePort :: Int}
     deriving (Show, Eq)
 
 -- | A subset of the @cardano-node@ CLI parameters, used for starting the
@@ -150,7 +155,7 @@ withCardanoNode tr cfg action = do
     let socketPath = nodeSocketPathFile cfg
     let run output = do
             cp <- cardanoNodeProcess cfg output
-            withBackendCreateProcess tr cp
+            withBackendCreateProcess tr cp (TimeoutInSecs 4) SendSigINT
                 $ \_ -> action $ fmap CardanoNodeConn socketPath
     case nodeOutputFile cfg of
         Nothing -> run Inherit
@@ -185,7 +190,8 @@ cardanoNodeProcess cfg output = do
         , "--database-path"
         , nodeDatabaseDir cfg
         ]
-            <> maybe []
+            <> maybe
+                []
                 (\p -> ["--socket-path", p])
                 (maybeFromMaybeK $ nodeSocketPathFile cfg)
             <> opt "--port" (show . unNodePort <$> nodePort cfg)

lib/launcher/src/Cardano/Launcher/Wallet.hs

@@ -19,7 +19,9 @@ module Cardano.Launcher.Wallet
 import Prelude
 
 import Cardano.Launcher
-    ( LauncherLog
+    ( IfToSendSigINT (DoNotSendSigINT)
+    , LauncherLog
+    , TimeoutInSecs (..)
     , withBackendCreateProcess
     )
 import Cardano.Launcher.Node
@@ -92,23 +94,27 @@ withCardanoWallet
     -- ^ Callback function with a socket filename and genesis params
     -> IO a
 withCardanoWallet tr node cfg@CardanoWalletConfig{..} action =
-    withBackendCreateProcess tr (cardanoWallet cfg node)
+    withBackendCreateProcess
+        tr
+        (cardanoWallet cfg node)
+        (TimeoutInSecs 4)
+        DoNotSendSigINT
         $ \_ -> action $ CardanoWalletConn walletPort
 
 cardanoWallet :: CardanoWalletConfig -> CardanoNodeConn -> CreateProcess
 cardanoWallet CardanoWalletConfig{..} node =
-
-    let cp = proc (fromMaybe "cardano-wallet" executable)
-            $ [ "serve"
-            , "--node-socket"
-            , nodeSocketFile node
-            , "--database"
-            , walletDatabaseDir
-            , "--port"
-            , show walletPort
-            ]
-                <> case walletNetwork of
-                    Mainnet -> ["--mainnet"]
-                    Testnet path -> ["--testnet", path]
-                <> extraArgs
-    in cp { cwd = workingDir }
+    let cp =
+            proc (fromMaybe "cardano-wallet" executable)
+                $ [ "serve"
+                  , "--node-socket"
+                  , nodeSocketFile node
+                  , "--database"
+                  , walletDatabaseDir
+                  , "--port"
+                  , show walletPort
+                  ]
+                    <> case walletNetwork of
+                        Mainnet -> ["--mainnet"]
+                        Testnet path -> ["--testnet", path]
+                    <> extraArgs
+    in  cp{cwd = workingDir}

lib/launcher/test/unit/Cardano/LauncherSpec.hs

@@ -37,10 +37,12 @@ import Cardano.BM.Trace
     )
 import Cardano.Launcher
     ( Command (..)
+    , IfToSendSigINT (DoNotSendSigINT)
     , LauncherLog
     , ProcessHandles (..)
     , ProcessHasExited (..)
     , StdStream (..)
+    , TimeoutInSecs (TimeoutInSecs)
     , withBackendProcess
     )
 import Control.Monad
@@ -208,6 +210,7 @@ spec = beforeAll setupMockCommands $ do
         pendingOnWine "SYSTEM32 commands not available under wine"
         mvar <- newEmptyMVar
         let backend = withBackendProcess tr foreverCommand
+                        (TimeoutInSecs 5) DoNotSendSigINT
                 $ \(ProcessHandles _ _ _ ph) -> do
                     putMVar mvar ph
                     forever $ threadDelay maxBound
@@ -224,6 +227,7 @@ spec = beforeAll setupMockCommands $ do
         skipOnWindows "Not applicable"
         mvar <- newEmptyMVar
         let backend = withBackendProcess tr unkillableCommand
+                        (TimeoutInSecs 5) DoNotSendSigINT
                 $ \(ProcessHandles _ _ _ ph) -> do
                     putMVar mvar ph
                     forever $ threadDelay maxBound
@@ -278,7 +282,8 @@ launch tr cmds = do
         waitForOthers (ProcessHandles _ _ _ ph) = do
             modifyMVar_ phsVar (pure . (ph:))
             forever $ threadDelay maxBound
-        start = async . try . flip (withBackendProcess tr) waitForOthers
+        start c = async . try
+            $ withBackendProcess tr c  (TimeoutInSecs 5) DoNotSendSigINT waitForOthers
 
     mapM start cmds >>= waitAnyCancel >>= \case
         (_, Left e) -> do