Merge pull request #1247 from input-output-hk/fix-fix-contestation-pe…

…riod

Fix the fix of ContestationPeriod fromDiffTime

hydra-cluster/bench/Bench/EndToEnd.hs

@@ -76,7 +76,7 @@ data Event = Event
   deriving stock (Generic, Eq, Show)
   deriving anyclass (ToJSON)
 
-bench :: Int -> DiffTime -> FilePath -> Dataset -> IO Summary
+bench :: Int -> NominalDiffTime -> FilePath -> Dataset -> IO Summary
 bench startingNodeId timeoutSeconds workDir dataset@Dataset{clientDatasets, title, description} = do
   putStrLn $ "Test logs available in: " <> (workDir </> "test.log")
   withFile (workDir </> "test.log") ReadWriteMode $ \hdl ->
@@ -122,7 +122,7 @@ bench startingNodeId timeoutSeconds workDir dataset@Dataset{clientDatasets, titl
                 v ^? key "contestationDeadline" . _JSON
 
               -- Expect to see ReadyToFanout within 3 seconds after deadline
-              remainingTime <- realToFrac . diffUTCTime deadline <$> getCurrentTime
+              remainingTime <- diffUTCTime deadline <$> getCurrentTime
               waitFor hydraTracer (remainingTime + 3) [leader] $
                 output "ReadyToFanout" ["headId" .= headId]
 

hydra-cluster/bench/Bench/Options.hs

@@ -31,14 +31,14 @@ data Options
       { workDirectory :: Maybe FilePath
       , outputDirectory :: Maybe FilePath
       , scalingFactor :: Int
-      , timeoutSeconds :: DiffTime
+      , timeoutSeconds :: NominalDiffTime
       , clusterSize :: Word64
       , startingNodeId :: Int
       }
   | DatasetOptions
       { datasetFiles :: [FilePath]
       , outputDirectory :: Maybe FilePath
-      , timeoutSeconds :: DiffTime
+      , timeoutSeconds :: NominalDiffTime
       , startingNodeId :: Int
       }
 
@@ -119,7 +119,7 @@ scalingFactorParser =
         <> help "The scaling factor to apply to transactions generator (default: 100)"
     )
 
-timeoutParser :: Parser DiffTime
+timeoutParser :: Parser NominalDiffTime
 timeoutParser =
   option
     auto

hydra-cluster/exe/hydra-cluster/Main.hs

@@ -2,7 +2,7 @@ module Main where
 
 import Hydra.Prelude
 
-import CardanoNode (withCardanoNodeDevnet, withCardanoNodeOnKnownNetwork)
+import CardanoNode (waitForFullySynchronized, withCardanoNodeDevnet, withCardanoNodeOnKnownNetwork)
 import Hydra.Cluster.Faucet (publishHydraScriptsAs)
 import Hydra.Cluster.Fixture (Actor (Faucet))
 import Hydra.Cluster.Options (Options (..), PublishOrReuse (Publish, Reuse), parseOptions)
@@ -24,6 +24,7 @@ run options =
       case knownNetwork of
         Just network ->
           withCardanoNodeOnKnownNetwork fromCardanoNode workDir network $ \node -> do
+            waitForFullySynchronized fromCardanoNode node
             publishOrReuseHydraScripts tracer node
               >>= singlePartyHeadFullLifeCycle tracer workDir node
         Nothing ->

hydra-cluster/src/CardanoClient.hs

@@ -15,11 +15,8 @@ import Hydra.Cardano.Api hiding (Block)
 import Hydra.Chain.CardanoClient
 
 import Cardano.Api.UTxO qualified as UTxO
-import Cardano.Slotting.Time (RelativeTime (getRelativeTime), diffRelativeTime, toRelativeTime)
-import Data.Fixed (Centi)
 import Data.Map qualified as Map
 import Hydra.Chain.CardanoClient qualified as CardanoClient
-import Hydra.Logging (Tracer, traceWith)
 
 -- TODO(SN): DRY with Hydra.Cardano.Api
 
@@ -167,44 +164,6 @@ mkGenesisTx networkId pparams signingKey initialAmount recipients =
 data RunningNode = RunningNode
   { nodeSocket :: SocketPath
   , networkId :: NetworkId
-  , blockTime :: DiffTime
+  , blockTime :: NominalDiffTime
   -- ^ Expected time between blocks (varies a lot on testnets)
   }
-
--- Logging
-
-data NodeLog
-  = MsgNodeCmdSpec {cmd :: Text}
-  | MsgCLI [Text]
-  | MsgCLIStatus Text Text
-  | MsgCLIRetry Text
-  | MsgCLIRetryResult Text Int
-  | MsgNodeStarting {stateDirectory :: FilePath}
-  | MsgSocketIsReady SocketPath
-  | MsgSynchronizing {percentDone :: Centi}
-  | MsgNodeIsReady
-  deriving stock (Eq, Show, Generic)
-  deriving anyclass (ToJSON, FromJSON)
-
--- | Wait until the node is fully caught up with the network. This can take a
--- while!
-waitForFullySynchronized ::
-  Tracer IO NodeLog ->
-  NetworkId ->
-  SocketPath ->
-  IO ()
-waitForFullySynchronized tracer networkId nodeSocket = do
-  systemStart <- querySystemStart networkId nodeSocket QueryTip
-  check systemStart
- where
-  check systemStart = do
-    targetTime <- toRelativeTime systemStart <$> getCurrentTime
-    eraHistory <- queryEraHistory networkId nodeSocket QueryTip
-    tipSlotNo <- queryTipSlotNo networkId nodeSocket
-    (tipTime, _slotLength) <- either throwIO pure $ getProgress tipSlotNo eraHistory
-    let timeDifference = diffRelativeTime targetTime tipTime
-    let percentDone = realToFrac (100.0 * getRelativeTime tipTime / getRelativeTime targetTime)
-    traceWith tracer $ MsgSynchronizing{percentDone}
-    if timeDifference < 20 -- TODO: derive from known network and block times
-      then pure ()
-      else threadDelay 3 >> check systemStart

hydra-cluster/src/CardanoNode.hs

@@ -4,32 +4,31 @@ module CardanoNode where
 
 import Hydra.Prelude
 
-import CardanoClient (NodeLog (..), QueryPoint (QueryTip), RunningNode (..), queryGenesisParameters, waitForFullySynchronized)
+import Cardano.Slotting.Time (diffRelativeTime, getRelativeTime, toRelativeTime)
+import CardanoClient (QueryPoint (QueryTip), RunningNode (..), queryEraHistory, querySystemStart, queryTipSlotNo)
 import Control.Lens ((?~), (^?!))
 import Control.Tracer (Tracer, traceWith)
 import Data.Aeson (Value (String), (.=))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Lens (atKey, key, _Number)
+import Data.Fixed (Centi)
 import Data.Text qualified as Text
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Hydra.Cardano.Api (
   AsType (AsPaymentKey),
   File (..),
-  GenesisParameters (..),
   NetworkId,
   NetworkMagic (..),
   PaymentKey,
   SigningKey,
   SocketPath,
   VerificationKey,
   generateSigningKey,
+  getProgress,
   getVerificationKey,
  )
 import Hydra.Cardano.Api qualified as Api
-import Hydra.Cluster.Fixture (
-  KnownNetwork (Mainnet, Preproduction, Preview),
-  defaultNetworkId,
- )
+import Hydra.Cluster.Fixture (KnownNetwork (..))
 import Hydra.Cluster.Util (readConfigFile)
 import Network.HTTP.Simple (getResponseBody, httpBS, parseRequestThrow)
 import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
@@ -45,6 +44,18 @@ import System.Process (
  )
 import Test.Hydra.Prelude
 
+data NodeLog
+  = MsgNodeCmdSpec {cmd :: Text}
+  | MsgCLI [Text]
+  | MsgCLIStatus Text Text
+  | MsgCLIRetry Text
+  | MsgCLIRetryResult Text Int
+  | MsgNodeStarting {stateDirectory :: FilePath}
+  | MsgSocketIsReady SocketPath
+  | MsgSynchronizing {percentDone :: Centi}
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
+
 type Port = Int
 
 newtype NodeId = NodeId Int
@@ -125,10 +136,7 @@ withCardanoNodeDevnet ::
   IO a
 withCardanoNodeDevnet tracer stateDirectory action = do
   args <- setupCardanoDevnet stateDirectory
-  withCardanoNode tracer stateDirectory args networkId action
- where
-  -- NOTE: This needs to match what's in config/genesis-shelley.json
-  networkId = defaultNetworkId
+  withCardanoNode tracer stateDirectory args action
 
 -- | Run a cardano-node as normal network participant on a known network.
 withCardanoNodeOnKnownNetwork ::
@@ -141,8 +149,7 @@ withCardanoNodeOnKnownNetwork ::
   IO a
 withCardanoNodeOnKnownNetwork tracer workDir knownNetwork action = do
   copyKnownNetworkFiles
-  networkId <- readNetworkId
-  withCardanoNode tracer workDir args networkId action
+  withCardanoNode tracer workDir args action
  where
   args =
     defaultCardanoNodeArgs
@@ -154,15 +161,6 @@ withCardanoNodeOnKnownNetwork tracer workDir knownNetwork action = do
       , nodeConwayGenesisFile = "conway-genesis.json"
       }
 
-  -- Read 'NetworkId' from shelley genesis
-  readNetworkId = do
-    shelleyGenesis :: Aeson.Value <- unsafeDecodeJson =<< readFileBS (workDir </> "shelley-genesis.json")
-    if shelleyGenesis ^?! key "networkId" == "Mainnet"
-      then pure Api.Mainnet
-      else do
-        let magic = shelleyGenesis ^?! key "networkMagic" . _Number
-        pure $ Api.Testnet (Api.NetworkMagic $ truncate magic)
-
   -- Copy/download configuration files for a known network
   copyKnownNetworkFiles =
     forM_
@@ -265,10 +263,9 @@ withCardanoNode ::
   Tracer IO NodeLog ->
   FilePath ->
   CardanoNodeArgs ->
-  NetworkId ->
   (RunningNode -> IO a) ->
   IO a
-withCardanoNode tr stateDirectory args@CardanoNodeArgs{nodeSocket} networkId action = do
+withCardanoNode tr stateDirectory args action = do
   traceWith tr $ MsgNodeCmdSpec (show $ cmdspec process)
   withLogFile logFilePath $ \out -> do
     hSetBuffering out NoBuffering
@@ -280,6 +277,8 @@ withCardanoNode tr stateDirectory args@CardanoNodeArgs{nodeSocket} networkId act
               Left{} -> error "should never been reached"
               Right a -> pure a
  where
+  CardanoNodeArgs{nodeSocket, nodeShelleyGenesisFile} = args
+
   process = cardanoNodeProcess (Just stateDirectory) args
 
   logFilePath = stateDirectory </> "logs" </> "cardano-node.log"
@@ -291,31 +290,56 @@ withCardanoNode tr stateDirectory args@CardanoNodeArgs{nodeSocket} networkId act
     traceWith tr $ MsgNodeStarting{stateDirectory}
     waitForSocket nodeSocketPath
     traceWith tr $ MsgSocketIsReady nodeSocketPath
-    -- Wait for synchronization since otherwise we will receive a query
-    -- exception when trying to obtain pparams and the era is not the one we
-    -- expect.
-    _ <- waitForFullySynchronized tr networkId nodeSocketPath
-    traceWith tr MsgNodeIsReady
-    blockTime <- calculateBlockTime <$> queryGenesisParameters networkId nodeSocketPath QueryTip
+    shelleyGenesis :: Aeson.Value <- readShelleyGenesisJSON $ stateDirectory </> nodeShelleyGenesisFile
     action
       RunningNode
         { nodeSocket = nodeSocketPath
-        , networkId
-        , blockTime
+        , networkId = getShelleyGenesisNetworkId shelleyGenesis
+        , blockTime = getShelleyGenesisBlockTime shelleyGenesis
         }
 
-  calculateBlockTime
-    GenesisParameters
-      { protocolParamActiveSlotsCoefficient
-      , protocolParamSlotLength
-      } =
-      fromRational $
-        protocolParamActiveSlotsCoefficient * toRational protocolParamSlotLength
+  readShelleyGenesisJSON = readFileBS >=> unsafeDecodeJson
+
+  -- Read 'NetworkId' from shelley genesis JSON file
+  getShelleyGenesisNetworkId json = do
+    if json ^?! key "networkId" == "Mainnet"
+      then Api.Mainnet
+      else do
+        let magic = json ^?! key "networkMagic" . _Number
+        Api.Testnet (Api.NetworkMagic $ truncate magic)
+
+  -- Read expected time between blocks from shelley genesis
+  getShelleyGenesisBlockTime json = do
+    let slotLength = json ^?! key "slotLength" . _Number
+    let activeSlotsCoeff = json ^?! key "activeSlotsCoeff" . _Number
+    realToFrac $ slotLength / activeSlotsCoeff
 
   cleanupSocketFile =
     whenM (doesFileExist socketPath) $
       removeFile socketPath
 
+-- | Wait until the node is fully caught up with the network. This can take a
+-- while!
+waitForFullySynchronized ::
+  Tracer IO NodeLog ->
+  RunningNode ->
+  IO ()
+waitForFullySynchronized tracer RunningNode{networkId, nodeSocket, blockTime} = do
+  systemStart <- querySystemStart networkId nodeSocket QueryTip
+  check systemStart
+ where
+  check systemStart = do
+    targetTime <- toRelativeTime systemStart <$> getCurrentTime
+    eraHistory <- queryEraHistory networkId nodeSocket QueryTip
+    tipSlotNo <- queryTipSlotNo networkId nodeSocket
+    (tipTime, _slotLength) <- either throwIO pure $ getProgress tipSlotNo eraHistory
+    let timeDifference = diffRelativeTime targetTime tipTime
+    let percentDone = realToFrac (100.0 * getRelativeTime tipTime / getRelativeTime targetTime)
+    traceWith tracer $ MsgSynchronizing{percentDone}
+    if timeDifference < blockTime
+      then pure ()
+      else threadDelay 3 >> check systemStart
+
 -- | Wait for the node socket file to become available.
 waitForSocket :: SocketPath -> IO ()
 waitForSocket socketPath =

hydra-cluster/src/Hydra/Cluster/Scenarios.hs

@@ -8,14 +8,14 @@ import Test.Hydra.Prelude
 
 import Cardano.Api.UTxO qualified as UTxO
 import CardanoClient (
-  NodeLog,
   QueryPoint (QueryTip),
   RunningNode (..),
   buildTransaction,
   queryTip,
   queryUTxOFor,
   submitTx,
  )
+import CardanoNode (NodeLog)
 import Control.Concurrent.Async (mapConcurrently_)
 import Control.Lens ((^?))
 import Data.Aeson (Value, object, (.=))
@@ -60,7 +60,7 @@ import Hydra.Cluster.Faucet (FaucetLog, createOutputAtAddress, seedFromFaucet, s
 import Hydra.Cluster.Faucet qualified as Faucet
 import Hydra.Cluster.Fixture (Actor (..), actorName, alice, aliceSk, aliceVk, bob, bobSk, bobVk, carol, carolSk)
 import Hydra.Cluster.Util (chainConfigFor, keysFor, modifyConfig, setNetworkId)
-import Hydra.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod), fromDiffTime)
+import Hydra.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod), fromNominalDiffTime)
 import Hydra.HeadId (HeadId)
 import Hydra.Ledger (IsTx (balance))
 import Hydra.Ledger.Cardano (genKeyPair)
@@ -232,7 +232,7 @@ singlePartyHeadFullLifeCycle tracer workDir node hydraScriptsTxId =
     refuelIfNeeded tracer node Alice 25_000_000
     -- Start hydra-node on chain tip
     tip <- queryTip networkId nodeSocket
-    contestationPeriod <- fromDiffTime $ 10 * blockTime
+    contestationPeriod <- fromNominalDiffTime $ 10 * blockTime
     aliceChainConfig <-
       chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] contestationPeriod
         <&> modifyConfig (\config -> config{networkId, startChainFrom = Just tip})
@@ -250,7 +250,7 @@ singlePartyHeadFullLifeCycle tracer workDir node hydraScriptsTxId =
         guard $ v ^? key "tag" == Just "HeadIsClosed"
         guard $ v ^? key "headId" == Just (toJSON headId)
         v ^? key "contestationDeadline" . _JSON
-      remainingTime <- realToFrac . diffUTCTime deadline <$> getCurrentTime
+      remainingTime <- diffUTCTime deadline <$> getCurrentTime
       waitFor hydraTracer (remainingTime + 3 * blockTime) [n1] $
         output "ReadyToFanout" ["headId" .= headId]
       send n1 $ input "Fanout" []