Create keys and launch three node cluster. Remove keys that were mean…

…t to be generated

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Node.Chairman
   ( tests
@@ -8,43 +9,69 @@ module Test.Cardano.Node.Chairman
 import           Cardano.Prelude
 import           Hedgehog (Property, discover)
 
+import qualified Data.Time.Clock as DTC
+import qualified Data.Time.Clock.POSIX as DTC
 import qualified Hedgehog as H
-import qualified System.Directory as IO
 import qualified System.IO 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"
+  base <- H.noteShowM H.getProjectBase
+  baseConfig <- H.noteShow $ base <> "/configuration/chairman/defaults/simpleview"
+  currentTime <- H.noteShowIO DTC.getCurrentTime
+  startTime <- H.noteShow $ DTC.addUTCTime 60 currentTime -- 60 seconds into the future
 
-  H.createDirectoryIfMissing dbDir
-  H.createDirectoryIfMissing socketDir
+  -- Generate keys
+  void $ H.execCli
+    [ "genesis"
+    , "--genesis-output-dir", tempDir <> "/genesis"
+    , "--start-time", show @Int64 (floor (DTC.utcTimeToPOSIXSeconds startTime))
+    , "--protocol-parameters-file", base <> "/scripts/protocol-params.json"
+    , "--k", "2160"
+    , "--protocol-magic", "459045235"
+    , "--n-poor-addresses", "128"
+    , "--n-delegate-addresses", "7"
+    , "--total-balance", "8000000000000000"
+    , "--avvm-entry-count", "128"
+    , "--avvm-entry-balance", "10000000000000"
+    , "--delegate-share", "0.9"
+    , "--real-pbft"
+    , "--secret-seed", "2718281828"
+    ]
 
-  base <- H.getProjectBase
+  -- Launch cluster of three nodes
+  procResults <- forM [0..2] $ \i -> do
+    si <- H.noteShow $ show @Int i
+    dbDir <- H.noteShow $ tempDir <> "/db/node-" <> si
+    socketDir <- H.noteShow $ tempDir <> "/socket"
 
-  dirContents <- liftIO $ IO.listDirectory base
+    H.createDirectoryIfMissing dbDir
+    H.createDirectoryIfMissing socketDir
 
-  H.annotateShow $ dirContents
+    H.copyFile (baseConfig <> "/topology-node-" <> si <> ".json") (tempDir <> "/topology-node-" <> si <> ".json")
+    H.copyFile (baseConfig <> "/config-" <> si <> ".yaml") (tempDir <> "/config-" <> si <> ".yaml")
 
-  (Just hIn, _mOut, _mErr, hProcess) <- H.createProcess =<< H.procNode
-    [ "run"
-    , "--database-path", dbDir
-    , "--socket-path", socketDir <> "/node-2-socket"
-    , "--port", "3002"
-    , "--topology", base <> "/configuration/chairman/defaults/simpleview/topology-node-2.json"
-    , "--config", base <> "/configuration/chairman/defaults/simpleview/config-2.yaml"
-    , "--signing-key", base <> "/configuration/chairman/defaults/simpleview/genesis/delegate-keys.002.key"
-    , "--delegation-certificate", base <> "/configuration/chairman/defaults/simpleview/genesis/delegation-cert.002.json"
-    , "--shutdown-ipc", "0"
-    ]
+    (Just hIn, _mOut, _mErr, hProcess) <- H.createProcess =<< H.procNode
+      [ "run"
+      , "--database-path", dbDir
+      , "--socket-path", socketDir <> "/node-" <> si <> "-socket"
+      , "--port", "300" <> si <> ""
+      , "--topology", tempDir <> "/topology-node-" <> si <> ".json"
+      , "--config", tempDir <> "/config-" <> si <> ".yaml"
+      , "--signing-key", tempDir <> "/genesis/delegate-keys.00" <> si <> ".key"
+      , "--delegation-certificate", tempDir <> "/genesis/delegation-cert.00" <> si <> ".json"
+      , "--shutdown-ipc", "0"
+      ]
 
-  H.threadDelay 10000000
+    return (hIn, hProcess)
 
-  liftIO $ IO.hClose hIn
+  H.threadDelay 10000000
 
-  void $ H.waitForProcess hProcess
+  -- Signal for cluster to shutdown and wait for shutdown to complete
+  forM_ procResults $ \(hIn, _) -> liftIO $ IO.hClose hIn
+  forM_ procResults $ \(_, hProcess) -> void $ H.waitForProcess hProcess
 
 tests :: IO Bool
 tests = H.checkParallel $$discover

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

@@ -1,15 +1,23 @@
+{-# LANGUAGE BangPatterns #-}
+
 module Test.Common.Base
   ( propertyOnce
   , failWithCustom
   , threadDelay
   , workspace
   , moduleWorkspace
   , createDirectoryIfMissing
+  , copyFile
+  , noteShow
+  , noteShowM
+  , noteShowIO
   ) where
 
+import           Control.Monad
 import           Control.Monad.IO.Class (liftIO)
 import           Data.Bool
 import           Data.Either (Either (..))
+import           Data.Eq
 import           Data.Function (($), (.))
 import           Data.Int
 import           Data.Maybe (Maybe (..), listToMaybe, maybe)
@@ -22,22 +30,21 @@ import           Hedgehog (MonadTest)
 import           Hedgehog.Internal.Property (Diff, liftTest, mkTest)
 import           Hedgehog.Internal.Source (getCaller)
 import           System.IO (FilePath, IO)
+import           Text.Show
 
 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.Info 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
+threadDelay = H.evalM . 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
@@ -53,13 +60,13 @@ failWithCustom cs mdiff msg = liftTest $ mkTest (Left $ H.Failure (getCaller cs)
 -- the block fails.
 workspace :: HasCallStack => FilePath -> (FilePath -> H.PropertyT IO ()) -> H.PropertyT IO ()
 workspace prefixPath f = GHC.withFrozenCallStack $ do
-  systemTemp <- liftIO $ IO.getCanonicalTemporaryDirectory
+  systemTemp <- H.evalM . liftIO $ IO.getCanonicalTemporaryDirectory
   let systemPrefixPath = systemTemp <> "/" <> prefixPath
-  liftIO $ IO.createDirectoryIfMissing True systemPrefixPath
-  ws <- liftIO $ IO.createTempDirectory systemPrefixPath "test"
-  H.annotate $ "Workspace: " <> cardanoCliPath <> "/" <> ws
+  H.evalM . liftIO $ IO.createDirectoryIfMissing True systemPrefixPath
+  ws <- H.evalM . liftIO $ IO.createTempDirectory systemPrefixPath "test"
+  H.annotate $ "Workspace: " <> ws
   f ws
-  liftIO $ IO.removeDirectoryRecursive ws
+  when (IO.os /= "mingw32") . H.evalM . liftIO $ IO.removeDirectoryRecursive ws
 
 -- | Create a workspace directory which will exist for at least the duration of
 -- the supplied block.
@@ -76,3 +83,26 @@ moduleWorkspace prefixPath f = GHC.withFrozenCallStack $ do
 
 createDirectoryIfMissing :: HasCallStack => FilePath -> H.PropertyT IO ()
 createDirectoryIfMissing filePath = H.evalM . liftIO $ IO.createDirectoryIfMissing True filePath
+
+copyFile :: HasCallStack => FilePath -> FilePath -> H.PropertyT IO ()
+copyFile src dst = GHC.withFrozenCallStack $ do
+  H.annotate $ "Copy from " <> show src <> " to " <> show dst
+  H.evalM . liftIO $ IO.copyFile src dst
+
+noteShow :: (HasCallStack, Show a) => a -> H.PropertyT IO a
+noteShow a = GHC.withFrozenCallStack $ do
+  !b <- H.eval a
+  H.annotateShow b
+  return b
+
+noteShowM :: (HasCallStack, Show a) => H.PropertyT IO a -> H.PropertyT IO a
+noteShowM a = GHC.withFrozenCallStack $ do
+  !b <- H.evalM a
+  H.annotateShow b
+  return b
+
+noteShowIO :: (HasCallStack, Show a) => IO a -> H.PropertyT IO a
+noteShowIO a = GHC.withFrozenCallStack $ do
+  !b <- H.evalM . liftIO $ a
+  H.annotateShow b
+  return b

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

@@ -3,9 +3,11 @@
 
 module Test.Common.Process
   ( createProcess
+  , execFlex
   , getProjectBase
+  , procCli
   , procNode
-  , interruptProcessGroupOf
+  , execCli
   , waitForProcess
   ) where
 
@@ -14,21 +16,50 @@ import           Control.Exception
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Bool
+import           Data.Either
 import           Data.Function
+import           Data.Int
 import           Data.Maybe (Maybe (..))
+import           Data.Monoid
 import           Data.Semigroup ((<>))
 import           Data.String (String)
-import           GHC.Stack (HasCallStack)
+import           GHC.Stack (CallStack, HasCallStack)
+import           Hedgehog (MonadTest)
+import           Hedgehog.Internal.Property (Diff, liftTest, mkTest)
+import           Hedgehog.Internal.Source (getCaller)
 import           System.Exit (ExitCode)
 import           System.IO (Handle, IO)
 import           System.Process (CmdSpec (..), CreateProcess (..), ProcessHandle)
+import           Text.Show
 
 import qualified Data.List as L
 import qualified GHC.Stack as GHC
 import qualified Hedgehog as H
+import qualified Hedgehog.Internal.Property as H
 import qualified System.Environment as IO
+import qualified System.Exit as IO
 import qualified System.Process as IO
 
+-- | Format argument for a shell CLI command.
+--
+-- This includes automatically embedding string in double quotes if necessary, including any necessary escaping.
+--
+-- Note, this function does not cover all the edge cases for shell processing, so avoid use in production code.
+argQuote :: String -> String
+argQuote arg = if ' ' `L.elem` arg || '"' `L.elem` arg || '$' `L.elem` arg
+  then "\"" <> escape arg <> "\""
+  else arg
+  where escape :: String -> String
+        escape ('"':xs) = '\\':'"':escape xs
+        escape ('\\':xs) = '\\':'\\':escape xs
+        escape ('\n':xs) = '\\':'n':escape xs
+        escape ('\r':xs) = '\\':'r':escape xs
+        escape ('\t':xs) = '\\':'t':escape xs
+        escape ('$':xs) = '\\':'$':escape xs
+        escape (x:xs) = x:escape xs
+        escape "" = ""
+
+-- | Create a process returning handles to stdin, stdout, and stderr as well as the process handle.
 createProcess :: HasCallStack
   => CreateProcess
   -> H.PropertyT IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
@@ -38,36 +69,95 @@ createProcess cp = GHC.withFrozenCallStack $ do
     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
+-- | Create a process returning its stdout.
+--
+-- Being a 'flex' function means that the environment determines how the process is launched.
+--
+-- When running in a nix environment, the 'envBin' argument describes the environment variable
+-- that defines the binary to use to launch the process.
+--
+-- When running outside a nix environment, the `pkgBin` describes the name of the binary
+-- to launch via cabal exec.
+execFlex :: HasCallStack
+  => String
+  -> String
+  -> [String]
+  -> H.PropertyT IO String
+execFlex pkgBin envBin arguments = GHC.withFrozenCallStack $ do
+  maybeEnvBin <- liftIO $ IO.lookupEnv envBin
+  (actualBin, actualArguments) <- case maybeEnvBin of
+    Just envBin' -> return (envBin', arguments)
+    Nothing -> return ("cabal", ("exec":"--":pkgBin:arguments))
+  H.annotate $ "Command: " <> actualBin <> " " <> L.unwords actualArguments
+  (exitResult, stdout, stderr) <- H.evalM . liftIO $ IO.readProcessWithExitCode actualBin actualArguments ""
+  case exitResult of
+    IO.ExitFailure exitCode -> failWithCustom GHC.callStack Nothing . L.unlines $
+      [ "Process exited with non-zero exit-code"
+      , "━━━━ command ━━━━"
+      , pkgBin <> " " <> L.unwords (fmap argQuote arguments)
+      , "━━━━ stdout ━━━━"
+      , stdout
+      , "━━━━ stderr ━━━━"
+      , stderr
+      , "━━━━ exit code ━━━━"
+      , show @Int exitCode
+      ]
+    IO.ExitSuccess -> return stdout
+
+-- | Run cardano-cli, returning the stdout
+execCli :: HasCallStack => [String] -> H.PropertyT IO String
+execCli = GHC.withFrozenCallStack $ execFlex "cardano-cli" "CARDANO_CLI"
 
 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]
+procFlex
+  :: HasCallStack
+  => String
+  -- ^ Cabal package name corresponding to the executable
+  -> String
+  -- ^ Environment variable pointing to the binary to run
+  -> [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)
+procFlex pkg binaryEnv arguments = GHC.withFrozenCallStack . H.evalM $ do
+  maybeEnvBin <- liftIO $ IO.lookupEnv binaryEnv
+  cp <- case maybeEnvBin of
+    Just envBin -> return $ IO.proc envBin arguments
+    Nothing -> return $ IO.proc "cabal" ("exec":"--":pkg:arguments)
   return $ cp
     { IO.create_group = True
     , IO.std_in = IO.CreatePipe
     }
 
+procCli
+  :: HasCallStack
+  => [String]
+  -- ^ Arguments to the CLI command
+  -> H.PropertyT IO CreateProcess
+  -- ^ Captured stdout
+procCli = procFlex "cardano-cli" "CARDANO_CLI"
+
+procNode
+  :: HasCallStack
+  => [String]
+  -- ^ Arguments to the CLI command
+  -> H.PropertyT IO CreateProcess
+  -- ^ Captured stdout
+procNode = procFlex "cardano-node" "CARDANO_NODE"
+
 getProjectBase :: H.PropertyT IO String
 getProjectBase = do
-  maybeCardanoCli <- liftIO $ IO.lookupEnv "CARDANO_NODE_SRC"
-  case maybeCardanoCli of
+  maybeNodeSrc <- liftIO $ IO.lookupEnv "CARDANO_NODE_SRC"
+  case maybeNodeSrc of
     Just path -> return path
     Nothing -> return ".."
+
+-- | 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)