diff --git a/CHANGELOG.md b/CHANGELOG.md index 48b6d5979cd..22acf87d2db 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -40,6 +40,8 @@ changes. - **BREAKING** Changes the `NodeOptions` log output because of internal restructuring of chain layer configuration. +- Adapt cardano client and the chain-sync client to survive after the fork to Conway era. + ## [0.14.0] - 2023-12-04 - **BREAKING** Multiple changes to the Hydra Head protocol on-chain: diff --git a/hydra-cardano-api/src/Cardano/Api/UTxO.hs b/hydra-cardano-api/src/Cardano/Api/UTxO.hs index d13e68d4d66..ad4194edac0 100644 --- a/hydra-cardano-api/src/Cardano/Api/UTxO.hs +++ b/hydra-cardano-api/src/Cardano/Api/UTxO.hs @@ -10,6 +10,8 @@ module Cardano.Api.UTxO where import Cardano.Api hiding (UTxO, toLedgerUTxO) import Cardano.Api qualified +import Cardano.Api.Shelley (ReferenceScript (..)) +import Data.Bifunctor (second) import Data.Coerce (coerce) import Data.List qualified as List import Data.Map (Map) @@ -84,8 +86,36 @@ min = UTxO . uncurry Map.singleton . Map.findMin . toMap -- * Type Conversions -fromApi :: Cardano.Api.UTxO Era -> UTxO -fromApi = coerce +-- | Transforms a UTxO containing tx outs from any era into Babbage era. +fromApi :: Cardano.Api.UTxO era -> UTxO +fromApi (Cardano.Api.UTxO eraUTxO) = + let eraPairs = Map.toList eraUTxO + babbagePairs = second coerceOutputToEra <$> eraPairs + in fromPairs babbagePairs + where + coerceOutputToEra :: TxOut CtxUTxO era -> TxOut CtxUTxO Era + coerceOutputToEra (TxOut eraAddress eraValue eraDatum eraRefScript) = + TxOut + (coerceAddressToEra eraAddress) + (coerceValueToEra eraValue) + (coerceDatumToEra eraDatum) + (coerceRefScriptToEra eraRefScript) + + coerceAddressToEra :: AddressInEra era -> AddressInEra Era + coerceAddressToEra (AddressInEra _ eraAddress) = anyAddressInShelleyBasedEra ShelleyBasedEraBabbage (toAddressAny eraAddress) + + coerceValueToEra :: TxOutValue era -> TxOutValue Era + coerceValueToEra (TxOutAdaOnly _ eraLovelace) = lovelaceToTxOutValue BabbageEra eraLovelace + coerceValueToEra (TxOutValue _ value) = TxOutValue MaryEraOnwardsBabbage value + + coerceDatumToEra :: TxOutDatum CtxUTxO era -> TxOutDatum CtxUTxO Era + coerceDatumToEra TxOutDatumNone = TxOutDatumNone + coerceDatumToEra (TxOutDatumHash _ hashScriptData) = TxOutDatumHash AlonzoEraOnwardsBabbage hashScriptData + coerceDatumToEra (TxOutDatumInline _ hashableScriptData) = TxOutDatumInline BabbageEraOnwardsBabbage hashableScriptData + + coerceRefScriptToEra :: ReferenceScript era -> ReferenceScript Era + coerceRefScriptToEra ReferenceScriptNone = ReferenceScriptNone + coerceRefScriptToEra (ReferenceScript _ scriptInAnyLang) = ReferenceScript BabbageEraOnwardsBabbage scriptInAnyLang toApi :: UTxO -> Cardano.Api.UTxO Era toApi = coerce diff --git a/hydra-cluster/src/CardanoNode.hs b/hydra-cluster/src/CardanoNode.hs index 8bc1880ea54..bc3e99feb5a 100644 --- a/hydra-cluster/src/CardanoNode.hs +++ b/hydra-cluster/src/CardanoNode.hs @@ -12,7 +12,17 @@ import Data.Aeson qualified as Aeson import Data.Aeson.Lens (atKey, key, _Number) import Data.Text qualified as Text import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) -import Hydra.Cardano.Api (AsType (AsPaymentKey), File (..), NetworkId, PaymentKey, SigningKey, SocketPath, VerificationKey, generateSigningKey, getVerificationKey) +import Hydra.Cardano.Api ( + AsType (AsPaymentKey), + File (..), + NetworkId, + PaymentKey, + SigningKey, + SocketPath, + VerificationKey, + generateSigningKey, + getVerificationKey, + ) import Hydra.Cardano.Api qualified as Api import Hydra.Chain.CardanoClient (QueryPoint (QueryTip), queryProtocolParameters) import Hydra.Cluster.Fixture ( @@ -135,8 +145,8 @@ withCardanoNodeOnKnownNetwork :: FilePath -> -- | A well-known Cardano network to connect to. KnownNetwork -> - (RunningNode -> IO ()) -> - IO () + (RunningNode -> IO a) -> + IO a withCardanoNodeOnKnownNetwork tracer workDir knownNetwork action = do copyKnownNetworkFiles networkId <- readNetworkId diff --git a/hydra-cluster/test/Test/EndToEndSpec.hs b/hydra-cluster/test/Test/EndToEndSpec.hs index a17f8764726..d1ab40cc281 100644 --- a/hydra-cluster/test/Test/EndToEndSpec.hs +++ b/hydra-cluster/test/Test/EndToEndSpec.hs @@ -37,28 +37,7 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text import Data.Time (secondsToDiffTime) -import Hydra.Cardano.Api ( - AddressInEra, - GenesisParameters (..), - NetworkId (Testnet), - NetworkMagic (NetworkMagic), - PaymentKey, - SlotNo (..), - ToUTxOContext (toUTxOContext), - TxId, - TxIn (..), - VerificationKey, - isVkTxOut, - lovelaceToValue, - mkTxIn, - mkVkAddress, - serialiseAddress, - signTx, - txOutValue, - txOuts', - unEpochNo, - pattern TxValidityLowerBound, - ) +import Hydra.Cardano.Api hiding (Value, cardanoEra, queryGenesisParameters) import Hydra.Chain.Direct.Fixture (defaultPParams, testNetworkId) import Hydra.Chain.Direct.State () import Hydra.Cluster.Faucet ( @@ -527,6 +506,7 @@ spec = around (showLogsOnFailure "EndToEndSpec") $ do describe "forking eras" $ do it "does report on unsupported era" $ \tracer -> do + pendingWith "Currently supporting Conway era no future upcoming" withClusterTempDir "unsupported-era" $ \tmpDir -> do args <- setupCardanoDevnet tmpDir forkIntoConwayInEpoch tmpDir args 1 @@ -535,18 +515,19 @@ spec = around (showLogsOnFailure "EndToEndSpec") $ do let node = RunningNode{nodeSocket, networkId = defaultNetworkId, pparams} hydraScriptsTxId <- publishHydraScriptsAs node Faucet chainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod - withHydraNode' chainConfig tmpDir 1 aliceSk [] [1] pparams Nothing $ \out mStdErr ph -> do + withHydraNode' chainConfig tmpDir 1 aliceSk [] [1] pparams Nothing $ \out stdErr ph -> do -- Assert nominal startup waitForLog 5 out "missing NodeOptions" (Text.isInfixOf "NodeOptions") waitUntilEpoch tmpDir args node 1 waitForProcess ph `shouldReturn` ExitFailure 1 - errorOutputs <- hGetContents mStdErr + errorOutputs <- hGetContents stdErr errorOutputs `shouldContain` "Received blocks in unsupported era" errorOutputs `shouldContain` "upgrade your hydra-node" it "does report on unsupported era on startup" $ \tracer -> do + pendingWith "Currently supporting Conway era no future upcoming" withClusterTempDir "unsupported-era-startup" $ \tmpDir -> do args <- setupCardanoDevnet tmpDir forkIntoConwayInEpoch tmpDir args 1 @@ -558,25 +539,104 @@ spec = around (showLogsOnFailure "EndToEndSpec") $ do waitUntilEpoch tmpDir args node 2 - withHydraNode' chainConfig tmpDir 1 aliceSk [] [1] pparams Nothing $ \_out mStdErr ph -> do + withHydraNode' chainConfig tmpDir 1 aliceSk [] [1] pparams Nothing $ \_out stdErr ph -> do waitForProcess ph `shouldReturn` ExitFailure 1 - errorOutputs <- hGetContents mStdErr + errorOutputs <- hGetContents stdErr errorOutputs `shouldContain` "Connected to cardano-node in unsupported era" errorOutputs `shouldContain` "upgrade your hydra-node" + it "support new era" $ \tracer -> do + withClusterTempDir "support-new-era" $ \tmpDir -> do + args <- setupCardanoDevnet tmpDir + + forkIntoConwayInEpoch tmpDir args 10 + withCardanoNode (contramap FromCardanoNode tracer) tmpDir args defaultNetworkId $ + \nodeSocket -> do + let pparams = defaultPParams + node = RunningNode{nodeSocket, networkId = defaultNetworkId, pparams} + lovelaceBalanceValue = 100_000_000 + -- Funds to be used as fuel by Hydra protocol transactions + (aliceCardanoVk, _) <- keysFor Alice + seedFromFaucet_ node aliceCardanoVk lovelaceBalanceValue (contramap FromFaucet tracer) + -- Get some UTXOs to commit to a head + (aliceExternalVk, aliceExternalSk) <- generate genKeyPair + committedUTxOByAlice <- seedFromFaucet node aliceExternalVk aliceCommittedToHead (contramap FromFaucet tracer) + + hydraScriptsTxId <- publishHydraScriptsAs node Faucet + chainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + + let hydraTracer = contramap FromHydraNode tracer + withHydraNode hydraTracer chainConfig tmpDir 1 aliceSk [] [1] pparams $ \n1 -> do + send n1 $ input "Init" [] + headId <- waitForAllMatch 10 [n1] $ headIsInitializingWith (Set.fromList [alice]) + + requestCommitTx n1 committedUTxOByAlice <&> signTx aliceExternalSk >>= submitTx node + + waitFor hydraTracer 3 [n1] $ output "HeadIsOpen" ["utxo" .= committedUTxOByAlice, "headId" .= headId] + + waitUntilEpoch tmpDir args node 10 + + send n1 $ input "Close" [] + waitMatch 3 n1 $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsClosed" + guard $ v ^? key "headId" == Just (toJSON headId) + snapshotNumber <- v ^? key "snapshotNumber" + guard $ snapshotNumber == Aeson.Number 0 + + it "support new era on restart" $ \tracer -> do + withClusterTempDir "support-new-era-restart" $ \tmpDir -> do + args <- setupCardanoDevnet tmpDir + + forkIntoConwayInEpoch tmpDir args 10 + withCardanoNode (contramap FromCardanoNode tracer) tmpDir args defaultNetworkId $ + \nodeSocket -> do + let pparams = defaultPParams + node = RunningNode{nodeSocket, networkId = defaultNetworkId, pparams} + lovelaceBalanceValue = 100_000_000 + -- Funds to be used as fuel by Hydra protocol transactions + (aliceCardanoVk, _) <- keysFor Alice + seedFromFaucet_ node aliceCardanoVk lovelaceBalanceValue (contramap FromFaucet tracer) + -- Get some UTXOs to commit to a head + (aliceExternalVk, aliceExternalSk) <- generate genKeyPair + committedUTxOByAlice <- seedFromFaucet node aliceExternalVk aliceCommittedToHead (contramap FromFaucet tracer) + + hydraScriptsTxId <- publishHydraScriptsAs node Faucet + chainConfig <- chainConfigFor Alice tmpDir nodeSocket hydraScriptsTxId [] cperiod + + let hydraTracer = contramap FromHydraNode tracer + headId <- withHydraNode hydraTracer chainConfig tmpDir 1 aliceSk [] [1] pparams $ \n1 -> do + send n1 $ input "Init" [] + headId <- waitForAllMatch 10 [n1] $ headIsInitializingWith (Set.fromList [alice]) + + requestCommitTx n1 committedUTxOByAlice <&> signTx aliceExternalSk >>= submitTx node + + waitFor hydraTracer 3 [n1] $ output "HeadIsOpen" ["utxo" .= committedUTxOByAlice, "headId" .= headId] + + pure headId + + waitUntilEpoch tmpDir args node 10 + + withHydraNode hydraTracer chainConfig tmpDir 1 aliceSk [] [1] pparams $ \n1 -> do + send n1 $ input "Close" [] + waitMatch 3 n1 $ \v -> do + guard $ v ^? key "tag" == Just "HeadIsClosed" + guard $ v ^? key "headId" == Just (toJSON headId) + snapshotNumber <- v ^? key "snapshotNumber" + guard $ snapshotNumber == Aeson.Number 0 + -- | Wait until given number of epoch. This uses the epoch and slot lengths from -- the 'ShelleyGenesisFile' of the node args passed in. waitUntilEpoch :: FilePath -> CardanoNodeArgs -> RunningNode -> Natural -> IO () waitUntilEpoch stateDirectory args RunningNode{networkId, nodeSocket} toEpochNo = do fromEpochNo :: Natural <- fromIntegral . unEpochNo <$> queryEpochNo networkId nodeSocket QueryTip toEpochNo `shouldSatisfy` (> fromEpochNo) - shellyGenesisFile :: Aeson.Value <- unsafeDecodeJsonFile (stateDirectory nodeShelleyGenesisFile args) + shelleyGenesisFile :: Aeson.Value <- unsafeDecodeJsonFile (stateDirectory nodeShelleyGenesisFile args) let slotLength = fromMaybe (error "Field epochLength not found") $ - shellyGenesisFile ^? key "slotLength" . _Double + shelleyGenesisFile ^? key "slotLength" . _Double epochLength = fromMaybe (error "Field epochLength not found") $ - shellyGenesisFile ^? key "epochLength" . _Double + shelleyGenesisFile ^? key "epochLength" . _Double threadDelay . realToFrac $ fromIntegral (toEpochNo - fromEpochNo) * epochLength * slotLength waitForLog :: DiffTime -> Handle -> Text -> (Text -> Bool) -> IO () diff --git a/hydra-node/src/Hydra/Chain/CardanoClient.hs b/hydra-node/src/Hydra/Chain/CardanoClient.hs index bdc8f880d02..b5f8ef17419 100644 --- a/hydra-node/src/Hydra/Chain/CardanoClient.hs +++ b/hydra-node/src/Hydra/Chain/CardanoClient.hs @@ -6,11 +6,14 @@ module Hydra.Chain.CardanoClient where import Hydra.Prelude -import Hydra.Cardano.Api hiding (Block) +import Hydra.Cardano.Api hiding (Block, queryCurrentEra) import Cardano.Api.UTxO qualified as UTxO -import Cardano.Ledger.Core (PParams) +import Cardano.Ledger.Core (PParams (..)) +import Data.Aeson (eitherDecode', encode) import Data.Set qualified as Set +import Data.Text qualified as Text +import Hydra.Ledger.Cardano.Json () import Ouroboros.Consensus.Cardano.Block (EraMismatch (..)) import Test.QuickCheck (oneof) import Text.Printf (printf) @@ -19,6 +22,10 @@ data QueryException = QueryAcquireException AcquiringFailure | QueryEraMismatchException EraMismatch | QueryProtocolParamsConversionException ProtocolParametersConversionError + | QueryProtocolParamsEraNotSupported AnyCardanoEra + | QueryProtocolParamsEncodingFailureOnEra AnyCardanoEra Text + | QueryEraNotInCardanoModeFailure AnyCardanoEra + | QueryNotShelleyBasedEraException AnyCardanoEra deriving stock (Show) instance Eq QueryException where @@ -28,6 +35,10 @@ instance Eq QueryException where (AFPointNotOnChain, AFPointNotOnChain) -> True _ -> False (QueryEraMismatchException em1, QueryEraMismatchException em2) -> em1 == em2 + (QueryProtocolParamsEraNotSupported ens1, QueryProtocolParamsEraNotSupported ens2) -> ens1 == ens2 + (QueryProtocolParamsEncodingFailureOnEra e1 f1, QueryProtocolParamsEncodingFailureOnEra e2 f2) -> e1 == e2 && f1 == f2 + (QueryEraNotInCardanoModeFailure e1, QueryEraNotInCardanoModeFailure e2) -> e1 == e2 + (QueryNotShelleyBasedEraException e1, QueryNotShelleyBasedEraException e2) -> e1 == e2 _ -> False instance Exception QueryException where @@ -36,6 +47,14 @@ instance Exception QueryException where QueryEraMismatchException EraMismatch{ledgerEraName, otherEraName} -> printf "Connected to cardano-node in unsupported era %s. Please upgrade your hydra-node to era %s." otherEraName ledgerEraName QueryProtocolParamsConversionException err -> show err + QueryProtocolParamsEraNotSupported unsupportedEraName -> + printf "Error while querying protocol params using era %s." (show unsupportedEraName :: Text) + QueryProtocolParamsEncodingFailureOnEra eraName encodingFailure -> + printf "Error while querying protocol params using era %s: %s." (show eraName :: Text) encodingFailure + QueryEraNotInCardanoModeFailure eraName -> + printf "Error while querying using era %s not in cardano mode." (show eraName :: Text) + QueryNotShelleyBasedEraException eraName -> + printf "Error while querying using era %s not in shelley based era." (show eraName :: Text) -- * CardanoClient handle @@ -245,69 +264,87 @@ queryEpochNo networkId socket queryPoint = do -- -- Throws at least 'QueryException' if query fails. queryProtocolParameters :: + -- | Current network discriminant NetworkId -> + -- | Filepath to the cardano-node's domain socket SocketPath -> QueryPoint -> IO (PParams LedgerEra) -queryProtocolParameters networkId socket queryPoint = do - let query = - QueryInEra - BabbageEraInCardanoMode - ( QueryInShelleyBasedEra - ShelleyBasedEraBabbage - QueryProtocolParameters - ) - runQuery networkId socket queryPoint query >>= throwOnEraMismatch +queryProtocolParameters networkId socket queryPoint = + runQueryExpr networkId socket queryPoint $ do + (AnyCardanoEra era) <- queryCurrentEraExpr + eraPParams <- queryInEraExpr era QueryProtocolParameters + liftIO $ coercePParamsToLedgerEra era eraPParams + where + encodeToEra eraToEncode pparams = + case eitherDecode' (encode pparams) of + Left e -> throwIO $ QueryProtocolParamsEncodingFailureOnEra (anyCardanoEra eraToEncode) (Text.pack e) + Right (ok :: PParams LedgerEra) -> pure ok + + coercePParamsToLedgerEra :: CardanoEra era -> PParams (ShelleyLedgerEra era) -> IO (PParams LedgerEra) + coercePParamsToLedgerEra era pparams = + case era of + ByronEra -> throwIO $ QueryProtocolParamsEraNotSupported (anyCardanoEra ByronEra) + ShelleyEra -> encodeToEra ShelleyEra pparams + AllegraEra -> encodeToEra AllegraEra pparams + MaryEra -> encodeToEra MaryEra pparams + AlonzoEra -> encodeToEra AlonzoEra pparams + BabbageEra -> pure pparams + ConwayEra -> encodeToEra ConwayEra pparams -- | Query 'GenesisParameters' at a given point. -- -- Throws at least 'QueryException' if query fails. -queryGenesisParameters :: NetworkId -> SocketPath -> QueryPoint -> IO (GenesisParameters ShelleyEra) +queryGenesisParameters :: + -- | Current network discriminant + NetworkId -> + -- | Filepath to the cardano-node's domain socket + SocketPath -> + QueryPoint -> + IO (GenesisParameters ShelleyEra) queryGenesisParameters networkId socket queryPoint = - let query = - QueryInEra - BabbageEraInCardanoMode - ( QueryInShelleyBasedEra - ShelleyBasedEraBabbage - QueryGenesisParameters - ) - in runQuery networkId socket queryPoint query >>= throwOnEraMismatch + runQueryExpr networkId socket queryPoint $ do + (AnyCardanoEra era) <- queryCurrentEraExpr + queryInEraExpr era QueryGenesisParameters -- | Query UTxO for all given addresses at given point. -- -- Throws at least 'QueryException' if query fails. queryUTxO :: NetworkId -> SocketPath -> QueryPoint -> [Address ShelleyAddr] -> IO UTxO queryUTxO networkId socket queryPoint addresses = - let query = - QueryInEra - BabbageEraInCardanoMode - ( QueryInShelleyBasedEra - ShelleyBasedEraBabbage - ( QueryUTxO - (QueryUTxOByAddress (Set.fromList $ map AddressShelley addresses)) - ) - ) - in UTxO.fromApi <$> (runQuery networkId socket queryPoint query >>= throwOnEraMismatch) + runQueryExpr networkId socket queryPoint $ do + (AnyCardanoEra era) <- queryCurrentEraExpr + eraUTxO <- queryInEraExpr era $ QueryUTxO (QueryUTxOByAddress (Set.fromList $ map AddressShelley addresses)) + pure $ UTxO.fromApi eraUTxO -- | Query UTxO for given tx inputs at given point. -- -- Throws at least 'QueryException' if query fails. -queryUTxOByTxIn :: NetworkId -> SocketPath -> QueryPoint -> [TxIn] -> IO UTxO +queryUTxOByTxIn :: + -- | Current network discriminant + NetworkId -> + -- | Filepath to the cardano-node's domain socket + SocketPath -> + QueryPoint -> + [TxIn] -> + IO UTxO queryUTxOByTxIn networkId socket queryPoint inputs = - let query = - QueryInEra - BabbageEraInCardanoMode - ( QueryInShelleyBasedEra - ShelleyBasedEraBabbage - (QueryUTxO (QueryUTxOByTxIn (Set.fromList inputs))) - ) - in UTxO.fromApi <$> (runQuery networkId socket queryPoint query >>= throwOnEraMismatch) + runQueryExpr networkId socket queryPoint $ do + (AnyCardanoEra era) <- queryCurrentEraExpr + eraUTxO <- queryInEraExpr era $ QueryUTxO (QueryUTxOByTxIn (Set.fromList inputs)) + pure $ UTxO.fromApi eraUTxO -- | Query the whole UTxO from node at given point. Useful for debugging, but -- should obviously not be used in production code. -- -- Throws at least 'QueryException' if query fails. -queryUTxOWhole :: NetworkId -> SocketPath -> QueryPoint -> IO UTxO +queryUTxOWhole :: + -- | Current network discriminant + NetworkId -> + -- | Filepath to the cardano-node's domain socket + SocketPath -> + QueryPoint -> + IO UTxO queryUTxOWhole networkId socket queryPoint = do UTxO.fromApi <$> (runQuery networkId socket queryPoint query >>= throwOnEraMismatch) where @@ -333,7 +370,13 @@ queryUTxOFor networkId nodeSocket queryPoint vk = -- | Query the current set of registered stake pools. -- -- Throws at least 'QueryException' if query fails. -queryStakePools :: NetworkId -> SocketPath -> QueryPoint -> IO (Set PoolId) +queryStakePools :: + -- | Current network discriminant + NetworkId -> + -- | Filepath to the cardano-node's domain socket + SocketPath -> + QueryPoint -> + IO (Set PoolId) queryStakePools networkId socket queryPoint = let query = QueryInEra @@ -344,6 +387,48 @@ queryStakePools networkId socket queryPoint = ) in runQuery networkId socket queryPoint query >>= throwOnEraMismatch +-- * Helpers + +-- | Monadic query expression to get current era. +queryCurrentEraExpr :: LocalStateQueryExpr b p (QueryInMode CardanoMode) r IO AnyCardanoEra +queryCurrentEraExpr = + queryExpr (QueryCurrentEra CardanoModeIsMultiEra) >>= liftIO . throwOnUnsupportedNtcVersion + +-- | Monadic query expression for a 'QueryInShelleyBasedEra'. +queryInEraExpr :: + -- | The current running era we can use to query the node + CardanoEra era -> + QueryInShelleyBasedEra era a -> + LocalStateQueryExpr b p (QueryInMode CardanoMode) r IO a +queryInEraExpr era query = + liftIO (mkQueryInEra era query) + >>= queryExpr + >>= (liftIO . throwOnUnsupportedNtcVersion) + >>= (liftIO . throwOnEraMismatch) + +-- | Construct a 'QueryInMode' from a 'CardanoEra' which is only known at +-- run-time. +-- +-- Throws a 'QueryException' if passed era is not in 'CardanoMode' or a +-- 'ShelleyBasedEra'. +mkQueryInEra :: + MonadThrow m => + -- | The current running era we can use to query the node + CardanoEra era -> + QueryInShelleyBasedEra era a -> + m (QueryInMode CardanoMode (Either EraMismatch a)) +mkQueryInEra era query = + case toEraInMode era CardanoMode of + Nothing -> throwIO $ QueryEraNotInCardanoModeFailure (anyCardanoEra era) + Just eraInMode -> do + mShelleyBaseEra <- requireShelleyBasedEra era + case mShelleyBaseEra of + Nothing -> throwIO $ QueryNotShelleyBasedEraException (anyCardanoEra era) + Just sbe -> + pure $ + QueryInEra eraInMode $ + QueryInShelleyBasedEra sbe query + -- | Throws at least 'QueryException' if query fails. runQuery :: NetworkId -> SocketPath -> QueryPoint -> QueryInMode CardanoMode a -> IO a runQuery networkId socket point query = @@ -356,7 +441,22 @@ runQuery networkId socket point query = QueryTip -> Nothing QueryAt cp -> Just cp --- * Helpers +-- | Throws at least 'QueryException' if query fails. +runQueryExpr :: + NetworkId -> + SocketPath -> + QueryPoint -> + LocalStateQueryExpr (BlockInMode CardanoMode) ChainPoint (QueryInMode CardanoMode) () IO a -> + IO a +runQueryExpr networkId socket point query = + executeLocalStateQueryExpr (localNodeConnectInfo networkId socket) maybePoint query >>= \case + Left err -> throwIO $ QueryAcquireException err + Right result -> pure result + where + maybePoint = + case point of + QueryTip -> Nothing + QueryAt cp -> Just cp throwOnEraMismatch :: MonadThrow m => Either EraMismatch a -> m a throwOnEraMismatch res = @@ -364,6 +464,12 @@ throwOnEraMismatch res = Left eraMismatch -> throwIO $ QueryEraMismatchException eraMismatch Right result -> pure result +throwOnUnsupportedNtcVersion :: MonadThrow m => Either UnsupportedNtcVersionError a -> m a +throwOnUnsupportedNtcVersion res = + case res of + Left unsupportedNtcVersion -> error $ show unsupportedNtcVersion -- TODO + Right result -> pure result + localNodeConnectInfo :: NetworkId -> SocketPath -> LocalNodeConnectInfo CardanoMode localNodeConnectInfo = LocalNodeConnectInfo cardanoModeParams diff --git a/hydra-node/src/Hydra/Chain/Direct.hs b/hydra-node/src/Hydra/Chain/Direct.hs index 6c45f928b1a..f366dc313b0 100644 --- a/hydra-node/src/Hydra/Chain/Direct.hs +++ b/hydra-node/src/Hydra/Chain/Direct.hs @@ -9,6 +9,8 @@ module Hydra.Chain.Direct ( import Hydra.Prelude +import Cardano.Api.Block (Block (ShelleyBlock)) +import Cardano.Binary (decodeFullDecoder, serialize) import Cardano.Ledger.Shelley.API qualified as Ledger import Cardano.Ledger.Slot (EpochInfo) import Cardano.Slotting.EpochInfo (hoistEpochInfo) @@ -32,11 +34,12 @@ import Hydra.Cardano.Api ( ConsensusModeParams (..), EpochSlots (..), EraHistory (EraHistory), - EraInMode (BabbageEraInCardanoMode), + EraInMode (..), LocalChainSyncClient (..), LocalNodeClientProtocols (..), LocalNodeConnectInfo (..), NetworkId, + ShelleyBasedEra (..), SocketPath, Tx, TxInMode (..), @@ -88,6 +91,8 @@ import Hydra.Logging (Tracer, traceWith) import Hydra.Options (DirectChainConfig (..)) import Hydra.Party (Party) import Ouroboros.Consensus.HardFork.History qualified as Consensus +import Ouroboros.Consensus.Shelley.Ledger (decodeShelleyBlock, encodeShelleyBlock) +import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR) import Ouroboros.Network.Magic (NetworkMagic (..)) import Ouroboros.Network.Protocol.ChainSync.Client ( ChainSyncClient (..), @@ -107,6 +112,7 @@ loadChainContext :: DirectChainConfig -> -- | Hydra party of our hydra node. Party -> + -- | The current running era we can use to query the node IO ChainContext loadChainContext config party = do (vk, _) <- readKeyPair cardanoSigningKey @@ -308,6 +314,24 @@ chainSyncClient handler wallet startingPoint = -- Observe Hydra transactions onRollForward handler header txs pure clientStIdle + BlockInMode _ block ConwayEraInCardanoMode -> do + -- TODO: uses cardano-api:internal + -- NOTE: we should remove this dependency once we have ShelleyBlock available + -- on the normal cardano-api library. + let (ShelleyBlock ShelleyBasedEraConway conwayBlock) = block + -- XXX: We should not be needing to wrap / unwrap in addition. We + -- just found those functions to satisfy the types. + let serializedBlock = serialize $ wrapCBORinCBOR encodeShelleyBlock conwayBlock + let babbageBlock = + case decodeFullDecoder "ShelleyBlock Babbage" (unwrapCBORinCBOR decodeShelleyBlock) serializedBlock of + Left e -> error $ show e + Right b -> b + let (Block header txs) = ShelleyBlock ShelleyBasedEraBabbage babbageBlock + -- Update the tiny wallet + update wallet header txs + -- Observe Hydra transactions + onRollForward handler header txs + pure clientStIdle (BlockInMode era _ _) -> throwIO $ EraNotSupportedException{ledgerEraName = show era, otherEraName = show BabbageEra} , recvMsgRollBackward = \point _tip -> ChainSyncClient $ do -- Re-initialize the tiny wallet diff --git a/hydra-node/src/Hydra/Chain/Direct/ScriptRegistry.hs b/hydra-node/src/Hydra/Chain/Direct/ScriptRegistry.hs index 3af6d6b852d..3f1b87636d1 100644 --- a/hydra-node/src/Hydra/Chain/Direct/ScriptRegistry.hs +++ b/hydra-node/src/Hydra/Chain/Direct/ScriptRegistry.hs @@ -157,7 +157,10 @@ registryUTxO scriptRegistry = -- Can throw at least 'NewScriptRegistryException' on failure. queryScriptRegistry :: (MonadIO m, MonadThrow m) => + -- | cardano-node's network identifier. + -- A combination of network discriminant + magic number. NetworkId -> + -- | Filepath to the cardano-node's domain socket SocketPath -> TxId -> m ScriptRegistry diff --git a/hydra-node/src/Hydra/Ledger/Cardano/Json.hs b/hydra-node/src/Hydra/Ledger/Cardano/Json.hs index 0b2b61854cc..65145ee0f58 100644 --- a/hydra-node/src/Hydra/Ledger/Cardano/Json.hs +++ b/hydra-node/src/Hydra/Ledger/Cardano/Json.hs @@ -18,6 +18,8 @@ import Cardano.Ledger.Alonzo.Scripts qualified as Ledger import Cardano.Ledger.Alonzo.TxAuxData qualified as Ledger import Cardano.Ledger.Alonzo.TxWits qualified as Ledger import Cardano.Ledger.Api (outputsTxBodyL) +import Cardano.Ledger.Api qualified as Ledger +import Cardano.Ledger.Api.Era (eraProtVerLow) import Cardano.Ledger.Babbage.PParams (BabbagePParams (..)) import Cardano.Ledger.Babbage.PParams qualified as Ledger import Cardano.Ledger.Babbage.Tx qualified as Ledger @@ -35,10 +37,7 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Binary.Decoding (Annotator) import Cardano.Ledger.Block (txid) -import Cardano.Ledger.Core (eraProtVerLow) import Cardano.Ledger.Core qualified as Ledger -import Cardano.Ledger.Crypto qualified as Ledger -import Cardano.Ledger.Keys qualified as Ledger import Cardano.Ledger.Mary.Value qualified as Ledger import Cardano.Ledger.SafeHash qualified as Ledger import Cardano.Ledger.Shelley.API qualified as Ledger @@ -98,8 +97,7 @@ instance FromJSON (Ledger.BabbagePParams Identity era) where .: "rho" <*> obj .: "tau" - <*> obj - .: "protocolVersion" + <*> (obj .:? "protocolVersion" .!= Ledger.ProtVer (eraProtVerLow @Ledger.Babbage) 0) <*> obj .: "minPoolCost" .!= mempty