Report error on unsupported era

CHANGELOG.md

@@ -30,6 +30,7 @@ changes.
 - Hydra.Options split into Hydra.Options.Common, Hydra.Options.Offline,
   Hydra.Options.Online, re-exported from Hydra.Options.
 
+- Report error on unsupported era.
 
 ## [0.14.0] - 2023-12-04
 

cabal.project

@@ -33,10 +33,6 @@ packages:
 package *
   ghc-options: -j8
 
--- Warnings as errors for local packages
-program-options
-  ghc-options: -Werror
-
 -- Always build tests and benchmarks of local packages
 tests: True
 benchmarks: True

hydra-cluster/config/devnet/genesis-conway.json

@@ -1,4 +1,5 @@
 {
+  "genDelegs": {},
   "poolVotingThresholds": {
     "pvtCommitteeNormal": 0.51,
     "pvtCommitteeNoConfidence": 0.51,

hydra-cluster/config/devnet/genesis-shelley.json

@@ -1,5 +1,5 @@
 {
-    "epochLength": 432000,
+    "epochLength": 5,
     "activeSlotsCoeff": 1.0,
     "slotLength": 0.1,
     "securityParam": 2160,

hydra-cluster/src/CardanoNode.hs

@@ -4,12 +4,12 @@ module CardanoNode where
 
 import Hydra.Prelude
 
-import Control.Lens ((^?!))
+import Control.Lens ((^?), (^?!))
 import Control.Tracer (Tracer, traceWith)
-import Data.Aeson ((.=))
+import Data.Aeson (fromJSON, (.=))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.KeyMap qualified as Aeson.KeyMap
-import Data.Aeson.Lens (key, _Number)
+import Data.Aeson.Lens (key, _Number, _Value)
 import Data.Fixed (Centi)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Hydra.Cardano.Api (AsType (AsPaymentKey), File (..), NetworkId, PaymentKey, SigningKey, SocketPath, VerificationKey, generateSigningKey, getVerificationKey)
@@ -77,7 +77,7 @@ defaultCardanoNodeArgs :: CardanoNodeArgs
 defaultCardanoNodeArgs =
   CardanoNodeArgs
     { nodeSocket = "node.socket"
-    , nodeConfigFile = "configuration.json"
+    , nodeConfigFile = "cardano-node.json"
     , nodeByronGenesisFile = "genesis-byron.json"
     , nodeShelleyGenesisFile = "genesis-shelley.json"
     , nodeAlonzoGenesisFile = "genesis-alonzo.json"
@@ -117,64 +117,14 @@ withCardanoNodeDevnet ::
   (RunningNode -> IO a) ->
   IO a
 withCardanoNodeDevnet tracer stateDirectory action = do
-  createDirectoryIfMissing True stateDirectory
-  [dlgCert, signKey, vrfKey, kesKey, opCert] <-
-    mapM
-      copyDevnetCredential
-      [ "byron-delegation.cert"
-      , "byron-delegate.key"
-      , "vrf.skey"
-      , "kes.skey"
-      , "opcert.cert"
-      ]
-  let args =
-        defaultCardanoNodeArgs
-          { nodeDlgCertFile = Just dlgCert
-          , nodeSignKeyFile = Just signKey
-          , nodeVrfKeyFile = Just vrfKey
-          , nodeKesKeyFile = Just kesKey
-          , nodeOpCertFile = Just opCert
-          }
-  copyDevnetFiles args
-  refreshSystemStart stateDirectory args
-  writeTopology [] args
-
+  args <- setupCardanoDevnet stateDirectory
   withCardanoNode tracer networkId stateDirectory args $ \rn -> do
     traceWith tracer MsgNodeIsReady
     action rn
  where
   -- NOTE: This needs to match what's in config/genesis-shelley.json
   networkId = defaultNetworkId
 
-  copyDevnetCredential file = do
-    let destination = stateDirectory </> file
-    unlessM (doesFileExist destination) $
-      readConfigFile ("devnet" </> file)
-        >>= writeFileBS destination
-    setFileMode destination ownerReadMode
-    pure file
-
-  copyDevnetFiles args = do
-    readConfigFile ("devnet" </> "cardano-node.json")
-      >>= writeFileBS
-        (stateDirectory </> nodeConfigFile args)
-    readConfigFile ("devnet" </> "genesis-byron.json")
-      >>= writeFileBS
-        (stateDirectory </> nodeByronGenesisFile args)
-    readConfigFile ("devnet" </> "genesis-shelley.json")
-      >>= writeFileBS
-        (stateDirectory </> nodeShelleyGenesisFile args)
-    readConfigFile ("devnet" </> "genesis-alonzo.json")
-      >>= writeFileBS
-        (stateDirectory </> nodeAlonzoGenesisFile args)
-    readConfigFile ("devnet" </> "genesis-conway.json")
-      >>= writeFileBS
-        (stateDirectory </> nodeConwayGenesisFile args)
-
-  writeTopology peers args =
-    Aeson.encodeFile (stateDirectory </> nodeTopologyFile args) $
-      mkTopology peers
-
 -- | Run a cardano-node as normal network participant on a known network.
 withCardanoNodeOnKnownNetwork ::
   Tracer IO NodeLog ->
@@ -205,7 +155,7 @@ withCardanoNodeOnKnownNetwork tracer workDir knownNetwork action = do
   readNetworkId = do
     shelleyGenesis :: Aeson.Value <- unsafeDecodeJson =<< readFileBS (workDir </> "shelley-genesis.json")
     if shelleyGenesis ^?! key "networkId" == "Mainnet"
-      then pure $ Api.Mainnet
+      then pure Api.Mainnet
       else do
         let magic = shelleyGenesis ^?! key "networkMagic" . _Number
         pure $ Api.Testnet (Api.NetworkMagic $ truncate magic)
@@ -241,6 +191,75 @@ withCardanoNodeOnKnownNetwork tracer workDir knownNetwork action = do
   fetchConfigFile path =
     parseRequestThrow path >>= httpBS <&> getResponseBody
 
+-- | Setup the cardano-node to run a local devnet producing blocks. This copies
+-- the appropriate files and prepares 'CardanoNodeArgs' for 'withCardanoNode'.
+setupCardanoDevnet :: FilePath -> IO CardanoNodeArgs
+setupCardanoDevnet stateDirectory = do
+  createDirectoryIfMissing True stateDirectory
+  [dlgCert, signKey, vrfKey, kesKey, opCert] <-
+    mapM
+      copyDevnetCredential
+      [ "byron-delegation.cert"
+      , "byron-delegate.key"
+      , "vrf.skey"
+      , "kes.skey"
+      , "opcert.cert"
+      ]
+  let args =
+        defaultCardanoNodeArgs
+          { nodeDlgCertFile = Just dlgCert
+          , nodeSignKeyFile = Just signKey
+          , nodeVrfKeyFile = Just vrfKey
+          , nodeKesKeyFile = Just kesKey
+          , nodeOpCertFile = Just opCert
+          }
+  copyDevnetFiles args
+  refreshSystemStart stateDirectory args
+  writeTopology [] args
+  pure args
+ where
+  copyDevnetCredential file = do
+    let destination = stateDirectory </> file
+    unlessM (doesFileExist destination) $
+      readConfigFile ("devnet" </> file)
+        >>= writeFileBS destination
+    setFileMode destination ownerReadMode
+    pure file
+
+  copyDevnetFiles args = do
+    readConfigFile ("devnet" </> "cardano-node.json")
+      >>= writeFileBS
+        (stateDirectory </> nodeConfigFile args)
+    readConfigFile ("devnet" </> "genesis-byron.json")
+      >>= writeFileBS
+        (stateDirectory </> nodeByronGenesisFile args)
+    readConfigFile ("devnet" </> "genesis-shelley.json")
+      >>= writeFileBS
+        (stateDirectory </> nodeShelleyGenesisFile args)
+    readConfigFile ("devnet" </> "genesis-alonzo.json")
+      >>= writeFileBS
+        (stateDirectory </> nodeAlonzoGenesisFile args)
+    readConfigFile ("devnet" </> "genesis-conway.json")
+      >>= writeFileBS
+        (stateDirectory </> nodeConwayGenesisFile args)
+
+  writeTopology peers args =
+    Aeson.encodeFile (stateDirectory </> nodeTopologyFile args) $
+      mkTopology peers
+
+-- | Modify the cardano-node configuration to fork into conway at given era
+-- number. See 'config/devnet/genesis-shelley.json' for the epoch length (in
+-- slots).
+forkIntoConwayInEpoch :: FilePath -> CardanoNodeArgs -> Natural -> IO ()
+forkIntoConwayInEpoch stateDirectory args n = do
+  config <-
+    unsafeDecodeJsonFile (stateDirectory </> nodeConfigFile args)
+      <&> addField "TestConwayHardForkAtEpoch" n
+  Aeson.encodeFile
+    (stateDirectory </> nodeConfigFile args)
+    config
+  return ()
+
 withCardanoNode ::
   Tracer IO NodeLog ->
   NetworkId ->
@@ -353,7 +372,7 @@ refreshSystemStart stateDirectory args = do
   config <-
     unsafeDecodeJsonFile (stateDirectory </> nodeConfigFile args)
       <&> addField "ByronGenesisFile" (nodeByronGenesisFile args)
-      <&> addField "ShelleyGenesisFile" (nodeShelleyGenesisFile args)
+      . addField "ShelleyGenesisFile" (nodeShelleyGenesisFile args)
 
   Aeson.encodeFile
     (stateDirectory </> nodeByronGenesisFile args)
@@ -405,6 +424,14 @@ data NodeLog
 addField :: ToJSON a => Aeson.Key -> a -> Aeson.Value -> Aeson.Value
 addField k v = withObject (Aeson.KeyMap.insert k (toJSON v))
 
+getField :: (ToJSON a, FromJSON b) => Aeson.Key -> a -> b
+getField fieldKey value =
+  case fromJSON (findField fieldKey value) of
+    Aeson.Error _ -> error $ "Field " <> show fieldKey <> " not found"
+    Aeson.Success d -> d
+ where
+  findField k v = fromMaybe Aeson.Null $ toJSON v ^? key k . _Value
+
 -- | Do something with an a JSON object. Fails if the given JSON value isn't an
 -- object.
 withObject :: (Aeson.Object -> Aeson.Object) -> Aeson.Value -> Aeson.Value

hydra-cluster/src/HydraNode.hs

@@ -367,7 +367,7 @@ withHydraNode ::
 withHydraNode tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds hydraScriptsTxId action = do
   withLogFile logFilePath $ \logFileHandle -> do
     withHydraNode' chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds hydraScriptsTxId (Just logFileHandle) $ do
-      \_ processHandle -> do
+      \_ _ processHandle -> do
         race
           (checkProcessHasNotDied ("hydra-node (" <> show hydraNodeId <> ")") processHandle)
           (withConnectionToNode tracer hydraNodeId action)
@@ -388,7 +388,7 @@ withHydraNode' ::
   TxId ->
   -- | If given use this as std out.
   Maybe Handle ->
-  (Handle -> ProcessHandle -> IO a) ->
+  (Handle -> Handle -> ProcessHandle -> IO a) ->
   IO a
 withHydraNode' chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds hydraScriptsTxId mGivenStdOut action = do
   withSystemTempDirectory "hydra-node" $ \dir -> do
@@ -423,13 +423,13 @@ withHydraNode' chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNodeIds h
                 }
           )
             { std_out = maybe CreatePipe UseHandle mGivenStdOut
-            , std_err = Inherit
+            , std_err = CreatePipe
             }
-    withCreateProcess p $ \_stdin mCreatedHandle mErr processHandle ->
-      case (mCreatedHandle, mGivenStdOut, mErr) of
-        (Just out, _, _) -> action out processHandle
-        (Nothing, Just out, _) -> action out processHandle
-        (_, _, _) -> error "Should not happen™"
+    withCreateProcess p $ \_stdin mCreatedStdOut mCreatedStdErr processHandle ->
+      case (mCreatedStdOut <|> mGivenStdOut, mCreatedStdErr) of
+        (Just out, Just err) -> action out err processHandle
+        (Nothing, _) -> error "Should not happen™"
+        (_, Nothing) -> error "Should not happen™"
  where
   peers =
     [ Host