Same system start time for all nodes in the integration test cluster

lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs

@@ -21,6 +21,7 @@ module Cardano.Wallet.Shelley.Launch
       withCluster
     , withBFTNode
     , withStakePool
+    , NodeConfig (..)
 
     -- * Utils
     , NetworkConfiguration (..)
@@ -98,7 +99,7 @@ import Data.Text
 import Data.Text.Class
     ( ToText (..) )
 import Data.Time.Clock
-    ( getCurrentTime )
+    ( UTCTime, addUTCTime, getCurrentTime )
 import GHC.TypeLits
     ( SomeNat (..), someNatVal )
 import Options.Applicative
@@ -264,8 +265,10 @@ withCluster
     -- ^ Action to run with the cluster up
     -> IO a
 withCluster tr severity n action = bracketTracer' tr "withCluster" $ do
+    systemStart <- addUTCTime 1 <$> getCurrentTime
     ports <- randomUnusedTCPPorts (n + 1)
-    withBFTNode tr severity (head $ rotate ports) $ \socket block0 params -> do
+    let bftCfg = NodeConfig severity systemStart (head $ rotate ports)
+    withBFTNode tr bftCfg $ \socket block0 params -> do
         waitForSocket tr socket
         waitGroup <- newChan
         doneGroup <- newChan
@@ -284,7 +287,8 @@ withCluster tr severity n action = bracketTracer' tr "withCluster" $ do
 
         forM_ (zip [0..] $ tail $ rotate ports) $ \(idx, (port, peers)) -> do
             link =<< async (handle onException $ do
-                withStakePool tr severity idx (port, peers) $ do
+                let spCfg = NodeConfig severity systemStart (port, peers)
+                withStakePool tr idx spCfg $ do
                     writeChan waitGroup $ Right port
                     readChan doneGroup)
 
@@ -306,23 +310,29 @@ withCluster tr severity n action = bracketTracer' tr "withCluster" $ do
     rotate :: Ord a => [a] -> [(a, [a])]
     rotate = nub . fmap (\(x:xs) -> (x, sort xs)) . permutations
 
+-- | Configuration parameters which update the @node.config@ test data file.
+data NodeConfig = NodeConfig
+    { minSeverity :: Severity -- ^ Minimum logging severity
+    , systemStart :: UTCTime -- ^ Genesis block start time
+    , nodePeers :: (Int, [Int]) -- ^ A list of ports used by peers and this node
+    } deriving (Show)
+
 withBFTNode
     :: Tracer IO ClusterLog
     -- ^ Trace for subprocess control logging
-    -> Severity
-    -- ^ Minimal logging severity
-    -> (Int, [Int])
-    -- ^ A list of ports used by peers and this pool.
+    -> NodeConfig
     -> (FilePath -> Block -> (NetworkParameters, NodeVersionData) -> IO a)
     -- ^ Callback function with genesis parameters
     -> IO a
-withBFTNode tr severity (port, peers) action = bracketTracer' tr "withBFTNode" $
+withBFTNode tr (NodeConfig severity systemStart (port, peers)) action =
+    bracketTracer' tr "withBFTNode" $
     withTempDir tr name $ \dir -> do
         [vrfPrv, kesPrv, opCert] <- forM
             ["node-vrf.skey", "node-kes.skey", "node.opcert"]
             (\f -> copyFile (source </> f) (dir </> f) $> (dir </> f))
 
-        (config, block0, networkParams, versionData) <- genConfig dir severity
+        (config, block0, networkParams, versionData)
+            <- genConfig dir severity systemStart
         topology <- genTopology dir peers
         let socket = genSocketPath dir
 
@@ -351,16 +361,15 @@ withBFTNode tr severity (port, peers) action = bracketTracer' tr "withBFTNode" $
 setupStakePoolData
     :: Tracer IO ClusterLog
     -> FilePath
-    -> Severity
-    -> (Int, [Int])
+    -> NodeConfig
     -> IO (Command, FilePath, FilePath)
-setupStakePoolData tr dir severity (port, peers) = do
+setupStakePoolData tr dir (NodeConfig severity systemStart (port, peers)) = do
     -- Node configuration
     (opPrv, opPub, opCount) <- genOperatorKeyPair tr dir
     (vrfPrv, vrfPub) <- genVrfKeyPair tr dir
     (kesPrv, kesPub) <- genKesKeyPair tr dir
     opCert <- issueOpCert tr dir kesPub opPrv opCount
-    (config, _, _, _) <- genConfig dir severity
+    (config, _, _, _) <- genConfig dir severity systemStart
     topology <- genTopology dir peers
 
     -- Pool registration
@@ -401,23 +410,22 @@ setupStakePoolData tr dir severity (port, peers) = do
 withStakePool
     :: Tracer IO ClusterLog
     -- ^ Trace for subprocess control logging
-    -> Severity
-    -- ^ Minimal logging severity
     -> Int
     -- ^ Unique stake pool number
-    -> (Int, [Int])
-    -- ^ A list of ports used by peers and this pool.
+    -> NodeConfig
     -> IO a
     -- ^ Callback function called once the pool has started.
     -> IO a
-withStakePool tr severity idx (port, peers) action = bracketTracer' tr "withStakePool" $ do
-    let name = "stake-pool-" ++ show idx
+withStakePool tr idx cfg action =
+    bracketTracer' tr "withStakePool" $
     withTempDir tr name $ \dir -> do
-        (cmd, opPub, tx) <- setupStakePoolData tr dir severity (port, peers)
+        (cmd, opPub, tx) <- setupStakePoolData tr dir cfg
         withCardanoNodeProcess tr name cmd $ do
             submitTx tr name tx
             timeout 120 ("pool registration", waitUntilRegistered tr name opPub)
             action
+  where
+    name = "stake-pool-" ++ show idx
 
 withCardanoNodeProcess
     :: Tracer IO ClusterLog
@@ -435,16 +443,18 @@ genConfig
     -- ^ A top-level directory where to put the configuration.
     -> Severity
     -- ^ Minimum severity level for logging
+    -> UTCTime
+    -- ^ Genesis block start time
     -> IO (FilePath, Block, NetworkParameters, NodeVersionData)
-genConfig dir severity = do
+genConfig dir severity systemStart = do
     -- we need to specify genesis file location every run in tmp
     Yaml.decodeFileThrow (source </> "node.config")
         >>= withObject (addGenesisFilePath (T.pack nodeGenesisFile))
         >>= withObject (addMinSeverity (T.pack $ show severity))
         >>= Yaml.encodeFile (dir </> "node.config")
 
     Yaml.decodeFileThrow @_ @Aeson.Value (source </> "genesis.yaml")
-        >>= withObject updateStartTime
+        >>= withObject (updateSystemStart systemStart)
         >>= Aeson.encodeFile nodeGenesisFile
 
     (genesisData :: ShelleyGenesis TPraosStandardCrypto)
@@ -834,12 +844,12 @@ oneMillionAda = 1_000_000_000_000
 
 -- | Add a "systemStart" field in a given object with the current POSIX time as a
 -- value.
-updateStartTime
-    :: Aeson.Object
+updateSystemStart
+    :: UTCTime
+    -> Aeson.Object
     -> IO Aeson.Object
-updateStartTime m = do
-    time <- getCurrentTime
-    pure $ HM.insert "systemStart" (toJSON time) m
+updateSystemStart systemStart =
+    pure . HM.insert "systemStart" (toJSON systemStart)
 
 -- | Add a "GenesisFile" field in a given object with the current path of
 -- genesis.json in tmp dir as value.