Stuff

cardano-node/cardano-node.cabal

@@ -263,6 +263,7 @@ test-suite cardano-node-test
   build-depends:
                         base >= 4.12 && < 5
                       , aeson
+                      , async
                       , bytestring
                       , cardano-config
                       , cardano-crypto-class
@@ -301,5 +302,3 @@ test-suite cardano-node-test
                         -Wpartial-fields
                         -Wcompat
                         -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T
-
-  build-tool-depends:   cardano-node:cardano-node

cardano-node/test/Test/Cardano/Node/Chairman.hs

@@ -9,26 +9,21 @@ import           Cardano.Prelude
 import           Hedgehog (Property, discover)
 
 import qualified Hedgehog as H
-import qualified System.Process as IO
 import qualified Test.Common.Base as H
 import qualified Test.Common.Process as H
 
 prop_spawnOneNode :: Property
 prop_spawnOneNode = H.propertyOnce $ do
-  (_mIn, _mOut, _mErr, hProcess) <- H.createProcess $
-    ( IO.proc "cardano-node"
-      [ "run"
-      , "--database-path", "../db/node-2/"
-      , "--socket-path", "../socket/node-2-socket"
-      , "--port", "3002"
-      , "--topology", "../configuration/defaults/simpleview/topology-node-2.json"
-      , "--config", "../configuration/defaults/simpleview/config-2.yaml"
-      , "--signing-key", "../configuration/defaults/simpleview/genesis/delegate-keys.002.key"
-      , "--delegation-certificate", "../configuration/defaults/simpleview/genesis/delegation-cert.002.json"
-      ]
-    )
-    { IO.create_group = True
-    }
+  (_mIn, _mOut, _mErr, hProcess) <- H.createProcess =<< H.procNode
+    [ "run"
+    , "--database-path", "../db/node-2/"
+    , "--socket-path", "../socket/node-2-socket"
+    , "--port", "3002"
+    , "--topology", "../configuration/defaults/simpleview/topology-node-2.json"
+    , "--config", "../configuration/defaults/simpleview/config-2.yaml"
+    , "--signing-key", "../configuration/defaults/simpleview/genesis/delegate-keys.002.key"
+    , "--delegation-certificate", "../configuration/defaults/simpleview/genesis/delegation-cert.002.json"
+    ]
 
   H.threadDelay 10000000
 

cardano-node/test/Test/Common/Base.hs

@@ -1,18 +1,32 @@
 module Test.Common.Base
   ( propertyOnce
+  , failWithCustom
   , threadDelay
   ) where
 
 import           Control.Monad.IO.Class (liftIO)
+import           Data.Either (Either (..))
 import           Data.Function (($), (.))
 import           Data.Int
+import           Data.Maybe (Maybe (..))
+import           Data.Monoid (Monoid (..))
+import           Data.String (String)
+import           GHC.Stack (CallStack)
+import           Hedgehog (MonadTest)
+import           Hedgehog.Internal.Property (Diff, liftTest, mkTest)
+import           Hedgehog.Internal.Source (getCaller)
 import           System.IO (IO)
 
 import qualified Control.Concurrent as IO
 import qualified Hedgehog as H
+import qualified Hedgehog.Internal.Property as H
 
 propertyOnce :: H.PropertyT IO () -> H.Property
 propertyOnce = H.withTests 1 . H.property
 
 threadDelay :: Int -> H.PropertyT IO ()
-threadDelay n = liftIO $ IO.threadDelay n
+threadDelay = liftIO . IO.threadDelay
+
+-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.
+failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a
+failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs) msg mdiff, mempty)

cardano-node/test/Test/Common/Process.hs

@@ -1,20 +1,29 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Test.Common.Process
   ( createProcess
+  , procNode
   , interruptProcessGroupOf
   , waitForProcess
   ) where
 
+import           Control.Concurrent.Async
+import           Control.Exception
+import           Control.Monad
 import           Control.Monad.IO.Class
-import           Data.Function ((.))
-import           Data.Function (($))
+import           Data.Bool
+import           Data.Function
 import           Data.Maybe (Maybe (..))
+import           Data.String (String)
 import           GHC.Stack (HasCallStack)
 import           System.Exit (ExitCode)
 import           System.IO (Handle, IO)
 import           System.Process (CreateProcess (..), ProcessHandle)
 
 import qualified GHC.Stack as GHC
 import qualified Hedgehog as H
+import qualified System.Environment as IO
 import qualified System.Process as IO
 
 createProcess :: HasCallStack
@@ -31,6 +40,18 @@ interruptProcessGroupOf hProcess = GHC.withFrozenCallStack $ do
 
 waitForProcess :: HasCallStack
   => ProcessHandle
-  -> H.PropertyT IO ExitCode
+  -> H.PropertyT IO (Maybe ExitCode)
 waitForProcess hProcess = GHC.withFrozenCallStack $ do
-  H.evalM . liftIO $ IO.waitForProcess hProcess
+  H.evalM . liftIO $ catch (fmap Just (IO.waitForProcess hProcess)) $ \(_ :: AsyncCancelled) -> return Nothing
+
+procNode
+  :: [String]
+  -- ^ Arguments to the CLI command
+  -> H.PropertyT IO CreateProcess
+  -- ^ Captured stdout
+procNode arguments = do
+  maybeCardanoCli <- liftIO $ IO.lookupEnv "CARDANO_NODE"
+  cp <- case maybeCardanoCli of
+    Just cardanoCli -> return $ IO.proc cardanoCli arguments
+    Nothing -> return $ IO.proc "cabal" ("exec":"--":"cardano-node":arguments)
+  return $ cp { IO.create_group = True }

nix/haskell.nix

@@ -102,6 +102,9 @@ let
 
         # cardano-cli-test depends on cardano-cli
         packages.cardano-cli.preCheck = "export CARDANO_CLI=${pkgSet.cardano-cli.components.exes.cardano-cli}/bin/cardano-cli";
+
+        # cardano-node-test depends on cardano-node
+        packages.cardano-node.preCheck = "export CARDANO_NODE=${pkgSet.cardano-node.components.exes.cardano-node}/bin/cardano-node";
       }
       {
         packages = lib.genAttrs projectPackages