Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Spawn cardano-node in a test for 10 seconds.
- Loading branch information
Showing
32 changed files
with
1,475 additions
and
15 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -45,3 +45,5 @@ hie.yaml | |
|
|
||
| # Ignore files generated by tests | ||
| tmp | ||
| /cardano-node/logs | ||
|
|
||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,48 @@ | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
|
|
||
| module Test.Cardano.Node.Chairman | ||
| ( tests | ||
| ) where | ||
|
|
||
| import Cardano.Prelude | ||
| import Hedgehog (Property, discover) | ||
|
|
||
| import qualified Hedgehog as H | ||
| import qualified System.Directory as IO | ||
| import qualified Test.Common.Base as H | ||
| import qualified Test.Common.Process as H | ||
|
|
||
| prop_spawnOneNode :: Property | ||
| prop_spawnOneNode = H.propertyOnce . H.workspace "temp/chairman" $ \tempDir -> do | ||
| let dbDir = tempDir <> "/db/node-2" | ||
| let socketDir = tempDir <> "/socket" | ||
|
|
||
| H.createDirectoryIfMissing dbDir | ||
| H.createDirectoryIfMissing socketDir | ||
|
|
||
| base <- H.getProjectBase | ||
|
|
||
| dirContents <- liftIO $ IO.listDirectory base | ||
|
|
||
| H.annotateShow $ dirContents | ||
|
|
||
| (_mIn, _mOut, _mErr, hProcess) <- H.createProcess =<< H.procNode | ||
| [ "run" | ||
| , "--database-path", dbDir | ||
| , "--socket-path", socketDir <> "/node-2-socket" | ||
| , "--port", "3002" | ||
| , "--topology", base <> "/chairman/configuration/defaults/simpleview/topology-node-2.json" | ||
| , "--config", base <> "/chairman/configuration/defaults/simpleview/config-2.yaml" | ||
| , "--signing-key", base <> "/chairman/configuration/defaults/simpleview/genesis/delegate-keys.002.key" | ||
| , "--delegation-certificate", base <> "/chairman/configuration/defaults/simpleview/genesis/delegation-cert.002.json" | ||
| ] | ||
|
|
||
| H.threadDelay 10000000 | ||
|
|
||
| H.interruptProcessGroupOf hProcess | ||
|
|
||
| void $ H.waitForProcess hProcess | ||
|
|
||
| tests :: IO Bool | ||
| tests = H.checkParallel $$discover |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,79 @@ | ||
| module Test.Common.Base | ||
| ( propertyOnce | ||
| , failWithCustom | ||
| , threadDelay | ||
| , workspace | ||
| , moduleWorkspace | ||
| , createDirectoryIfMissing | ||
| ) where | ||
|
|
||
| import Control.Monad.IO.Class (liftIO) | ||
| import Data.Bool | ||
| import Data.Either (Either (..)) | ||
| import Data.Function (($), (.)) | ||
| import Data.Functor | ||
| import Data.Int | ||
| import Data.Maybe (Maybe (..), fromMaybe, listToMaybe) | ||
| import Data.Monoid (Monoid (..)) | ||
| import Data.Semigroup (Semigroup (..)) | ||
| import Data.String (String) | ||
| import Data.Tuple | ||
| import GHC.Stack (CallStack, HasCallStack, callStack, getCallStack) | ||
| import Hedgehog (MonadTest) | ||
| import Hedgehog.Internal.Property (Diff, liftTest, mkTest) | ||
| import Hedgehog.Internal.Source (getCaller) | ||
| import System.IO (FilePath, IO) | ||
|
|
||
| import qualified Control.Concurrent as IO | ||
| import qualified GHC.Stack as GHC | ||
| import qualified Hedgehog as H | ||
| import qualified Hedgehog.Internal.Property as H | ||
| import qualified System.Directory as IO | ||
| import qualified System.IO.Temp as IO | ||
|
|
||
| cardanoCliPath :: FilePath | ||
| cardanoCliPath = "cardano-cli" | ||
|
|
||
| propertyOnce :: H.PropertyT IO () -> H.Property | ||
| propertyOnce = H.withTests 1 . H.property | ||
|
|
||
| threadDelay :: Int -> H.PropertyT IO () | ||
| 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) | ||
|
|
||
| -- | Create a workspace directory which will exist for at least the duration of | ||
| -- the supplied block. | ||
| -- | ||
| -- The directory will have the supplied prefix but contain a generated random | ||
| -- suffix to prevent interference between tests | ||
| -- | ||
| -- The directory will be deleted if the block succeeds, but left behind if | ||
| -- the block fails. | ||
| workspace :: HasCallStack => FilePath -> (FilePath -> H.PropertyT IO ()) -> H.PropertyT IO () | ||
| workspace prefixPath f = GHC.withFrozenCallStack $ do | ||
| systemTemp <- liftIO $ IO.getCanonicalTemporaryDirectory | ||
| let systemPrefixPath = systemTemp <> "/" <> prefixPath | ||
| liftIO $ IO.createDirectoryIfMissing True systemPrefixPath | ||
| ws <- liftIO $ IO.createTempDirectory systemPrefixPath "test" | ||
| H.annotate $ "Workspace: " <> cardanoCliPath <> "/" <> ws | ||
| f ws | ||
| liftIO $ IO.removeDirectoryRecursive ws | ||
|
|
||
| -- | Create a workspace directory which will exist for at least the duration of | ||
| -- the supplied block. | ||
| -- | ||
| -- The directory will have the prefix as "$prefixPath/$moduleName" but contain a generated random | ||
| -- suffix to prevent interference between tests | ||
| -- | ||
| -- The directory will be deleted if the block succeeds, but left behind if | ||
| -- the block fails. | ||
| moduleWorkspace :: HasCallStack => FilePath -> (FilePath -> H.PropertyT IO ()) -> H.PropertyT IO () | ||
| moduleWorkspace prefixPath f = GHC.withFrozenCallStack $ do | ||
| let srcModule = fromMaybe "UnknownModule" (fmap (GHC.srcLocModule . snd) (listToMaybe (getCallStack callStack))) | ||
| workspace (prefixPath <> "/" <> srcModule) f | ||
|
|
||
| createDirectoryIfMissing :: HasCallStack => FilePath -> H.PropertyT IO () | ||
| createDirectoryIfMissing filePath = H.evalM . liftIO $ IO.createDirectoryIfMissing True filePath |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,70 @@ | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
|
|
||
| module Test.Common.Process | ||
| ( createProcess | ||
| , getProjectBase | ||
| , procNode | ||
| , interruptProcessGroupOf | ||
| , waitForProcess | ||
| ) where | ||
|
|
||
| import Control.Concurrent.Async | ||
| import Control.Exception | ||
| import Control.Monad | ||
| import Control.Monad.IO.Class | ||
| import Data.Bool | ||
| import Data.Function | ||
| import Data.Maybe (Maybe (..)) | ||
| import Data.Semigroup ((<>)) | ||
| import Data.String (String) | ||
| import GHC.Stack (HasCallStack) | ||
| import System.Exit (ExitCode) | ||
| import System.IO (Handle, IO) | ||
| import System.Process (CmdSpec (..), CreateProcess (..), ProcessHandle) | ||
|
|
||
| import qualified Data.List as L | ||
| 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 | ||
| => CreateProcess | ||
| -> H.PropertyT IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) | ||
| createProcess cp = GHC.withFrozenCallStack $ do | ||
| case IO.cmdspec cp of | ||
| RawCommand cmd args -> H.annotate $ "Command line: " <> cmd <> " " <> L.intercalate " " args | ||
| ShellCommand cmd -> H.annotate $ "Command line: " <> cmd | ||
| H.evalM . liftIO $ IO.createProcess cp | ||
|
|
||
| interruptProcessGroupOf :: HasCallStack | ||
| => ProcessHandle | ||
| -> H.PropertyT IO () | ||
| interruptProcessGroupOf hProcess = GHC.withFrozenCallStack $ do | ||
| H.evalM . liftIO $ IO.interruptProcessGroupOf hProcess | ||
|
|
||
| waitForProcess :: HasCallStack | ||
| => ProcessHandle | ||
| -> H.PropertyT IO (Maybe ExitCode) | ||
| waitForProcess hProcess = GHC.withFrozenCallStack $ do | ||
| 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 } | ||
|
|
||
| getProjectBase :: H.PropertyT IO String | ||
| getProjectBase = do | ||
| maybeCardanoCli <- liftIO $ IO.lookupEnv "CARDANO_NODE_SRC" | ||
| case maybeCardanoCli of | ||
| Just path -> return path | ||
| Nothing -> return ".." |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.