diff --git a/.github/workflows/ci-nix.yaml b/.github/workflows/ci-nix.yaml index eb113df448f..d63fc92ee20 100644 --- a/.github/workflows/ci-nix.yaml +++ b/.github/workflows/ci-nix.yaml @@ -47,6 +47,7 @@ jobs: - name: ❓ Test if: ${{ matrix.package != 'hydra-tui' }} run: | + echo "${{secrets.blockfrost_token}}" > blockfrost-project.txt cd ${{ matrix.package }} nix build .#${{ matrix.package }}-tests nix develop .#${{ matrix.package }}-tests --command tests diff --git a/CHANGELOG.md b/CHANGELOG.md index 9fc9dde61bf..14c1f7e2e3d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -30,6 +30,8 @@ changes. - Change to the `ReqSn` message in the Hydra network protocol - Added `DepositExpired` for when a deposit was deemed expired. +- Enable blockfrost integration for hydra-node. + ## [0.21.0] - 2025-04-28 - New metric for counting the number of active peers: `hydra_head_peers_connected` diff --git a/hydra-cluster/hydra-cluster.cabal b/hydra-cluster/hydra-cluster.cabal index 1c5fb719d14..40d03130578 100644 --- a/hydra-cluster/hydra-cluster.cabal +++ b/hydra-cluster/hydra-cluster.cabal @@ -144,6 +144,7 @@ test-suite tests other-modules: Paths_hydra_cluster Spec + Test.BlockfrostChainSpec Test.CardanoClientSpec Test.CardanoNodeSpec Test.ChainObserverSpec diff --git a/hydra-cluster/src/Hydra/Cluster/Faucet.hs b/hydra-cluster/src/Hydra/Cluster/Faucet.hs index 7725662d25b..751d94b9cf5 100644 --- a/hydra-cluster/src/Hydra/Cluster/Faucet.hs +++ b/hydra-cluster/src/Hydra/Cluster/Faucet.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + module Hydra.Cluster.Faucet where import Hydra.Cardano.Api @@ -13,6 +15,7 @@ import CardanoClient ( awaitTransactionId, buildAddress, buildTransaction, + buildTransactionWithPParams', queryUTxO, queryUTxOFor, sign, @@ -21,18 +24,24 @@ import CardanoClient ( import Control.Exception (IOException) import Control.Monad.Class.MonadThrow (Handler (Handler), catches) import Control.Tracer (Tracer, traceWith) +import Data.Set qualified as Set +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import GHC.IO.Exception (IOErrorType (ResourceExhausted), IOException (ioe_type)) +import Hydra.Chain.Blockfrost.Client qualified as Blockfrost +import Hydra.Chain.Direct (DirectBackend (..)) import Hydra.Chain.ScriptRegistry ( publishHydraScripts, ) import Hydra.Cluster.Fixture (Actor (Faucet)) import Hydra.Cluster.Util (keysFor) import Hydra.Ledger.Cardano () -import Hydra.Tx (balance) +import Hydra.Options (DirectOptions (..)) +import Hydra.Tx (balance, txId) data FaucetException = FaucetHasNotEnoughFunds {faucetUTxO :: UTxO} | FaucetFailedToBuildTx {reason :: TxBodyErrorAutoBalance Era} + | FaucetBlockfrostError {blockFrostError :: Text} deriving stock (Show) instance Exception FaucetException @@ -88,6 +97,55 @@ findFaucetUTxO RunningNode{networkId, nodeSocket} lovelace = do FaucetHasNotEnoughFunds{faucetUTxO} pure foundUTxO +seedFromFaucetBlockfrost :: + -- | Recipient of the funds + VerificationKey PaymentKey -> + -- | Amount to get from faucet + Coin -> + Blockfrost.BlockfrostClientT IO UTxO +seedFromFaucetBlockfrost receivingVerificationKey lovelace = do + (faucetVk, faucetSk) <- liftIO $ keysFor Faucet + + Blockfrost.Genesis + { Blockfrost._genesisNetworkMagic = networkMagic + , Blockfrost._genesisSystemStart = systemStart' + } <- + Blockfrost.queryGenesisParameters + pparams <- Blockfrost.queryProtocolParameters + let networkId = Blockfrost.toCardanoNetworkId networkMagic + let changeAddress = buildAddress faucetVk networkId + let receivingAddress = buildAddress receivingVerificationKey networkId + let theOutput = + TxOut + (shelleyAddressInEra shelleyBasedEra receivingAddress) + (lovelaceToValue lovelace) + TxOutDatumNone + ReferenceScriptNone + stakePools' <- Blockfrost.listPools + let stakePools = Set.fromList (Blockfrost.toCardanoPoolId <$> stakePools') + let systemStart = SystemStart $ posixSecondsToUTCTime systemStart' + eraHistory <- Blockfrost.queryEraHistory + foundUTxO <- findUTxO networkId changeAddress lovelace + case buildTransactionWithPParams' pparams systemStart eraHistory stakePools (mkVkAddress networkId faucetVk) foundUTxO [] [theOutput] of + Left e -> liftIO $ throwIO $ FaucetFailedToBuildTx{reason = e} + Right tx -> do + let signedTx = signTx faucetSk tx + eResult <- Blockfrost.tryError $ Blockfrost.submitTransaction signedTx + case eResult of + Left err -> liftIO $ throwIO $ FaucetBlockfrostError{blockFrostError = show err} + Right _ -> do + void $ Blockfrost.awaitUTxO networkId [changeAddress] (txId signedTx) 100 + Blockfrost.awaitUTxO networkId [receivingAddress] (txId signedTx) 100 + where + findUTxO networkId address lovelace' = do + faucetUTxO <- Blockfrost.queryUTxO networkId [address] + let foundUTxO = UTxO.find (\o -> (selectLovelace . txOutValue) o >= lovelace') faucetUTxO + when (isNothing foundUTxO) $ + liftIO $ + throwIO $ + FaucetHasNotEnoughFunds{faucetUTxO} + pure $ maybe mempty (uncurry UTxO.singleton) foundUTxO + -- | Like 'seedFromFaucet', but without returning the seeded 'UTxO'. seedFromFaucet_ :: RunningNode -> @@ -201,6 +259,6 @@ retryOnExceptions tracer action = publishHydraScriptsAs :: RunningNode -> Actor -> IO [TxId] publishHydraScriptsAs RunningNode{networkId, nodeSocket} actor = do (_, sk) <- keysFor actor - txIds <- publishHydraScripts networkId nodeSocket sk + txIds <- publishHydraScripts (DirectBackend $ DirectOptions{networkId, nodeSocket}) sk mapM_ (awaitTransactionId networkId nodeSocket) txIds pure txIds diff --git a/hydra-cluster/src/Hydra/Cluster/Fixture.hs b/hydra-cluster/src/Hydra/Cluster/Fixture.hs index 9d04a692b5c..9a9ef01d5b2 100644 --- a/hydra-cluster/src/Hydra/Cluster/Fixture.hs +++ b/hydra-cluster/src/Hydra/Cluster/Fixture.hs @@ -27,7 +27,10 @@ bobVk = getVerificationKey bobSk carolVk = getVerificationKey carolSk cperiod :: ContestationPeriod -cperiod = 10 +cperiod = UnsafeContestationPeriod 10 + +blockfrostcperiod :: ContestationPeriod +blockfrostcperiod = UnsafeContestationPeriod 200 -- NOTE: This is hard-coded and needs to correspond to the initial funds set in -- the genesis-shelley.json file. diff --git a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs index b2aaee0915a..d3d849dac56 100644 --- a/hydra-cluster/src/Hydra/Cluster/Scenarios.hs +++ b/hydra-cluster/src/Hydra/Cluster/Scenarios.hs @@ -107,7 +107,7 @@ import Hydra.Ledger.Cardano (mkSimpleTx, mkTransferTx, unsafeBuildTransaction) import Hydra.Ledger.Cardano.Evaluate (maxTxExecutionUnits) import Hydra.Logging (Tracer, traceWith) import Hydra.Node.DepositPeriod (DepositPeriod (..)) -import Hydra.Options (DirectChainConfig (..), startChainFrom) +import Hydra.Options (CardanoChainConfig (..), startChainFrom) import Hydra.Tx (HeadId, IsTx (balance), Party, txId) import Hydra.Tx.ContestationPeriod qualified as CP import Hydra.Tx.Utils (dummyValidatorScript, verificationKeyToOnChainId) @@ -287,7 +287,7 @@ restartedNodeCanAbort tracer workDir cardanoNode hydraScriptsTxId = do chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] 2 -- we delibelately do not start from a chain point here to highlight the -- need for persistence - <&> modifyConfig (\config -> config{networkId, startChainFrom = Nothing}) + <&> modifyConfig (\config -> config{startChainFrom = Nothing}) let hydraTracer = contramap FromHydraNode tracer headId1 <- withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [] [1] $ \n1 -> do @@ -303,7 +303,7 @@ restartedNodeCanAbort tracer workDir cardanoNode hydraScriptsTxId = do waitFor hydraTracer 20 [n1] $ output "HeadIsAborted" ["utxo" .= object mempty, "headId" .= headId2] where - RunningNode{nodeSocket, networkId} = cardanoNode + RunningNode{nodeSocket} = cardanoNode nodeReObservesOnChainTxs :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> [TxId] -> IO () nodeReObservesOnChainTxs tracer workDir cardanoNode hydraScriptsTxId = do @@ -314,11 +314,11 @@ nodeReObservesOnChainTxs tracer workDir cardanoNode hydraScriptsTxId = do let contestationPeriod = 2 aliceChainConfig <- chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [Bob] contestationPeriod - <&> modifyConfig (\config -> config{networkId, startChainFrom = Nothing}) + <&> modifyConfig (\config -> config{startChainFrom = Nothing}) bobChainConfig <- chainConfigFor Bob workDir nodeSocket hydraScriptsTxId [Alice] contestationPeriod - <&> modifyConfig (\config -> config{networkId, startChainFrom = Nothing}) + <&> modifyConfig (\config -> config{startChainFrom = Nothing}) (aliceCardanoVk, aliceCardanoSk) <- keysFor Alice commitUTxO <- seedFromFaucet cardanoNode aliceCardanoVk 5_000_000 (contramap FromFaucet tracer) @@ -391,7 +391,7 @@ nodeReObservesOnChainTxs tracer workDir cardanoNode hydraScriptsTxId = do bobChainConfigFromTip <- chainConfigFor Bob workDir nodeSocket hydraScriptsTxId [Alice] contestationPeriod - <&> modifyConfig (\config -> config{networkId, startChainFrom = Just tip}) + <&> modifyConfig (\config -> config{startChainFrom = Just tip}) withTempDir "blank-state" $ \tmpDir -> do void $ readCreateProcessWithExitCode (proc "cp" ["-r", workDir "state-2", tmpDir]) "" @@ -450,7 +450,7 @@ singlePartyHeadFullLifeCycle tracer workDir node hydraScriptsTxId = contestationPeriod <- CP.fromNominalDiffTime $ 10 * blockTime aliceChainConfig <- chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] contestationPeriod - <&> modifyConfig (\config -> config{networkId, startChainFrom = Just tip}) + <&> modifyConfig (\config -> config{startChainFrom = Just tip}) withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [] [1] $ \n1 -> do -- Initialize & open head send n1 $ input "Init" [] @@ -506,7 +506,7 @@ singlePartyOpenAHead tracer workDir node hydraScriptsTxId callback = let contestationPeriod = 100 aliceChainConfig <- chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] contestationPeriod - <&> modifyConfig (\config -> config{networkId, startChainFrom = Just tip}) + <&> modifyConfig (\config -> config{startChainFrom = Just tip}) (walletVk, walletSk) <- generate genKeyPair let keyPath = workDir <> "/wallet.sk" @@ -961,7 +961,7 @@ canCloseWithLongContestationPeriod tracer workDir node hydraScriptsTxId = do let oneWeek = 60 * 60 * 24 * 7 aliceChainConfig <- chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] oneWeek - <&> modifyConfig (\config -> config{networkId, startChainFrom = Just tip}) + <&> modifyConfig (\config -> config{startChainFrom = Just tip}) let hydraTracer = contramap FromHydraNode tracer withHydraNode hydraTracer aliceChainConfig workDir 1 aliceSk [] [1] $ \n1 -> do -- Initialize & open head diff --git a/hydra-cluster/src/Hydra/Cluster/Util.hs b/hydra-cluster/src/Hydra/Cluster/Util.hs index 34e7b01e7d8..1cbdb71f68a 100644 --- a/hydra-cluster/src/Hydra/Cluster/Util.hs +++ b/hydra-cluster/src/Hydra/Cluster/Util.hs @@ -17,7 +17,8 @@ import Hydra.Cardano.Api ( textEnvelopeToJSON, ) import Hydra.Cluster.Fixture (Actor, actorName, fundsOf) -import Hydra.Options (ChainConfig (..), DirectChainConfig (..), defaultDirectChainConfig) +import Hydra.Node.DepositPeriod (DepositPeriod) +import Hydra.Options (BlockfrostOptions (..), CardanoChainConfig (..), ChainBackendOptions (..), ChainConfig (..), DirectOptions (..), defaultCardanoChainConfig, defaultDepositPeriod, defaultDirectOptions) import Hydra.Tx.ContestationPeriod (ContestationPeriod) import Paths_hydra_cluster qualified as Pkg import System.FilePath ((<.>), ()) @@ -66,7 +67,20 @@ chainConfigFor :: [Actor] -> ContestationPeriod -> IO ChainConfig -chainConfigFor me targetDir nodeSocket hydraScriptsTxId them contestationPeriod = do +chainConfigFor me targetDir nodeSocket txids actors cp = chainConfigFor' me targetDir (Right nodeSocket) txids actors cp defaultDepositPeriod + +chainConfigFor' :: + HasCallStack => + Actor -> + FilePath -> + Either FilePath SocketPath -> + -- | Transaction ids at which Hydra scripts should have been published. + [TxId] -> + [Actor] -> + ContestationPeriod -> + DepositPeriod -> + IO ChainConfig +chainConfigFor' me targetDir socketOrProjectPath hydraScriptsTxId them contestationPeriod depositPeriod = do when (me `elem` them) $ failure $ show me <> " must not be in " <> show them @@ -79,13 +93,17 @@ chainConfigFor me targetDir nodeSocket hydraScriptsTxId them contestationPeriod forM_ them $ \actor -> copyFile actor "vk" pure $ - Direct - defaultDirectChainConfig - { nodeSocket - , hydraScriptsTxId + Cardano + defaultCardanoChainConfig + { hydraScriptsTxId , cardanoSigningKey = actorFilePath me "sk" , cardanoVerificationKeys = [actorFilePath himOrHer "vk" | himOrHer <- them] , contestationPeriod + , depositPeriod + , chainBackendOptions = + case socketOrProjectPath of + Left projectPath -> Blockfrost BlockfrostOptions{projectPath} + Right nodeSocket -> Direct defaultDirectOptions{nodeSocket = nodeSocket} } where actorFilePath actor fileType = targetDir actorFileName actor fileType @@ -96,12 +114,15 @@ chainConfigFor me targetDir nodeSocket hydraScriptsTxId them contestationPeriod filePath = actorFilePath actor fileType readConfigFile ("credentials" fileName) >>= writeFileBS filePath -modifyConfig :: (DirectChainConfig -> DirectChainConfig) -> ChainConfig -> ChainConfig +modifyConfig :: (CardanoChainConfig -> CardanoChainConfig) -> ChainConfig -> ChainConfig modifyConfig fn = \case - Direct config -> Direct $ fn config + Cardano config -> Cardano $ fn config x -> x setNetworkId :: NetworkId -> ChainConfig -> ChainConfig setNetworkId networkId = \case - Direct config -> Direct config{networkId} + Cardano config@CardanoChainConfig{chainBackendOptions} -> + case chainBackendOptions of + Direct direct@DirectOptions{} -> Cardano config{chainBackendOptions = Direct direct{networkId = networkId}} + _ -> Cardano config x -> x diff --git a/hydra-cluster/src/HydraNode.hs b/hydra-cluster/src/HydraNode.hs index 108bc1beb99..94b9dd45886 100644 --- a/hydra-cluster/src/HydraNode.hs +++ b/hydra-cluster/src/HydraNode.hs @@ -20,12 +20,13 @@ import Data.ByteString (hGetContents) import Data.List qualified as List import Data.Text qualified as T import Hydra.API.HTTPServer (DraftCommitTxRequest (..), DraftCommitTxResponse (..)) +import Hydra.Chain.Blockfrost.Client qualified as Blockfrost import Hydra.Cluster.Util (readConfigFile) import Hydra.HeadLogic.State (SeenSnapshot) import Hydra.Logging (Tracer, Verbosity (..), traceWith) import Hydra.Network (Host (Host), NodeId (NodeId), WhichEtcd (EmbeddedEtcd)) import Hydra.Network qualified as Network -import Hydra.Options (ChainConfig (..), DirectChainConfig (..), LedgerConfig (..), RunOptions (..), defaultDirectChainConfig, toArgs) +import Hydra.Options (BlockfrostOptions (..), CardanoChainConfig (..), ChainBackendOptions (..), ChainConfig (..), DirectOptions (..), LedgerConfig (..), RunOptions (..), defaultCardanoChainConfig, defaultDirectOptions, nodeSocket, toArgs) import Hydra.Tx (ConfirmedSnapshot) import Hydra.Tx.ContestationPeriod (ContestationPeriod) import Hydra.Tx.Crypto (HydraKey) @@ -310,13 +311,17 @@ withHydraCluster tracer workDir nodeSocket firstNodeId allKeys hydraKeys hydraSc cardanoSigningKey = workDir show nodeId <.> "sk" cardanoVerificationKeys = [workDir show i <.> "vk" | i <- allNodeIds, i /= nodeId] chainConfig = - Direct - defaultDirectChainConfig - { nodeSocket - , hydraScriptsTxId + Cardano + defaultCardanoChainConfig + { hydraScriptsTxId , cardanoSigningKey , cardanoVerificationKeys , contestationPeriod + , chainBackendOptions = + Direct + defaultDirectOptions + { nodeSocket = nodeSocket + } } withHydraNode tracer @@ -343,9 +348,14 @@ preparePParams chainConfig stateDir paramsDecorator = do Offline _ -> readConfigFile "protocol-parameters.json" >>= writeFileBS cardanoLedgerProtocolParametersFile - Direct DirectChainConfig{nodeSocket, networkId} -> do - -- NOTE: This implicitly tests of cardano-cli with hydra-node - protocolParameters <- cliQueryProtocolParameters nodeSocket networkId + Cardano CardanoChainConfig{chainBackendOptions} -> do + protocolParameters <- case chainBackendOptions of + Direct DirectOptions{networkId, nodeSocket} -> + -- NOTE: This implicitly tests of cardano-cli with hydra-node + cliQueryProtocolParameters nodeSocket networkId + Blockfrost BlockfrostOptions{projectPath} -> do + prj <- Blockfrost.projectFromFile projectPath + toJSON <$> Blockfrost.runBlockfrostM prj Blockfrost.queryProtocolParameters Aeson.encodeFile cardanoLedgerProtocolParametersFile $ paramsDecorator protocolParameters & atKey "txFeeFixed" ?~ toJSON (Number 0) @@ -477,9 +487,15 @@ withHydraNode tracer chainConfig workDir hydraNodeId hydraSKey hydraVKeys allNod Offline _ -> readConfigFile "protocol-parameters.json" >>= writeFileBS cardanoLedgerProtocolParametersFile - Direct DirectChainConfig{nodeSocket, networkId} -> do - -- NOTE: This implicitly tests of cardano-cli with hydra-node - protocolParameters <- cliQueryProtocolParameters nodeSocket networkId + Cardano CardanoChainConfig{chainBackendOptions} -> do + protocolParameters <- case chainBackendOptions of + Direct DirectOptions{networkId, nodeSocket} -> + -- NOTE: This implicitly tests of cardano-cli with hydra-node + cliQueryProtocolParameters nodeSocket networkId + Blockfrost BlockfrostOptions{projectPath} -> do + prj <- Blockfrost.projectFromFile projectPath + toJSON <$> Blockfrost.runBlockfrostM prj Blockfrost.queryProtocolParameters + Aeson.encodeFile cardanoLedgerProtocolParametersFile $ protocolParameters & atKey "txFeeFixed" ?~ toJSON (Number 0) diff --git a/hydra-cluster/test/Test/BlockfrostChainSpec.hs b/hydra-cluster/test/Test/BlockfrostChainSpec.hs new file mode 100644 index 00000000000..07a1209ad82 --- /dev/null +++ b/hydra-cluster/test/Test/BlockfrostChainSpec.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Test.BlockfrostChainSpec where + +import Hydra.Prelude +import Test.Hydra.Prelude + +import Cardano.Api.UTxO qualified as UTxO +import CardanoClient ( + buildAddress, + ) +import Control.Concurrent.STM (newEmptyTMVarIO, takeTMVar) +import Control.Concurrent.STM.TMVar (putTMVar) +import Data.List qualified as List +import Hydra.Chain ( + Chain (Chain, draftCommitTx, postTx), + ChainEvent (..), + OnChainTx (..), + PostChainTx (..), + initHistory, + ) +import Hydra.Chain.Blockfrost (BlockfrostBackend (..), withBlockfrostChain) +import Hydra.Chain.Blockfrost.Client qualified as Blockfrost +import Hydra.Chain.Cardano (loadChainContext, mkTinyWallet) +import Hydra.Chain.Direct.Handlers (CardanoChainLog) +import Hydra.Chain.Direct.State (initialChainState) +import Hydra.Chain.ScriptRegistry (publishHydraScripts) +import Hydra.Cluster.Faucet ( + seedFromFaucetBlockfrost, + ) +import Hydra.Cluster.Fixture ( + Actor (Alice, Faucet), + alice, + aliceSk, + blockfrostcperiod, + ) +import Hydra.Cluster.Util (chainConfigFor', keysFor) +import Hydra.Ledger.Cardano (Tx) +import Hydra.Logging (Tracer, showLogsOnFailure) +import Hydra.Node.DepositPeriod (DepositPeriod (..)) +import Hydra.Options ( + BlockfrostOptions (..), + CardanoChainConfig (..), + ChainBackendOptions (..), + ChainConfig (..), + ) +import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..)) +import Hydra.Tx.Crypto (aggregate, sign) +import Hydra.Tx.HeadParameters (HeadParameters (..)) +import Hydra.Tx.IsTx (IsTx (..)) +import Hydra.Tx.Party (Party) +import Hydra.Tx.Snapshot (ConfirmedSnapshot (..), Snapshot (..)) +import Hydra.Tx.Snapshot qualified as Snapshot +import Test.DirectChainSpec ( + CardanoChainTest (..), + DirectChainTestLog (..), + externalCommit', + hasInitTxWith, + loadParticipants, + observesInTime', + observesInTimeSatisfying', + waitMatch, + ) +import Test.Hydra.Tx.Gen (genKeyPair) +import Test.QuickCheck (generate) + +spec :: Spec +spec = around (showLogsOnFailure "BlockfrostChainSpec") $ do + it "can open, close & fanout a Head using Blockfrost" $ \tracer -> do + withTempDir "hydra-cluster" $ \tmp -> do + (vk, sk) <- keysFor Faucet + let projectPath = "./../blockfrost-project.txt" + prj <- Blockfrost.projectFromFile projectPath + (aliceCardanoVk, _) <- keysFor Alice + (aliceExternalVk, aliceExternalSk) <- generate genKeyPair + hydraScriptsTxId <- publishHydraScripts (BlockfrostBackend $ BlockfrostOptions{projectPath}) sk + + Blockfrost.Genesis + { _genesisNetworkMagic + , _genesisSystemStart + } <- + Blockfrost.runBlockfrostM prj Blockfrost.queryGenesisParameters + + let networkId = Blockfrost.toCardanoNetworkId _genesisNetworkMagic + let faucetAddress = buildAddress vk networkId + -- wait to see the last txid propagated on the blockfrost network + void $ Blockfrost.runBlockfrostM prj $ Blockfrost.awaitUTxO networkId [faucetAddress] (List.last hydraScriptsTxId) 100 + + -- Alice setup + aliceChainConfig <- chainConfigFor' Alice tmp (Left projectPath) hydraScriptsTxId [] blockfrostcperiod (DepositPeriod 100) + + withBlockfrostChainTest (contramap (FromBlockfrostChain "alice") tracer) aliceChainConfig alice $ + \aliceChain@CardanoChainTest{postTx} -> do + _ <- Blockfrost.runBlockfrostM prj $ seedFromFaucetBlockfrost aliceCardanoVk 100_000_000 + someUTxO <- Blockfrost.runBlockfrostM prj $ seedFromFaucetBlockfrost aliceExternalVk 7_000_000 + -- Scenario + participants <- loadParticipants [Alice] + let headParameters = HeadParameters blockfrostcperiod [alice] + postTx $ InitTx{participants, headParameters} + (headId, headSeed) <- observesInTimeSatisfying' aliceChain 500 $ hasInitTxWith headParameters participants + + let blueprintTx = txSpendingUTxO someUTxO + externalCommit' (Left projectPath) aliceChain [aliceExternalSk] headId someUTxO blueprintTx + aliceChain `observesInTime'` OnCommitTx headId alice someUTxO + + postTx $ CollectComTx someUTxO headId headParameters + aliceChain `observesInTime'` OnCollectComTx{headId} + + let snapshotVersion = 0 + let snapshot = + Snapshot + { headId + , number = 1 + , utxo = someUTxO + , confirmed = [] + , utxoToCommit = Nothing + , utxoToDecommit = Nothing + , version = snapshotVersion + } + + postTx $ CloseTx headId headParameters snapshotVersion (ConfirmedSnapshot{snapshot, signatures = aggregate [sign aliceSk snapshot]}) + + deadline <- + waitMatch aliceChain $ \case + Observation{observedTx = OnCloseTx{snapshotNumber, contestationDeadline}} + | snapshotNumber == 1 -> Just contestationDeadline + _ -> Nothing + + waitMatch aliceChain $ \case + Tick t _ | t > deadline -> Just () + _ -> Nothing + postTx $ + FanoutTx + { utxo = Snapshot.utxo snapshot + , utxoToCommit = Nothing + , utxoToDecommit = Nothing + , headSeed + , contestationDeadline = deadline + } + let expectedUTxO = + (Snapshot.utxo snapshot <> fromMaybe mempty (Snapshot.utxoToCommit snapshot)) + `withoutUTxO` fromMaybe mempty (Snapshot.utxoToDecommit snapshot) + observesInTimeSatisfying' aliceChain 500 $ \case + OnFanoutTx _ finalUTxO -> + if UTxO.containsOutputs finalUTxO expectedUTxO + then pure () + else failure "OnFanoutTx does not contain expected UTxO" + _ -> failure "expected OnFanoutTx" + +-- | Wrapper around 'withBlockfrostChain' that threads a 'ChainStateType tx' through +-- 'postTx' and 'waitCallback' calls. +withBlockfrostChainTest :: + Tracer IO CardanoChainLog -> + ChainConfig -> + Party -> + (CardanoChainTest Tx IO -> IO a) -> + IO a +withBlockfrostChainTest tracer config party action = do + (configuration, backend) <- + case config of + Cardano cfg@CardanoChainConfig{chainBackendOptions} -> + case chainBackendOptions of + Blockfrost blockfrostOptions -> pure (cfg, BlockfrostBackend blockfrostOptions) + _ -> failure $ "unexpected chainBackendOptions: " <> show chainBackendOptions + otherConfig -> failure $ "unexpected chainConfig: " <> show otherConfig + ctx <- loadChainContext backend configuration party + eventMVar <- newEmptyTMVarIO + + let callback event = atomically $ putTMVar eventMVar event + + wallet <- mkTinyWallet backend tracer configuration + withBlockfrostChain backend tracer configuration ctx wallet (initHistory initialChainState) callback $ \Chain{postTx, draftCommitTx} -> do + action + CardanoChainTest + { postTx + , waitCallback = atomically $ takeTMVar eventMVar + , draftCommitTx = \headId utxo blueprintTx -> do + eTx <- draftCommitTx headId $ CommitBlueprintTx{lookupUTxO = utxo, blueprintTx} + case eTx of + Left e -> throwIO e + Right tx -> pure tx + } diff --git a/hydra-cluster/test/Test/DirectChainSpec.hs b/hydra-cluster/test/Test/DirectChainSpec.hs index 5628c1d4203..d24923c92e3 100644 --- a/hydra-cluster/test/Test/DirectChainSpec.hs +++ b/hydra-cluster/test/Test/DirectChainSpec.hs @@ -31,6 +31,7 @@ import Hydra.Cardano.Api ( UTxO', fromLedgerTx, lovelaceToValue, + serialiseToRawBytesHexText, signTx, toLedgerKeyHash, toLedgerTx, @@ -46,13 +47,10 @@ import Hydra.Chain ( PostTxError (..), initHistory, ) -import Hydra.Chain.Direct ( - IntersectionNotFoundException (..), - loadChainContext, - mkTinyWallet, - withDirectChain, - ) -import Hydra.Chain.Direct.Handlers (DirectChainLog) +import Hydra.Chain.Blockfrost.Client qualified as Blockfrost +import Hydra.Chain.Cardano (loadChainContext, mkTinyWallet) +import Hydra.Chain.Direct (DirectBackend (..), IntersectionNotFoundException (..), withDirectChain) +import Hydra.Chain.Direct.Handlers (CardanoChainLog) import Hydra.Chain.Direct.State (initialChainState) import Hydra.Chain.ScriptRegistry (queryScriptRegistry) import Hydra.Cluster.Faucet ( @@ -73,8 +71,9 @@ import Hydra.Cluster.Util (chainConfigFor, keysFor, modifyConfig, readConfigFile import Hydra.Ledger.Cardano (Tx) import Hydra.Logging (Tracer, nullTracer, showLogsOnFailure) import Hydra.Options ( + CardanoChainConfig (..), + ChainBackendOptions (..), ChainConfig (..), - DirectChainConfig (..), toArgNetworkId, ) import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..)) @@ -105,10 +104,10 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do hydraScriptsTxId <- publishHydraScriptsAs node Faucet -- Alice setup aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [Bob, Carol] cperiod - withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ \aliceChain@DirectChainTest{postTx} -> do + withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ \aliceChain@CardanoChainTest{postTx} -> do -- Bob setup bobChainConfig <- chainConfigFor Bob tmp nodeSocket hydraScriptsTxId [Alice, Carol] cperiod - withDirectChainTest nullTracer bobChainConfig bob $ \bobChain@DirectChainTest{} -> do + withDirectChainTest nullTracer bobChainConfig bob $ \bobChain@CardanoChainTest{} -> do -- Scenario participants <- loadParticipants [Alice, Bob, Carol] let headParameters = HeadParameters cperiod [alice, bob, carol] @@ -132,11 +131,11 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [Bob, Carol] cperiod withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx} -> do + \aliceChain@CardanoChainTest{postTx} -> do -- Bob setup bobChainConfig <- chainConfigFor Bob tmp nodeSocket hydraScriptsTxId [Alice, Carol] cperiod withDirectChainTest (contramap (FromDirectChain "bob") tracer) bobChainConfig bob $ - \bobChain@DirectChainTest{} -> do + \bobChain@CardanoChainTest{} -> do -- Scenario let aliceCommitment = 66_000_000 -- Mimic "external commit" by using different keys for Alice. @@ -180,14 +179,14 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [] cperiod withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx = alicePostTx} -> do + \aliceChain@CardanoChainTest{postTx = alicePostTx} -> do -- Bob setup (bobCardanoVk, _) <- keysFor Bob seedFromFaucet_ node bobCardanoVk 100_000_000 (contramap FromFaucet tracer) bobChainConfig <- chainConfigFor Bob tmp nodeSocket hydraScriptsTxId [] cperiod withDirectChainTest nullTracer bobChainConfig bob $ - \bobChain@DirectChainTest{postTx = bobPostTx} -> do + \bobChain@CardanoChainTest{postTx = bobPostTx} -> do -- Scenario aliceParticipants <- loadParticipants [Carol, Alice] let headParameters = HeadParameters cperiod [alice, carol] @@ -214,7 +213,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [] cperiod withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx} -> do + \aliceChain@CardanoChainTest{postTx} -> do participants <- loadParticipants [Alice] let headParameters = HeadParameters cperiod [alice] postTx $ InitTx{participants, headParameters} @@ -235,7 +234,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [] cperiod withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx} -> do + \aliceChain@CardanoChainTest{postTx} -> do participants <- loadParticipants [Alice] let headParameters = HeadParameters cperiod [alice] postTx $ InitTx{participants, headParameters} @@ -255,7 +254,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [] cperiod withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx} -> do + \aliceChain@CardanoChainTest{postTx} -> do -- Scenario participants <- loadParticipants [Alice] let headParameters = HeadParameters cperiod [alice] @@ -275,7 +274,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [] cperiod withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx} -> do + \aliceChain@CardanoChainTest{postTx} -> do -- Scenario participants <- loadParticipants [Alice] let headParameters = HeadParameters cperiod [alice] @@ -295,7 +294,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do <>~ Set.fromList (toLedgerKeyHash . verificationKeyHash . fst <$> randomKeys) ) - externalCommit' node aliceChain (aliceExternalSk : fmap snd randomKeys) headId newAliceUTxO blueprintTx + externalCommit' (Right node) aliceChain (aliceExternalSk : fmap snd randomKeys) headId newAliceUTxO blueprintTx aliceChain `observesInTime` OnCommitTx headId alice newAliceUTxO it "can open, close & fanout a Head" $ \tracer -> do @@ -307,7 +306,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [] cperiod withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx} -> do + \aliceChain@CardanoChainTest{postTx} -> do -- Scenario (aliceExternalVk, aliceExternalSk) <- generate genKeyPair someUTxO <- seedFromFaucet node aliceExternalVk 2_000_000 (contramap FromFaucet tracer) @@ -386,7 +385,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do let headParameters = HeadParameters cperiod [alice] -- Scenario tip <- withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx} -> do + \aliceChain@CardanoChainTest{postTx} -> do tip <- queryTip networkId nodeSocket postTx $ InitTx{participants, headParameters} void $ aliceChain `observesInTimeSatisfying` hasInitTxWith headParameters participants @@ -396,7 +395,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do -- REVIEW: It's a bit weird now that we would use the original chain -- state here. Does this test even make sense with persistence? withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig' alice $ - \aliceChain@DirectChainTest{} -> + \aliceChain@CardanoChainTest{} -> void $ aliceChain `observesInTimeSatisfying` hasInitTxWith headParameters participants it "cannot restart head to an unknown point" $ \tracer -> do @@ -446,7 +445,7 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do seedFromFaucet_ node aliceCardanoVk 100_000_000 (contramap FromFaucet tracer) aliceChainConfig <- chainConfigFor Alice tmp nodeSocket hydraScriptsTxId [] cperiod withDirectChainTest (contramap (FromDirectChain "alice") tracer) aliceChainConfig alice $ - \aliceChain@DirectChainTest{postTx} -> do + \aliceChain@CardanoChainTest{postTx} -> do (aliceExternalVk, aliceExternalSk) <- generate genKeyPair someUTxO <- seedFromFaucet node aliceExternalVk 1_000_000 (contramap FromFaucet tracer) @@ -528,12 +527,13 @@ spec = around (showLogsOnFailure "DirectChainSpec") $ do data DirectChainTestLog = FromNode NodeLog - | FromDirectChain Text DirectChainLog + | FromDirectChain Text CardanoChainLog + | FromBlockfrostChain Text CardanoChainLog | FromFaucet FaucetLog deriving stock (Show, Generic) deriving anyclass (ToJSON) -data DirectChainTest tx m = DirectChainTest +data CardanoChainTest tx m = CardanoChainTest { postTx :: PostChainTx tx -> m () , waitCallback :: m (ChainEvent tx) , draftCommitTx :: HeadId -> UTxOType tx -> tx -> m tx @@ -542,25 +542,28 @@ data DirectChainTest tx m = DirectChainTest -- | Wrapper around 'withDirectChain' that threads a 'ChainStateType tx' through -- 'postTx' and 'waitCallback' calls. withDirectChainTest :: - Tracer IO DirectChainLog -> + Tracer IO CardanoChainLog -> ChainConfig -> Party -> - (DirectChainTest Tx IO -> IO a) -> + (CardanoChainTest Tx IO -> IO a) -> IO a withDirectChainTest tracer config party action = do - directConfig <- case config of - Direct cfg -> pure cfg - otherConfig -> failure $ "unexpected chainConfig: " <> show otherConfig - ctx <- loadChainContext directConfig party + (configuration, backend) <- + case config of + Cardano cfg@CardanoChainConfig{chainBackendOptions} -> + case chainBackendOptions of + Direct directOptions -> pure (cfg, DirectBackend directOptions) + _ -> failure $ "unexpected chainBackendOptions: " <> show chainBackendOptions + otherConfig -> failure $ "unexpected chainConfig: " <> show otherConfig + ctx <- loadChainContext backend configuration party eventMVar <- newEmptyTMVarIO let callback event = atomically $ putTMVar eventMVar event - wallet <- mkTinyWallet tracer directConfig - - withDirectChain tracer directConfig ctx wallet (initHistory initialChainState) callback $ \Chain{postTx, draftCommitTx} -> do + wallet <- mkTinyWallet backend tracer configuration + withDirectChain backend tracer configuration ctx wallet (initHistory initialChainState) callback $ \Chain{postTx, draftCommitTx} -> do action - DirectChainTest + CardanoChainTest { postTx , waitCallback = atomically $ takeTMVar eventMVar , draftCommitTx = \headId utxo blueprintTx -> do @@ -579,13 +582,20 @@ hasInitTxWith HeadParameters{contestationPeriod = expectedContestationPeriod, pa pure (headId, headSeed) tx -> failure ("Unexpected observation: " <> show tx) -observesInTime :: IsTx tx => DirectChainTest tx IO -> OnChainTx tx -> IO () +observesInTime :: IsTx tx => CardanoChainTest tx IO -> OnChainTx tx -> IO () observesInTime chain expected = observesInTimeSatisfying chain (`shouldBe` expected) -observesInTimeSatisfying :: DirectChainTest tx IO -> (OnChainTx tx -> IO a) -> IO a -observesInTimeSatisfying DirectChainTest{waitCallback} check = - failAfter 10 go +observesInTimeSatisfying :: CardanoChainTest tx IO -> (OnChainTx tx -> IO a) -> IO a +observesInTimeSatisfying directChainTest = observesInTimeSatisfying' directChainTest 10 + +observesInTime' :: IsTx tx => CardanoChainTest tx IO -> OnChainTx tx -> IO () +observesInTime' chain expected = + observesInTimeSatisfying' chain 200 (`shouldBe` expected) + +observesInTimeSatisfying' :: CardanoChainTest tx IO -> NominalDiffTime -> (OnChainTx tx -> IO a) -> IO a +observesInTimeSatisfying' CardanoChainTest{waitCallback} waitTime check = + failAfter waitTime go where go = do e <- waitCallback @@ -595,8 +605,8 @@ observesInTimeSatisfying DirectChainTest{waitCallback} check = _TickOrRollback -> go -waitMatch :: DirectChainTest tx IO -> (ChainEvent tx -> Maybe b) -> IO b -waitMatch DirectChainTest{waitCallback} match = go +waitMatch :: CardanoChainTest tx IO -> (ChainEvent tx -> Maybe b) -> IO b +waitMatch CardanoChainTest{waitCallback} match = go where go = do a <- waitCallback @@ -610,32 +620,46 @@ delayUntil target = do -- Commit using a wallet/external unknown to a hydra-node. externalCommit :: RunningNode -> - DirectChainTest Tx IO -> + CardanoChainTest Tx IO -> SigningKey PaymentKey -> HeadId -> UTxO' (TxOut CtxUTxO) -> IO () externalCommit node hydraClient externalSk headId utxoToCommit = do let blueprintTx = txSpendingUTxO utxoToCommit - externalCommit' node hydraClient [externalSk] headId utxoToCommit blueprintTx + externalCommit' (Right node) hydraClient [externalSk] headId utxoToCommit blueprintTx externalCommit' :: - RunningNode -> - DirectChainTest Tx IO -> + Either FilePath RunningNode -> + CardanoChainTest Tx IO -> [SigningKey PaymentKey] -> HeadId -> UTxO' (TxOut CtxUTxO) -> Tx -> IO () -externalCommit' node hydraClient externalSks headId utxoToCommit blueprintTx = do +externalCommit' projectPathOrNode hydraClient externalSks headId utxoToCommit blueprintTx = do commitTx <- draftCommitTx headId utxoToCommit blueprintTx let signedTx = everybodySigns commitTx externalSks - submitTx node signedTx + case projectPathOrNode of + Left projectPath -> do + prj <- Blockfrost.projectFromFile projectPath + void $ + Blockfrost.runBlockfrostM prj $ do + void $ Blockfrost.submitTransaction signedTx + + Blockfrost.Genesis + { _genesisNetworkMagic + , _genesisSystemStart + } <- + Blockfrost.queryGenesisParameters + let networkId = Blockfrost.toCardanoNetworkId _genesisNetworkMagic + void $ Blockfrost.queryUTxOByTxIn networkId (serialiseToRawBytesHexText $ txId signedTx) + Right node -> submitTx node signedTx where everybodySigns tx' [] = tx' everybodySigns tx' (sk : sks) = everybodySigns (signTx sk tx') sks - DirectChainTest{draftCommitTx} = hydraClient + CardanoChainTest{draftCommitTx} = hydraClient -- | Load key files for given 'Actor's (see keysFor) and directly convert them to 'OnChainId'. loadParticipants :: [Actor] -> IO [OnChainId] diff --git a/hydra-cluster/test/Test/EndToEndSpec.hs b/hydra-cluster/test/Test/EndToEndSpec.hs index b3f93e313e8..b109904ec59 100644 --- a/hydra-cluster/test/Test/EndToEndSpec.hs +++ b/hydra-cluster/test/Test/EndToEndSpec.hs @@ -575,10 +575,15 @@ spec = around (showLogsOnFailure "EndToEndSpec") $ do withCardanoNodeDevnet (contramap FromCardanoNode tracer) dir $ \RunningNode{nodeSocket} -> do -- NOTE: Deliberately broken configuration so we expect the node to not start. let chainConfig = - Direct - defaultDirectChainConfig - { nodeSocket - , cardanoSigningKey = "not-existing.sk" + Cardano + defaultCardanoChainConfig + { cardanoSigningKey = "not-existing.sk" + , chainBackendOptions = + Direct + DirectOptions + { networkId = Hydra.Options.networkId defaultDirectOptions + , nodeSocket = nodeSocket + } } withHydraNode (contramap FromHydraNode tracer) chainConfig dir 1 aliceSk [] [1] (const $ pure ()) `shouldThrow` \(e :: SomeException) -> diff --git a/hydra-node/exe/hydra-node/Main.hs b/hydra-node/exe/hydra-node/Main.hs index 8a1511d7d97..cbf12ad368a 100644 --- a/hydra-node/exe/hydra-node/Main.hs +++ b/hydra-node/exe/hydra-node/Main.hs @@ -9,12 +9,13 @@ import Control.Exception (AsyncException (UserInterrupt), throwTo) import Data.ByteString (intercalate) import GHC.Weak (deRefWeak) import Hydra.Cardano.Api (serialiseToRawBytesHex) -import Hydra.Chain.Blockfrost.Client qualified as Blockfrost +import Hydra.Chain.Blockfrost (BlockfrostBackend (..)) +import Hydra.Chain.Direct (DirectBackend (..)) import Hydra.Chain.ScriptRegistry (publishHydraScripts) import Hydra.Logging (Verbosity (..)) import Hydra.Node.Run (run) import Hydra.Node.Util (readKeyPair) -import Hydra.Options (ChainBackend (..), Command (GenHydraKey, Publish, Run), PublishOptions (..), RunOptions (..), parseHydraCommand) +import Hydra.Options (ChainBackendOptions (..), Command (GenHydraKey, Publish, Run), PublishOptions (..), RunOptions (..), parseHydraCommand) import Hydra.Utils (genHydraKeys) import System.Posix.Signals qualified as Signals @@ -31,13 +32,13 @@ main = do GenHydraKey outputFile -> either (die . show) pure =<< genHydraKeys outputFile where - publish PublishOptions{chainBackend, publishSigningKey} = do + publish PublishOptions{chainBackendOptions, publishSigningKey} = do (_, sk) <- readKeyPair publishSigningKey - txIds <- case chainBackend of - DirectBackend{publishNetworkId, publishNodeSocket} -> - publishHydraScripts publishNetworkId publishNodeSocket sk - BlockfrostBackend{projectPath} -> - Blockfrost.publishHydraScripts projectPath sk + txIds <- case chainBackendOptions of + Direct directOptions -> + publishHydraScripts (DirectBackend directOptions) sk + Blockfrost blockfrostOptions -> + publishHydraScripts (BlockfrostBackend blockfrostOptions) sk putBSLn $ intercalate "," (serialiseToRawBytesHex <$> txIds) -- | Handle SIGTERM like SIGINT diff --git a/hydra-node/golden/RunOptions.json b/hydra-node/golden/RunOptions.json index 69521c473ef..ccf5eab9483 100644 --- a/hydra-node/golden/RunOptions.json +++ b/hydra-node/golden/RunOptions.json @@ -8,33 +8,29 @@ }, "apiPort": 28651, "chainConfig": { - "cardanoSigningKey": "c.sk", - "cardanoVerificationKeys": [ - "b/a/a.vk", - "a/a/a.vk", - "b/b/c.vk", - "b/b.vk", - "a/c/a.vk" - ], - "contestationPeriod": 11010, - "depositPeriod": 130, + "cardanoSigningKey": "a/a/a/b/b.sk", + "cardanoVerificationKeys": [], + "chainBackendOptions": { + "contents": { + "projectPath": "blockfrost-project.txt" + }, + "tag": "Blockfrost" + }, + "contestationPeriod": 36181, + "depositPeriod": 20565, "hydraScriptsTxId": [ - "88e381408dcd681c0f0bbd894c5202feede5c8790dbdff3a5de50b2fdeca0396", - "52aea27bb01d5f1c3fdccde7d40f8d743cc397c0d1d810bfb1d96fd3ac934f09", - "7ac013be0386ba006230e2f5ca7cba3cd6ffa141482090295316040a44f3baad", - "9511f25390a2a1fb31ea3b0dc50a2cba229454bf91ac39a7d0f6c418531bd6cf" + "0204060600060300030101030106040602070308010003080308030607070204", + "0706000004020104010600010504000508040302030508080403060803040401", + "0007060104000608050006070105060400010604060206000604080100020606", + "0606060106010308060005060102060503060303070002040507080100040502", + "0808040800010801050007080508040304010600020107070603070508060206" ], - "networkId": { - "magic": 17173, - "tag": "Testnet" - }, - "nodeSocket": "c/b/c/b.socket", "startChainFrom": { - "blockHash": "e91d38ce75292b953dff607a22049f145e2a863af3b699fef80282e3302fe26d", - "slot": 7277012, + "blockHash": "5702e13b130dbed8ed57778d585530ec0cb93ba9c6d3898201d2b4455ebe915b", + "slot": 5009519, "tag": "ChainPoint" }, - "tag": "DirectChainConfig" + "tag": "CardanoChainConfig" }, "hydraSigningKey": "b/c/b/b/a/b.sk", "hydraVerificationKeys": [ @@ -81,27 +77,30 @@ }, "apiPort": 21824, "chainConfig": { - "cardanoSigningKey": "c/c/a.sk", + "cardanoSigningKey": "a/c/b/b/a.sk", "cardanoVerificationKeys": [ - "a/c/c.vk" + "b/c.vk", + "a.vk" ], - "contestationPeriod": 43200, - "depositPeriod": 276, + "chainBackendOptions": { + "contents": { + "projectPath": "blockfrost-project.txt" + }, + "tag": "Blockfrost" + }, + "contestationPeriod": 604800, + "depositPeriod": 77091, "hydraScriptsTxId": [ - "78f200fbf81bfd7f6f811d34087e6cd06a72bf807244916d98692af49a975333", - "99eb953e33a038bd0439480eb9127808b4c75c38a4d2da1ea037bb519edf42ed", - "83e830b4dd023557bcca04ca01e0e38bffea112a768122eec3539adfd61d3647", - "f72387516313f58c624c1f2ebeafba9179b689a0f92b2b57e68d1c8e69adeb61", - "a6af8d534b0c444f7e66399f6bbdf43c913a4e7804439da219570654d7be09d3", - "c9f4fc68734893b785feec5285339e2e4646dabc5d12b98ba97f9163a28715b7" + "0603030805040507050206050502000703070300070307020007080605010706", + "0601010506060003060105050604010808000002080101060606000402070604", + "0008060605000007060801020806050408020207050505040700070008010500" ], - "networkId": { - "magic": 20635, - "tag": "Testnet" + "startChainFrom": { + "blockHash": "94d85c82a657c59dfa2ec73e33a198fe18675723520e373ef26753b9cf690eb7", + "slot": 13175187, + "tag": "ChainPoint" }, - "nodeSocket": "a.socket", - "startChainFrom": null, - "tag": "DirectChainConfig" + "tag": "CardanoChainConfig" }, "hydraSigningKey": "a/c/b.sk", "hydraVerificationKeys": [], @@ -143,34 +142,30 @@ }, "apiPort": 9075, "chainConfig": { - "cardanoSigningKey": "c/a/a.sk", + "cardanoSigningKey": "b/c/b.sk", "cardanoVerificationKeys": [ - "c/b/c.vk", - "a/c/b.vk", - "a/c/a.vk", - "b/c/a.vk" + "a.vk", + "c/c.vk" ], - "contestationPeriod": 86400, - "depositPeriod": 127, + "chainBackendOptions": { + "contents": { + "networkId": { + "magic": 42, + "tag": "Testnet" + }, + "nodeSocket": "node.socket" + }, + "tag": "Direct" + }, + "contestationPeriod": 53328, + "depositPeriod": 13685, "hydraScriptsTxId": [ - "d24e0f81e846d16c252517b3ded6dfaa6113dcb21e2126061ccc06777e2ac0a9", - "b7867e38c9bacf628b1381aa846cbbf8eee9d12d63ae8c8eaa21787181518d0d", - "f1a3037acfcdf078a9dc396067e94a76f2ba9f83a18f5ae80884bdc66fc26d66", - "a6933ec59bd6fadbba45ee28724284d118eec905a33c925a5a292b7d7a5c0bed", - "15e1f608e89afd1f2964f9cf1e297151328f523bcc36efbcf4f9d7cfd85fdfc3", - "727ad1baf77c1c62b6c24beeadb8092911ec067c1f53b9ba001b64e7ff05c90a", - "edfccbe82c9ab63213d77d24e068880034fd0d5a8cc95e0bdafec4c4e7e0a3b1", - "9beda0aed3eb215bac64481fb46651c05192c919e3824915e012c5426be6052e", - "261a72d1046c0d90a27845f074f4e91c40a689af6ed140f1fa209b19919a47c9", - "53f2c7a61b5c88851d4c36e769454bb427266dd44c66974ec180f2a784cfe31f" + "0803070100080004060607050207020500080706040408010108030308040000", + "0803080203010705030706060305030706030108060600020208020504030104", + "0804050802000600000504070104040800050500030405060004010803020100" ], - "networkId": { - "magic": 5794, - "tag": "Testnet" - }, - "nodeSocket": "c.socket", "startChainFrom": null, - "tag": "DirectChainConfig" + "tag": "CardanoChainConfig" }, "hydraSigningKey": "c/c/c/c.sk", "hydraVerificationKeys": [ @@ -226,38 +221,33 @@ }, "apiPort": 6700, "chainConfig": { - "cardanoSigningKey": "c/c/a/b/a/b.sk", + "cardanoSigningKey": "a/a/b/b.sk", "cardanoVerificationKeys": [ - "c/b.vk", - "c.vk", - "c/a.vk" + "b/c/b.vk", + "b/b.vk", + "c/b/a.vk", + "a.vk", + "b.vk" ], - "contestationPeriod": 2592000, - "depositPeriod": 80, + "chainBackendOptions": { + "contents": { + "projectPath": "blockfrost-project.txt" + }, + "tag": "Blockfrost" + }, + "contestationPeriod": 86400, + "depositPeriod": 73355, "hydraScriptsTxId": [ - "83683fb93e6b35eea8ab0979be707b0a7870dd6a3a929abb9a24438b884a8703", - "fdbc1cdcdd654a2e0985407b71e5ae5cb4754358628ce5e46b1f29c22e96041b", - "d2f518bf1a2ad88b10609952e70a864ea52b0d87c016a3a74a8805e4ddf1c0e1", - "4e52a122265ccfd49c01ee46419b2166897fefcd072e714aeb5f474c92bd2d2d", - "1122a671449c6503361f6d9121d064514621ae789c831b0edc73eac97a7127ad", - "80561210ca02e94224c845c9bb5c40613de695db9a03090ace1c6f1666bd63dd", - "edf610eb3d58df02c0061afb84f7caf217eaeb38420586da7d39b396a27e5fb5", - "a1f0ae57e88098fb1679c2fdad95950ee86292847a35b6102a36d1f623aaa489", - "9410f9c50a546e7c4f47482a7e79a8a81781d67d815db97d746f7265c22bdd5d", - "52c58d65dd811c16b1405ff46ac9dbda460bc314fcd8e9a0588f1129d3d3a3f9", - "965e84d7dadc652379b5ebc56b4a5796626fa32a05fd526ea3996c4a346fa6d5" + "0505020800060200070105030403000502030400000800070007010501060800", + "0703080004080308060407000004060501070808040606060100060504050505", + "0601080101060206020806060200020708080107060706000802030005080505" ], - "networkId": { - "magic": 25749, - "tag": "Testnet" - }, - "nodeSocket": "c/c/c/b/b/c.socket", "startChainFrom": { - "blockHash": "339fd8d359095560ebaaffa0d782854b6fd38f641ec178562871a75b1778f94a", - "slot": 4949497, + "blockHash": "f4dddbb1b9c60c5606a7f4a837be9a4e11a93b3fa9344b3d052c684470ca445b", + "slot": 14872327, "tag": "ChainPoint" }, - "tag": "DirectChainConfig" + "tag": "CardanoChainConfig" }, "hydraSigningKey": "b/c/b/b/b.sk", "hydraVerificationKeys": [ diff --git a/hydra-node/hydra-node.cabal b/hydra-node/hydra-node.cabal index b182fdee159..37d80212e25 100644 --- a/hydra-node/hydra-node.cabal +++ b/hydra-node/hydra-node.cabal @@ -55,9 +55,10 @@ library Hydra.API.ServerOutputFilter Hydra.API.WSServer Hydra.Chain + Hydra.Chain.Backend Hydra.Chain.Blockfrost Hydra.Chain.Blockfrost.Client - Hydra.Chain.Blockfrost.TimeHandle + Hydra.Chain.Cardano Hydra.Chain.CardanoClient Hydra.Chain.Direct Hydra.Chain.Direct.Handlers @@ -100,16 +101,19 @@ library build-depends: , aeson , base + , base16-bytestring , blockfrost-client >=0.9.2.0 , bytestring , cardano-api , cardano-binary , cardano-crypto-class + , cardano-crypto-wrapper , cardano-ledger-alonzo , cardano-ledger-api , cardano-ledger-babbage , cardano-ledger-babbage:testlib , cardano-ledger-binary + , cardano-ledger-byron , cardano-ledger-conway , cardano-ledger-conway:testlib , cardano-ledger-core @@ -152,6 +156,7 @@ library , quickcheck-arbitrary-adt , quickcheck-instances , resourcet + , retry , safe-money , serialise , sop-extras @@ -330,6 +335,7 @@ test-suite tests , contra-tracer , directory , filepath + , generic-lens , hedgehog-quickcheck , hspec , hspec-golden-aeson diff --git a/hydra-node/src/Hydra/Chain/Backend.hs b/hydra-node/src/Hydra/Chain/Backend.hs new file mode 100644 index 00000000000..b7bc4cc9381 --- /dev/null +++ b/hydra-node/src/Hydra/Chain/Backend.hs @@ -0,0 +1,38 @@ +module Hydra.Chain.Backend where + +import Hydra.Prelude + +import Hydra.Cardano.Api ( + Address, + ChainPoint, + EraHistory, + GenesisParameters, + LedgerEra, + NetworkId, + PParams, + PaymentKey, + PoolId, + ShelleyAddr, + ShelleyEra, + SystemStart (..), + Tx, + TxId, + UTxO, + VerificationKey, + ) +import Hydra.Chain.CardanoClient qualified as CardanoClient +import Hydra.Tx (ScriptRegistry) + +class ChainBackend a where + queryGenesisParameters :: (MonadIO m, MonadThrow m) => a -> m (GenesisParameters ShelleyEra) + queryScriptRegistry :: (MonadIO m, MonadThrow m) => a -> [TxId] -> m ScriptRegistry + queryNetworkId :: (MonadIO m, MonadThrow m) => a -> m NetworkId + queryTip :: (MonadIO m, MonadThrow m) => a -> m ChainPoint + queryUTxO :: (MonadIO m, MonadThrow m) => a -> [Address ShelleyAddr] -> m UTxO + queryEraHistory :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> m EraHistory + querySystemStart :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> m SystemStart + queryProtocolParameters :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> m (PParams LedgerEra) + queryStakePools :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> m (Set PoolId) + queryUTxOFor :: (MonadIO m, MonadThrow m) => a -> CardanoClient.QueryPoint -> VerificationKey PaymentKey -> m UTxO + submitTransaction :: (MonadIO m, MonadThrow m) => a -> Tx -> m () + awaitTransaction :: (MonadIO m, MonadThrow m) => a -> Tx -> m UTxO diff --git a/hydra-node/src/Hydra/Chain/Blockfrost.hs b/hydra-node/src/Hydra/Chain/Blockfrost.hs index 302a0a06827..87206c906d3 100644 --- a/hydra-node/src/Hydra/Chain/Blockfrost.hs +++ b/hydra-node/src/Hydra/Chain/Blockfrost.hs @@ -2,66 +2,332 @@ module Hydra.Chain.Blockfrost where import Hydra.Prelude -import Blockfrost.Client qualified as Blockfrost -import Cardano.Ledger.Shelley.API qualified as Ledger -import Cardano.Slotting.EpochInfo.API (EpochInfo, hoistEpochInfo) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Control.Concurrent.Class.MonadSTM (newEmptyTMVar, newTQueueIO, newTVarIO, putTMVar, readTQueue, readTVarIO, takeTMVar, writeTQueue, writeTVar) +import Control.Exception (IOException) +import Control.Retry (constantDelay, retrying) +import Data.ByteString.Base16 qualified as Base16 +import Data.Text qualified as T import Hydra.Cardano.Api ( - EraHistory (..), - SystemStart (..), - runExcept, - toLedgerUTxO, - ) -import Hydra.Chain.Blockfrost.Client ( - mkEraHistory, - queryGenesis, - queryTip, - queryUTxO, - runBlockfrostM, - toCardanoNetworkId, - toCardanoPParams, + BlockHeader (..), + ChainPoint (..), + Hash, + SlotNo (..), + Tx, + deserialiseFromCBOR, + getTxBody, + getTxId, + proxyToAsType, + serialiseToRawBytes, ) +import Hydra.Chain (ChainComponent, ChainStateHistory, PostTxError (..), currentState) +import Hydra.Chain.Backend (ChainBackend (..)) +import Hydra.Chain.Blockfrost.Client qualified as Blockfrost import Hydra.Chain.Direct.Handlers ( - DirectChainLog (..), - ) -import Hydra.Chain.Direct.Wallet ( - TinyWallet (..), - WalletInfoOnChain (..), - newTinyWallet, + CardanoChainLog (..), + ChainSyncHandler (..), + chainSyncHandler, + mkChain, + newLocalChainState, ) -import Hydra.Logging (Tracer) -import Hydra.Node.Util ( - readKeyPair, - ) -import Hydra.Options (BlockfrostChainConfig (..)) -import Ouroboros.Consensus.HardFork.History qualified as Consensus - -mkTinyWallet :: - Tracer IO DirectChainLog -> - BlockfrostChainConfig -> - IO (TinyWallet IO) -mkTinyWallet tracer config = do - keyPair@(_, sk) <- readKeyPair cardanoSigningKey - prj <- Blockfrost.projectFromFile projectPath - runBlockfrostM prj $ do - Blockfrost.Genesis{_genesisSystemStart, _genesisNetworkMagic} <- queryGenesis - let networkId = toCardanoNetworkId _genesisNetworkMagic - eraHistory <- mkEraHistory - let queryEpochInfo = pure $ toEpochInfo eraHistory - -- NOTE: we don't need to provide address here since it is derived from the - -- keypair but we still want to keep the same wallet api. - let queryWalletInfo queryPoint _address = runBlockfrostM prj $ do - point <- queryTip queryPoint - utxo <- queryUTxO sk networkId - let walletUTxO = Ledger.unUTxO $ toLedgerUTxO utxo - let systemStart = SystemStart $ posixSecondsToUTCTime _genesisSystemStart - pure $ WalletInfoOnChain{walletUTxO, systemStart, tip = point} - let querySomePParams = runBlockfrostM prj toCardanoPParams - liftIO $ newTinyWallet (contramap Wallet tracer) networkId keyPair queryWalletInfo queryEpochInfo querySomePParams +import Hydra.Chain.Direct.State (ChainContext, ChainStateAt (..)) +import Hydra.Chain.Direct.TimeHandle (queryTimeHandle) +import Hydra.Chain.Direct.Wallet (TinyWallet (..)) +import Hydra.Logging (Tracer, traceWith) +import Hydra.Options (BlockfrostOptions (..), CardanoChainConfig (..)) + +newtype BlockfrostBackend = BlockfrostBackend {options :: BlockfrostOptions} + +instance ChainBackend BlockfrostBackend where + queryGenesisParameters (BlockfrostBackend BlockfrostOptions{projectPath}) = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.toCardanoGenesisParameters <$> Blockfrost.runBlockfrostM prj Blockfrost.queryGenesisParameters + + queryScriptRegistry (BlockfrostBackend BlockfrostOptions{projectPath}) txIds = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.runBlockfrostM prj $ Blockfrost.queryScriptRegistry txIds + + queryNetworkId (BlockfrostBackend BlockfrostOptions{projectPath}) = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + -- TODO: This calls to queryGenesisParameters again, but we only need the network magic + Blockfrost.Genesis{_genesisNetworkMagic} <- Blockfrost.runBlockfrostM prj Blockfrost.queryGenesisParameters + pure $ Blockfrost.toCardanoNetworkId _genesisNetworkMagic + + queryTip (BlockfrostBackend BlockfrostOptions{projectPath}) = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.runBlockfrostM prj Blockfrost.queryTip + + queryUTxO (BlockfrostBackend BlockfrostOptions{projectPath}) addresses = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.Genesis + { _genesisNetworkMagic + , _genesisSystemStart + } <- + Blockfrost.runBlockfrostM prj Blockfrost.queryGenesisParameters + let networkId = Blockfrost.toCardanoNetworkId _genesisNetworkMagic + Blockfrost.runBlockfrostM prj $ Blockfrost.queryUTxO networkId addresses + + queryEraHistory (BlockfrostBackend BlockfrostOptions{projectPath}) _ = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.runBlockfrostM prj Blockfrost.queryEraHistory + + querySystemStart (BlockfrostBackend BlockfrostOptions{projectPath}) _ = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.runBlockfrostM prj Blockfrost.querySystemStart + + queryProtocolParameters (BlockfrostBackend BlockfrostOptions{projectPath}) _ = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.runBlockfrostM prj Blockfrost.queryProtocolParameters + + queryStakePools (BlockfrostBackend BlockfrostOptions{projectPath}) _ = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.runBlockfrostM prj Blockfrost.queryStakePools + + queryUTxOFor (BlockfrostBackend BlockfrostOptions{projectPath}) _ vk = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.runBlockfrostM prj $ Blockfrost.queryUTxOFor vk + + submitTransaction (BlockfrostBackend BlockfrostOptions{projectPath}) tx = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + void $ Blockfrost.runBlockfrostM prj $ Blockfrost.submitTransaction tx + + awaitTransaction (BlockfrostBackend BlockfrostOptions{projectPath}) tx = do + prj <- liftIO $ Blockfrost.projectFromFile projectPath + Blockfrost.runBlockfrostM prj $ Blockfrost.awaitTransaction tx + +withBlockfrostChain :: + BlockfrostBackend -> + Tracer IO CardanoChainLog -> + CardanoChainConfig -> + ChainContext -> + TinyWallet IO -> + -- | Chain state loaded from persistence. + ChainStateHistory Tx -> + ChainComponent Tx IO a +withBlockfrostChain backend tracer config ctx wallet chainStateHistory callback action = do + -- Last known point on chain as loaded from persistence. + let persistedPoint = recordedAt (currentState chainStateHistory) + queue <- newTQueueIO + -- Select a chain point from which to start synchronizing + chainPoint <- maybe (queryTip backend) pure $ do + (max <$> startChainFrom <*> persistedPoint) + <|> persistedPoint + <|> startChainFrom + + let getTimeHandle = queryTimeHandle backend + localChainState <- newLocalChainState chainStateHistory + let chainHandle = + mkChain + tracer + getTimeHandle + wallet + ctx + localChainState + (submitTx queue) + + let handler = chainSyncHandler tracer callback getTimeHandle ctx localChainState + res <- + race + ( handle onIOException $ do + prj <- Blockfrost.projectFromFile projectPath + blockfrostChain tracer queue prj chainPoint handler wallet + ) + (action chainHandle) + case res of + Left () -> error "'connectTo' cannot terminate but did?" + Right a -> pure a + where + BlockfrostBackend{options = BlockfrostOptions{projectPath}} = backend + CardanoChainConfig{startChainFrom} = config + + submitTx queue tx = do + response <- atomically $ do + response <- newEmptyTMVar + writeTQueue queue (tx, response) + return response + atomically (takeTMVar response) + >>= maybe (pure ()) throwIO + + onIOException :: IOException -> IO () + onIOException ioException = + throwIO $ + BlockfrostConnectException + { ioException + } + +newtype BlockfrostConnectException = BlockfrostConnectException + { ioException :: IOException + } + deriving stock (Show) + +instance Exception BlockfrostConnectException + +blockfrostChain :: + (MonadIO m, MonadCatch m, MonadAsync m, MonadDelay m) => + Tracer m CardanoChainLog -> + TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) -> + Blockfrost.Project -> + ChainPoint -> + ChainSyncHandler m -> + TinyWallet m -> + m () +blockfrostChain tracer queue prj chainPoint handler wallet = do + forever $ + race_ + (blockfrostChainFollow tracer prj chainPoint handler wallet) + (blockfrostSubmissionClient prj tracer queue) + +blockfrostChainFollow :: + (MonadIO m, MonadCatch m, MonadSTM m, MonadDelay m) => + Tracer m CardanoChainLog -> + Blockfrost.Project -> + ChainPoint -> + ChainSyncHandler m -> + TinyWallet m -> + m () +blockfrostChainFollow tracer prj chainPoint handler wallet = do + Blockfrost.Genesis{_genesisSlotLength, _genesisActiveSlotsCoefficient} <- Blockfrost.runBlockfrostM prj Blockfrost.getLedgerGenesis + + Blockfrost.Block{_blockHash = (Blockfrost.BlockHash genesisBlockHash)} <- + Blockfrost.runBlockfrostM prj (Blockfrost.getBlock (Left 0)) + + let blockTime :: Double = realToFrac _genesisSlotLength / realToFrac _genesisActiveSlotsCoefficient + + let blockHash = fromChainPoint chainPoint genesisBlockHash + + stateTVar <- newTVarIO blockHash + + void $ + retrying (retryPolicy blockTime) shouldRetry $ \_ -> do + loop stateTVar + `catch` \(ex :: APIBlockfrostError) -> + pure $ Left ex where - BlockfrostChainConfig{projectPath, cardanoSigningKey} = config + shouldRetry _ = \case + Right{} -> pure False + Left err -> pure $ isRetryable err + + retryPolicy blockTime' = constantDelay (truncate blockTime' * 1000 * 1000) + + loop stateTVar = do + current <- readTVarIO stateTVar + nextBlockHash <- rollForward tracer prj handler wallet 1 current + threadDelay 1 + atomically $ writeTVar stateTVar nextBlockHash + loop stateTVar + +rollForward :: + (MonadIO m, MonadThrow m) => + Tracer m CardanoChainLog -> + Blockfrost.Project -> + ChainSyncHandler m -> + TinyWallet m -> + Integer -> + Blockfrost.BlockHash -> + m Blockfrost.BlockHash +rollForward tracer prj handler wallet blockConfirmations blockHash = do + block@Blockfrost.Block + { _blockHash + , _blockConfirmations + , _blockNextBlock + , _blockHeight + , _blockSlot + , _blockTime + } <- + Blockfrost.runBlockfrostM prj $ Blockfrost.getBlock (Right blockHash) + + -- Check if block within the safe zone to be processes + when (_blockConfirmations < blockConfirmations) $ + throwIO (NotEnoughBlockConfirmations _blockHash) + + -- Search block transactions + txHashesCBOR <- Blockfrost.runBlockfrostM prj . Blockfrost.allPages $ \p -> + Blockfrost.getBlockTxsCBOR' (Right _blockHash) p Blockfrost.def + + -- Check if block contains a reference to its next + nextBlockHash <- maybe (throwIO $ MissingNextBlockHash _blockHash) pure _blockNextBlock + + -- Convert to cardano-api Tx + receivedTxs <- mapM (toTx . (\(Blockfrost.TxHashCBOR (_txHash, cbor)) -> cbor)) txHashesCBOR + let receivedTxIds = getTxId . getTxBody <$> receivedTxs + let point = toChainPoint block + traceWith tracer RolledForward{point, receivedTxIds} + + blockNo <- maybe (throwIO $ MissingBlockNo _blockHash) (pure . fromInteger) _blockHeight + let Blockfrost.BlockHash blockHash' = _blockHash + let blockHash'' = fromString $ T.unpack blockHash' + blockSlot <- maybe (throwIO $ MissingBlockSlot _blockSlot) (pure . fromInteger . Blockfrost.unSlot) _blockSlot + let header = BlockHeader (SlotNo blockSlot) blockHash'' blockNo + -- wallet update + update wallet header receivedTxs + + onRollForward handler header receivedTxs + + pure nextBlockHash + +blockfrostSubmissionClient :: + forall m. + (MonadIO m, MonadDelay m, MonadSTM m) => + Blockfrost.Project -> + Tracer m CardanoChainLog -> + TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) -> + m () +blockfrostSubmissionClient prj tracer queue = bfClient + where + bfClient = do + (tx, response) <- atomically $ readTQueue queue + let txId = getTxId $ getTxBody tx + traceWith tracer PostingTx{txId} + res <- liftIO $ Blockfrost.tryError $ Blockfrost.runBlockfrost prj $ Blockfrost.submitTransaction tx + case res of + Left err -> do + let postTxError = FailedToPostTx{failureReason = show err} + traceWith tracer PostingFailed{tx, postTxError} + threadDelay 1 + atomically (putTMVar response (Just postTxError)) + Right _ -> do + traceWith tracer PostedTx{txId} + atomically (putTMVar response Nothing) + bfClient + +toChainPoint :: Blockfrost.Block -> ChainPoint +toChainPoint Blockfrost.Block{_blockSlot, _blockHash} = + ChainPoint slotNo headerHash + where + slotNo :: SlotNo + slotNo = maybe 0 (fromInteger . Blockfrost.unSlot) _blockSlot + + headerHash :: Hash BlockHeader + headerHash = fromString . toString $ Blockfrost.unBlockHash _blockHash + +-- * Helpers + +data APIBlockfrostError + = BlockfrostError Text + | DecodeError Text + | NotEnoughBlockConfirmations Blockfrost.BlockHash + | MissingBlockNo Blockfrost.BlockHash + | MissingBlockSlot (Maybe Blockfrost.Slot) + | MissingNextBlockHash Blockfrost.BlockHash + deriving (Show, Exception) + +isRetryable :: APIBlockfrostError -> Bool +isRetryable (BlockfrostError _) = True +isRetryable (DecodeError _) = False +isRetryable (NotEnoughBlockConfirmations _) = True +isRetryable (MissingBlockNo _) = True +isRetryable (MissingBlockSlot _) = True +isRetryable (MissingNextBlockHash _) = True + +toTx :: MonadThrow m => Blockfrost.TransactionCBOR -> m Tx +toTx (Blockfrost.TransactionCBOR txCbor) = + case decodeBase16 txCbor of + Left decodeErr -> throwIO . DecodeError $ "Bad Base16 Tx CBOR: " <> decodeErr + Right bytes -> + case deserialiseFromCBOR (proxyToAsType (Proxy @Tx)) bytes of + Left deserializeErr -> throwIO . DecodeError $ "Bad Tx CBOR: " <> show deserializeErr + Right tx -> pure tx - toEpochInfo :: EraHistory -> EpochInfo (Either Text) - toEpochInfo (EraHistory interpreter) = - hoistEpochInfo (first show . runExcept) $ - Consensus.interpreterToEpochInfo interpreter +fromChainPoint :: ChainPoint -> Text -> Blockfrost.BlockHash +fromChainPoint chainPoint genesisBlockHash = case chainPoint of + ChainPoint _ headerHash -> Blockfrost.BlockHash (decodeUtf8 . Base16.encode . serialiseToRawBytes $ headerHash) + ChainPointAtGenesis -> Blockfrost.BlockHash genesisBlockHash diff --git a/hydra-node/src/Hydra/Chain/Blockfrost/Client.hs b/hydra-node/src/Hydra/Chain/Blockfrost/Client.hs index 7dcd7524bfc..0f28e888e5c 100644 --- a/hydra-node/src/Hydra/Chain/Blockfrost/Client.hs +++ b/hydra-node/src/Hydra/Chain/Blockfrost/Client.hs @@ -1,19 +1,42 @@ {-# LANGUAGE RecordWildCards #-} -module Hydra.Chain.Blockfrost.Client where +module Hydra.Chain.Blockfrost.Client ( + module Hydra.Chain.Blockfrost.Client, + module Blockfrost.Client, +) where import Hydra.Prelude import Blockfrost.Client ( + Block (..), + BlockHash (..), BlockfrostClientT, + Genesis (..), + Project, + Slot (..), + TransactionCBOR (..), + TxHashCBOR (..), + allPages, + def, + getBlock, + getBlockTxsCBOR', + getLedgerGenesis, + listPools, + projectFromFile, runBlockfrost, + tryError, + unBlockHash, + unSlot, ) import Blockfrost.Client qualified as Blockfrost +import Cardano.Chain.Genesis (mainnetProtocolMagicId) +import Cardano.Crypto.ProtocolMagic (ProtocolMagicId (..)) import Data.Map.Strict qualified as Map import Data.Time.Clock.POSIX -import Hydra.Cardano.Api hiding (LedgerState, fromNetworkMagic) +import Hydra.Cardano.Api hiding (LedgerState, fromNetworkMagic, queryGenesisParameters) import Cardano.Api.UTxO qualified as UTxO +import Cardano.Crypto.Hash (hashToTextAsHex) import Cardano.Ledger.Api.PParams import Cardano.Ledger.BaseTypes (EpochInterval (..), EpochSize (..), NonNegativeInterval, UnitInterval, boundRational, unsafeNonZero) import Cardano.Ledger.Binary.Version (mkVersion) @@ -35,23 +58,32 @@ import Cardano.Ledger.Plutus.CostModels (CostModels, mkCostModel, mkCostModels) import Cardano.Ledger.Shelley.API (ProtVer (..)) import Cardano.Slotting.Time (RelativeTime (..), mkSlotLength) import Control.Lens ((.~), (^.)) -import Data.Default (def) +import Data.List qualified as List import Data.SOP.NonEmpty (nonEmptyFromList) import Data.Set qualified as Set import Data.Text qualified as T import Hydra.Cardano.Api.Prelude (StakePoolKey, fromNetworkMagic) -import Hydra.Chain.CardanoClient (QueryPoint (..)) -import Hydra.Chain.ScriptRegistry (buildScriptPublishingTxs) -import Hydra.Tx (txId) +import Hydra.Tx (ScriptRegistry, newScriptRegistry) import Money qualified import Ouroboros.Consensus.Block (GenesisWindow (..)) import Ouroboros.Consensus.HardFork.History (Bound (..), EraEnd (..), EraParams (..), EraSummary (..), SafeZone (..), Summary (..), mkInterpreter) -data APIBlockfrostError - = BlockfrostError Text +data BlockfrostException + = TimeoutOnUTxO TxId + | FailedToDecodeAddress Text + | ByronAddressNotSupported + | FailedUTxOForHash Text + | FailedEraHistory + | AssetNameMissing + | DeserialiseError Text | DecodeError Text + | BlockfrostAPIError Text deriving (Show, Exception) +newtype APIBlockfrostError + = BlockfrostError BlockfrostException + deriving newtype (Show, Exception) + runBlockfrostM :: (MonadIO m, MonadThrow m) => Blockfrost.Project -> @@ -60,156 +92,38 @@ runBlockfrostM :: runBlockfrostM prj action = do result <- liftIO $ runBlockfrost prj action case result of - Left err -> throwIO (BlockfrostError $ show err) + Left err -> throwIO $ BlockfrostError $ BlockfrostAPIError (show err) Right val -> pure val -publishHydraScripts :: - -- | The path where the Blockfrost project token hash is stored. - FilePath -> - -- | Keys assumed to hold funds to pay for the publishing transaction. - SigningKey PaymentKey -> - IO [TxId] -publishHydraScripts projectPath sk = do - prj <- Blockfrost.projectFromFile projectPath - runBlockfrostM prj $ do - Blockfrost.Genesis - { _genesisNetworkMagic = networkMagic - , _genesisSystemStart = systemStart' - } <- - queryGenesis - pparams <- toCardanoPParams - let address = Blockfrost.Address (vkAddress networkMagic) - let networkId = toCardanoNetworkId networkMagic - let changeAddress = mkVkAddress networkId vk - stakePools' <- Blockfrost.listPools - let stakePools = Set.fromList (toCardanoPoolId <$> stakePools') - let systemStart = SystemStart $ posixSecondsToUTCTime systemStart' - eraHistory <- mkEraHistory - utxo <- Blockfrost.getAddressUtxos address - let cardanoUTxO = toCardanoUTxO utxo changeAddress - - txs <- liftIO $ buildScriptPublishingTxs pparams systemStart networkId eraHistory stakePools cardanoUTxO sk - forM txs $ \(tx :: Tx) -> do - void $ Blockfrost.submitTx $ Blockfrost.CBORString $ fromStrict $ serialiseToCBOR tx - pure $ txId tx - where - vk = getVerificationKey sk - - vkAddress networkMagic = textAddrOf (toCardanoNetworkId networkMagic) vk - -scriptTypeToPlutusVersion :: Blockfrost.ScriptType -> Maybe Language -scriptTypeToPlutusVersion = \case - Blockfrost.PlutusV1 -> Just PlutusV1 - Blockfrost.PlutusV2 -> Just PlutusV2 - Blockfrost.PlutusV3 -> Just PlutusV3 - Blockfrost.Timelock -> Nothing - -toCardanoPoolId :: Blockfrost.PoolId -> Hash StakePoolKey -toCardanoPoolId (Blockfrost.PoolId textPoolId) = - case deserialiseFromRawBytesHex (encodeUtf8 textPoolId) of - Left err -> error (show err) - Right pool -> pool - -toCardanoUTxO :: [Blockfrost.AddressUtxo] -> AddressInEra -> UTxO' (TxOut CtxUTxO) -toCardanoUTxO utxos addr = UTxO.fromList (toEntry <$> utxos) - where - toEntry :: Blockfrost.AddressUtxo -> (TxIn, TxOut CtxUTxO) - toEntry utxo = (toCardanoTxIn utxo, toCardanoTxOut utxo addr) - -toCardanoTxIn :: Blockfrost.AddressUtxo -> TxIn -toCardanoTxIn Blockfrost.AddressUtxo{_addressUtxoTxHash = Blockfrost.TxHash{unTxHash}, _addressUtxoOutputIndex} = - case deserialiseFromRawBytesHex (encodeUtf8 unTxHash) of - Left err -> error (show err) - Right txid -> TxIn txid (TxIx (fromIntegral _addressUtxoOutputIndex)) - --- REVIEW! TxOutDatumNone and ReferenceScriptNone -toCardanoTxOut :: Blockfrost.AddressUtxo -> AddressInEra -> TxOut CtxUTxO -toCardanoTxOut addrUTxO addr = - TxOut addr (toCardanoValue _addressUtxoAmount) TxOutDatumNone ReferenceScriptNone - where - Blockfrost.AddressUtxo{_addressUtxoAmount, _addressUtxoDataHash, _addressUtxoInlineDatum, _addressUtxoReferenceScriptHash} = addrUTxO - -toCardanoPolicyId :: Text -> PolicyId -toCardanoPolicyId pid = - case deserialiseFromRawBytesHex (encodeUtf8 pid) of - Left err -> error (show err) - Right p -> p - -toCardanoAssetName :: Text -> AssetName -toCardanoAssetName = AssetName . encodeUtf8 - -toCardanoValue :: [Blockfrost.Amount] -> Value -toCardanoValue = foldMap convertAmount +-- | Query for 'TxIn's in the search for outputs containing all the reference +-- scripts of the 'ScriptRegistry'. +-- +-- This is implemented by repeated querying until we have all necessary +-- reference scripts as we do only know the transaction id, not the indices. +-- +-- Can throw at least 'NewScriptRegistryException' on failure. +queryScriptRegistry :: + [TxId] -> + BlockfrostClientT IO ScriptRegistry +queryScriptRegistry txIds = do + Blockfrost.Genesis + { _genesisNetworkMagic + , _genesisSystemStart + } <- + queryGenesisParameters + let networkId = toCardanoNetworkId _genesisNetworkMagic + utxoList <- forM candidates $ \(TxIn (TxId candidateHash) _) -> queryUTxOByTxIn networkId $ hashToTextAsHex candidateHash + case newScriptRegistry $ fold utxoList of + Left e -> liftIO $ throwIO e + Right sr -> pure sr where - convertAmount (Blockfrost.AdaAmount lovelaces) = - fromList - [ - ( AdaAssetId - , Quantity (toInteger lovelaces) - ) - ] - convertAmount (Blockfrost.AssetAmount money) = - let currency = Money.someDiscreteCurrency money - in fromList - [ - ( AssetId - (toCardanoPolicyId currency) - (toCardanoAssetName currency) - , Quantity (Money.someDiscreteAmount money) - ) - ] - --- ** Helpers - -unwrapAddress :: AddressInEra -> Text -unwrapAddress = \case - ShelleyAddressInEra addr -> serialiseToBech32 addr - ByronAddressInEra{} -> error "Byron." + candidates = map (\txid -> TxIn txid (TxIx 0)) txIds -textAddrOf :: NetworkId -> VerificationKey PaymentKey -> Text -textAddrOf networkId vk = unwrapAddress (mkVkAddress @Era networkId vk) - -toCardanoNetworkId :: Integer -> NetworkId -toCardanoNetworkId = \case - 0 -> Mainnet - magicNbr -> Testnet (NetworkMagic (fromInteger magicNbr)) - -data BlockfrostConversion - = BlockfrostConversion - { a0 :: NonNegativeInterval - , rho :: UnitInterval - , tau :: UnitInterval - , priceMemory :: NonNegativeInterval - , priceSteps :: NonNegativeInterval - , pvtMotionNoConfidence :: UnitInterval - , pvtCommitteeNormal :: UnitInterval - , pvtCommitteeNoConfidence :: UnitInterval - , pvtHardForkInitiation :: UnitInterval - , pvtPPSecurityGroup :: UnitInterval - , dvtMotionNoConfidence :: UnitInterval - , dvtCommitteeNormal :: UnitInterval - , dvtCommitteeNoConfidence :: UnitInterval - , dvtUpdateToConstitution :: UnitInterval - , dvtHardForkInitiation :: UnitInterval - , dvtPPNetworkGroup :: UnitInterval - , dvtPPEconomicGroup :: UnitInterval - , dvtPPTechnicalGroup :: UnitInterval - , dvtPPGovGroup :: UnitInterval - , dvtTreasuryWithdrawal :: UnitInterval - , committeeMinSize :: Blockfrost.Quantity - , committeeMaxTermLength :: Blockfrost.Quantity - , govActionLifetime :: Blockfrost.Quantity - , govActionDeposit :: Coin - , drepDeposit :: Integer - , drepActivity :: Blockfrost.Quantity - , minFeeRefScriptCostPerByte :: NonNegativeInterval - } - -toCardanoPParams :: MonadIO m => BlockfrostClientT m (PParams LedgerEra) -toCardanoPParams = do +queryProtocolParameters :: MonadIO m => BlockfrostClientT m (PParams LedgerEra) +queryProtocolParameters = do pparams <- Blockfrost.getLatestEpochProtocolParams - minVersion <- liftIO $ mkVersion $ pparams ^. Blockfrost.protocolMinorVer - let maxVersion = fromIntegral $ pparams ^. Blockfrost.protocolMajorVer + let minVersion = fromIntegral $ pparams ^. Blockfrost.protocolMinorVer + maxVersion <- liftIO $ mkVersion $ pparams ^. Blockfrost.protocolMajorVer let results = do a0 <- boundRational (pparams ^. Blockfrost.a0) rho <- boundRational (pparams ^. Blockfrost.rho) @@ -257,13 +171,13 @@ toCardanoPParams = do & ppA0L .~ a0 & ppRhoL .~ rho & ppTauL .~ tau - & ppProtocolVersionL .~ ProtVer minVersion maxVersion + & ppProtocolVersionL .~ ProtVer maxVersion minVersion & ppMinPoolCostL .~ fromIntegral (pparams ^. Blockfrost.minPoolCost) & ppCoinsPerUTxOByteL .~ CoinPerByte (fromIntegral (pparams ^. Blockfrost.coinsPerUtxoSize)) - & ppCostModelsL .~ convertCostModels (pparams ^. Blockfrost.costModels) + & ppCostModelsL .~ convertCostModels (pparams ^. Blockfrost.costModelsRaw) & ppPricesL .~ Prices priceMemory priceSteps - & ppMaxTxExUnitsL .~ ExUnits (fromIntegral $ Blockfrost.unQuantity $ pparams ^. Blockfrost.maxTxExSteps) (fromIntegral $ Blockfrost.unQuantity $ pparams ^. Blockfrost.maxTxExMem) - & ppMaxBlockExUnitsL .~ ExUnits (fromIntegral $ Blockfrost.unQuantity $ pparams ^. Blockfrost.maxBlockExSteps) (fromIntegral $ Blockfrost.unQuantity $ pparams ^. Blockfrost.maxBlockExMem) + & ppMaxTxExUnitsL .~ ExUnits (fromIntegral $ Blockfrost.unQuantity $ pparams ^. Blockfrost.maxTxExMem) (fromIntegral $ Blockfrost.unQuantity $ pparams ^. Blockfrost.maxTxExSteps) + & ppMaxBlockExUnitsL .~ ExUnits (fromIntegral $ Blockfrost.unQuantity $ pparams ^. Blockfrost.maxBlockExMem) (fromIntegral $ Blockfrost.unQuantity $ pparams ^. Blockfrost.maxBlockExSteps) & ppMaxValSizeL .~ fromIntegral (Blockfrost.unQuantity $ pparams ^. Blockfrost.maxValSize) & ppCollateralPercentageL .~ fromIntegral (pparams ^. Blockfrost.collateralPercent) & ppMaxCollateralInputsL .~ fromIntegral (pparams ^. Blockfrost.maxCollateralInputs) @@ -277,22 +191,157 @@ toCardanoPParams = do & ppDRepActivityL .~ EpochInterval (fromIntegral $ Blockfrost.unQuantity drepActivity) & ppMinFeeRefScriptCostPerByteL .~ minFeeRefScriptCostPerByte where - convertCostModels :: Blockfrost.CostModels -> CostModels + convertCostModels :: Blockfrost.CostModelsRaw -> CostModels convertCostModels costModels = - let costModelsMap = Blockfrost.unCostModels costModels + let costModelsMap = Blockfrost.unCostModelsRaw costModels in foldMap ( (mempty <>) . ( \(scriptType, v) -> case scriptTypeToPlutusVersion scriptType of Nothing -> mempty Just plutusScript -> - case mkCostModel plutusScript (fromIntegral <$> Map.elems v) of + case mkCostModel plutusScript (fromIntegral <$> v) of Left _ -> mempty Right costModel -> mkCostModels $ Map.singleton plutusScript costModel ) ) (Map.toList costModelsMap) +-- ** Helpers + +toCardanoUTxO :: NetworkId -> TxIn -> Blockfrost.Address -> Maybe Blockfrost.ScriptHash -> Maybe Blockfrost.DatumHash -> [Blockfrost.Amount] -> Maybe Blockfrost.InlineDatum -> BlockfrostClientT IO (UTxO' (TxOut ctx)) +toCardanoUTxO networkId txIn address scriptHash datumHash amount inlineDatum = do + let addrTxt = Blockfrost.unAddress address + let datumHash' = Blockfrost.unDatumHash <$> datumHash + let inlineDatum' = Blockfrost._scriptDatumCborCbor . Blockfrost.unInlineDatum <$> inlineDatum + val <- toCardanoValue amount + plutusScript <- maybe (pure Nothing) (queryScript . Blockfrost.unScriptHash) scriptHash + o <- toCardanoTxOut networkId addrTxt val datumHash' inlineDatum' plutusScript + pure $ UTxO.singleton txIn o + +scriptTypeToPlutusVersion :: Blockfrost.ScriptType -> Maybe Language +scriptTypeToPlutusVersion = \case + Blockfrost.PlutusV1 -> Just PlutusV1 + Blockfrost.PlutusV2 -> Just PlutusV2 + Blockfrost.PlutusV3 -> Just PlutusV3 + Blockfrost.Timelock -> Nothing + +toCardanoPoolId :: Blockfrost.PoolId -> Hash StakePoolKey +toCardanoPoolId (Blockfrost.PoolId textPoolId) = + case deserialiseFromRawBytesHex (encodeUtf8 textPoolId) of + Left err -> error (show err) + Right pool -> pool + +toCardanoTxIn :: Text -> Integer -> TxIn +toCardanoTxIn txHash i = + case deserialiseFromRawBytesHex (encodeUtf8 txHash) of + Left err -> error (show err) + Right txid -> TxIn txid (TxIx (fromIntegral i)) + +toCardanoTxOut :: NetworkId -> Text -> Value -> Maybe Text -> Maybe Text -> Maybe PlutusScript -> BlockfrostClientT IO (TxOut ctx) +toCardanoTxOut networkId addrTxt val mDatumHash mInlineDatum plutusScript = do + let datum = + case mInlineDatum of + Nothing -> + case mDatumHash of + Nothing -> TxOutDatumNone + Just datumHash -> TxOutDatumHash (fromString $ T.unpack datumHash) + Just cborDatum -> + case deserialiseFromCBOR (proxyToAsType (Proxy @HashableScriptData)) (encodeUtf8 cborDatum) of + Left _ -> TxOutDatumNone + Right hashableScriptData -> TxOutDatumInline hashableScriptData + case plutusScript of + Nothing -> do + case toCardanoAddress addrTxt of + Nothing -> liftIO $ throwIO $ BlockfrostError $ FailedToDecodeAddress addrTxt + Just addr -> pure $ TxOut addr val datum ReferenceScriptNone + Just script -> pure $ TxOut (scriptAddr script) val datum (mkScriptRef script) + where + scriptAddr script = + makeShelleyAddressInEra + shelleyBasedEra + networkId + (PaymentCredentialByScript $ hashScript $ PlutusScript script) + NoStakeAddress + +toCardanoPolicyIdAndAssetName :: Text -> BlockfrostClientT IO (PolicyId, AssetName) +toCardanoPolicyIdAndAssetName pid = do + Blockfrost.AssetDetails{_assetDetailsPolicyId, _assetDetailsAssetName} <- Blockfrost.getAssetDetails (Blockfrost.mkAssetId pid) + case deserialiseFromRawBytesHex (encodeUtf8 $ Blockfrost.unPolicyId _assetDetailsPolicyId) of + Left err -> liftIO $ throwIO $ BlockfrostError $ DeserialiseError (show err) + Right p -> + case _assetDetailsAssetName of + Nothing -> liftIO $ throwIO $ BlockfrostError AssetNameMissing + Just assetName -> + case deserialiseFromRawBytesHex (encodeUtf8 assetName) of + Left err -> liftIO $ throwIO $ BlockfrostError $ DeserialiseError (show err) + Right asset -> pure (p, asset) + +toCardanoValue :: [Blockfrost.Amount] -> BlockfrostClientT IO Value +toCardanoValue = foldMapM convertAmount + where + convertAmount (Blockfrost.AdaAmount lovelaces) = + pure $ + fromList + [ + ( AdaAssetId + , Quantity (toInteger lovelaces) + ) + ] + convertAmount (Blockfrost.AssetAmount money) = do + let currency = Money.someDiscreteCurrency money + (cardanoPolicyId, assetName) <- toCardanoPolicyIdAndAssetName currency + pure $ + fromList + [ + ( AssetId + cardanoPolicyId + assetName + , Quantity (Money.someDiscreteAmount money) + ) + ] + +toCardanoAddress :: Text -> Maybe AddressInEra +toCardanoAddress addrTxt = + ShelleyAddressInEra <$> deserialiseAddress (AsAddress AsShelleyAddr) addrTxt + +toCardanoNetworkId :: Integer -> NetworkId +toCardanoNetworkId magic = + if fromIntegral magic == unProtocolMagicId mainnetProtocolMagicId + then Mainnet + else Testnet (NetworkMagic (fromInteger magic)) + +data BlockfrostConversion + = BlockfrostConversion + { a0 :: NonNegativeInterval + , rho :: UnitInterval + , tau :: UnitInterval + , priceMemory :: NonNegativeInterval + , priceSteps :: NonNegativeInterval + , pvtMotionNoConfidence :: UnitInterval + , pvtCommitteeNormal :: UnitInterval + , pvtCommitteeNoConfidence :: UnitInterval + , pvtHardForkInitiation :: UnitInterval + , pvtPPSecurityGroup :: UnitInterval + , dvtMotionNoConfidence :: UnitInterval + , dvtCommitteeNormal :: UnitInterval + , dvtCommitteeNoConfidence :: UnitInterval + , dvtUpdateToConstitution :: UnitInterval + , dvtHardForkInitiation :: UnitInterval + , dvtPPNetworkGroup :: UnitInterval + , dvtPPEconomicGroup :: UnitInterval + , dvtPPTechnicalGroup :: UnitInterval + , dvtPPGovGroup :: UnitInterval + , dvtTreasuryWithdrawal :: UnitInterval + , committeeMinSize :: Blockfrost.Quantity + , committeeMaxTermLength :: Blockfrost.Quantity + , govActionLifetime :: Blockfrost.Quantity + , govActionDeposit :: Coin + , drepDeposit :: Integer + , drepActivity :: Blockfrost.Quantity + , minFeeRefScriptCostPerByte :: NonNegativeInterval + } + toCardanoGenesisParameters :: Blockfrost.Genesis -> GenesisParameters ShelleyEra toCardanoGenesisParameters bfGenesis = GenesisParameters @@ -322,14 +371,21 @@ toCardanoGenesisParameters bfGenesis = , _genesisSecurityParam } = bfGenesis -mkEraHistory :: BlockfrostClientT IO EraHistory -mkEraHistory = do +submitTransaction :: MonadIO m => Tx -> BlockfrostClientT m Blockfrost.TxHash +submitTransaction tx = Blockfrost.submitTx $ Blockfrost.CBORString $ fromStrict $ serialiseToCBOR tx + +---------------- +-- Queries -- +---------------- + +queryEraHistory :: BlockfrostClientT IO EraHistory +queryEraHistory = do eras' <- Blockfrost.getNetworkEras - let eras = filter withoutEmptyEra eras' + let eras = filter isEmptyEra eras' let summary = mkEra <$> eras case nonEmptyFromList summary of Nothing -> - liftIO $ throwIO $ BlockfrostError "Failed to create EraHistory." + liftIO $ throwIO $ BlockfrostError FailedEraHistory Just s -> pure $ EraHistory (mkInterpreter $ Summary s) where mkBound Blockfrost.NetworkEraBound{_boundEpoch, _boundSlot, _boundTime} = @@ -351,45 +407,98 @@ mkEraHistory = do , eraEnd = EraEnd $ mkBound _networkEraEnd , eraParams = mkEraParams _networkEraParameters } - withoutEmptyEra + isEmptyEra Blockfrost.NetworkEraSummary { _networkEraStart = Blockfrost.NetworkEraBound{_boundTime = boundStart} , _networkEraEnd = Blockfrost.NetworkEraBound{_boundTime = boundEnd} - } = boundStart == 0 && boundEnd == 0 + , _networkEraParameters + } = boundStart /= 0 && boundEnd /= 0 ----------------- --- Wallet API -- ----------------- +-- | Query the Blockfrost API to get the 'UTxO' for 'TxIn' and convert to cardano 'UTxO'. +queryUTxOByTxIn :: NetworkId -> Text -> BlockfrostClientT IO UTxO +queryUTxOByTxIn networkId txHash = go (300 :: Int) -- TODO: make this configurable + where + go 0 = liftIO $ throwIO $ BlockfrostError $ FailedUTxOForHash txHash + go n = do + res <- Blockfrost.tryError $ Blockfrost.getTxUtxos (Blockfrost.TxHash txHash) + case res of + Left _e -> liftIO (threadDelay 1) >> go (n - 1) + Right Blockfrost.TransactionUtxos{_transactionUtxosInputs, _transactionUtxosOutputs} -> + foldMapM + ( \Blockfrost.UtxoOutput{_utxoOutputOutputIndex, _utxoOutputAddress, _utxoOutputAmount, _utxoOutputDataHash, _utxoOutputInlineDatum, _utxoOutputReferenceScriptHash} -> + let txIn = toCardanoTxIn txHash _utxoOutputOutputIndex + in toCardanoUTxO networkId txIn _utxoOutputAddress _utxoOutputReferenceScriptHash _utxoOutputDataHash _utxoOutputAmount _utxoOutputInlineDatum + ) + _transactionUtxosOutputs + +queryScript :: Text -> BlockfrostClientT IO (Maybe PlutusScript) +queryScript scriptHashTxt = do + Blockfrost.ScriptCBOR{_scriptCborCbor} <- Blockfrost.getScriptCBOR $ Blockfrost.ScriptHash scriptHashTxt + case _scriptCborCbor of + Nothing -> pure Nothing + Just fullScriptCBOR -> + case decodeBase16 fullScriptCBOR :: Either String ByteString of + Left _ -> pure Nothing + Right bytes -> + case deserialiseFromCBOR (proxyToAsType (Proxy @PlutusScript)) bytes of + Left _ -> pure Nothing + Right plutusScript -> pure $ Just plutusScript -- | Query the Blockfrost API for address UTxO and convert to cardano 'UTxO'. -queryUTxO :: SigningKey PaymentKey -> NetworkId -> BlockfrostClientT IO UTxO -queryUTxO sk networkId = do - let address = Blockfrost.Address vkAddress - utxo <- Blockfrost.getAddressUtxos address - let cardanoAddress = mkVkAddress networkId vk - pure $ toCardanoUTxO utxo cardanoAddress - where - vk = getVerificationKey sk - vkAddress = textAddrOf networkId vk +-- NOTE: We accept the address list here to be compatible with cardano-api but in +-- fact this is a single address query always. +queryUTxO :: NetworkId -> [Address ShelleyAddr] -> BlockfrostClientT IO UTxO +queryUTxO networkId addresses = do + let address' = Blockfrost.Address . serialiseAddress $ List.head addresses + utxoWithAddresses <- Blockfrost.getAddressUtxos' address' (Blockfrost.paged 1 1) Blockfrost.desc + + foldMapM + ( \Blockfrost.AddressUtxo + { Blockfrost._addressUtxoAddress + , Blockfrost._addressUtxoTxHash = Blockfrost.TxHash{unTxHash} + , Blockfrost._addressUtxoOutputIndex + , Blockfrost._addressUtxoAmount + , Blockfrost._addressUtxoBlock + , Blockfrost._addressUtxoDataHash + , Blockfrost._addressUtxoInlineDatum + , Blockfrost._addressUtxoReferenceScriptHash + } -> + let txin = toCardanoTxIn unTxHash _addressUtxoOutputIndex + in toCardanoUTxO networkId txin _addressUtxoAddress _addressUtxoReferenceScriptHash _addressUtxoDataHash _addressUtxoAmount _addressUtxoInlineDatum + ) + utxoWithAddresses + +queryUTxOFor :: VerificationKey PaymentKey -> BlockfrostClientT IO UTxO +queryUTxOFor vk = do + Blockfrost.Genesis + { _genesisNetworkMagic = networkMagic + } <- + queryGenesisParameters + let networkId = toCardanoNetworkId networkMagic + case mkVkAddress networkId vk of + ShelleyAddressInEra addr -> + queryUTxO networkId [addr] + ByronAddressInEra{} -> + liftIO $ throwIO $ BlockfrostError ByronAddressNotSupported -- | Query the Blockfrost API for 'Genesis' -queryGenesis :: BlockfrostClientT IO Blockfrost.Genesis -queryGenesis = Blockfrost.getLedgerGenesis +queryGenesisParameters :: BlockfrostClientT IO Blockfrost.Genesis +queryGenesisParameters = Blockfrost.getLedgerGenesis + +querySystemStart :: BlockfrostClientT IO SystemStart +querySystemStart = do + Blockfrost.Genesis{_genesisSystemStart} <- queryGenesisParameters + pure $ SystemStart $ posixSecondsToUTCTime _genesisSystemStart -- | Query the Blockfrost API for 'Genesis' and convert to cardano 'ChainPoint'. -queryTip :: QueryPoint -> BlockfrostClientT IO ChainPoint -queryTip queryPoint = do +queryTip :: BlockfrostClientT IO ChainPoint +queryTip = do Blockfrost.Block { _blockHeight , _blockHash , _blockSlot - } <- case queryPoint of - QueryTip -> Blockfrost.getLatestBlock - QueryAt point -> do - let slot = case point of - ChainPointAtGenesis -> 0 - ChainPoint slotNo _ -> fromIntegral $ unSlotNo slotNo - Blockfrost.getBlock (Left slot) + } <- + Blockfrost.getLatestBlock let slotAndBlockNumber = do blockSlot <- _blockSlot blockNumber <- _blockHeight @@ -404,3 +513,41 @@ queryTip queryPoint = do (SlotNo $ fromIntegral $ Blockfrost.unSlot blockSlot) (fromString $ T.unpack blockHash) (BlockNo $ fromIntegral blockNo) + +queryStakePools :: + BlockfrostClientT IO (Set PoolId) +queryStakePools = do + stakePools' <- Blockfrost.listPools + pure $ Set.fromList (toCardanoPoolId <$> stakePools') + +awaitTransaction :: Tx -> BlockfrostClientT IO UTxO +awaitTransaction tx = do + Blockfrost.Genesis{_genesisNetworkMagic} <- queryGenesisParameters + let networkId = toCardanoNetworkId _genesisNetworkMagic + let TxId txhash = getTxId $ getTxBody tx + queryUTxOByTxIn networkId (hashToTextAsHex txhash) + +-- | Await for specific UTxO at address - the one that is produced by the given 'TxId'. +awaitUTxO :: + -- | Network id + NetworkId -> + -- | Address we are interested in + [Address ShelleyAddr] -> + -- | Last transaction ID to await + TxId -> + -- | Number of seconds to wait + Int -> + BlockfrostClientT IO UTxO +awaitUTxO networkId addresses txid i = do + go i + where + go 0 = liftIO $ throwIO $ BlockfrostError (TimeoutOnUTxO txid) + go n = do + utxo <- Blockfrost.tryError $ queryUTxO networkId addresses + case utxo of + Left _e -> liftIO (threadDelay 1) >> go (n - 1) + Right utxo' -> + let wantedUTxO = UTxO.fromList $ List.filter (\(TxIn txid' _, _) -> txid' == txid) (UTxO.toList utxo') + in if null wantedUTxO + then liftIO (threadDelay 1) >> go (n - 1) + else pure utxo' diff --git a/hydra-node/src/Hydra/Chain/Blockfrost/TimeHandle.hs b/hydra-node/src/Hydra/Chain/Blockfrost/TimeHandle.hs deleted file mode 100644 index c132ced11ca..00000000000 --- a/hydra-node/src/Hydra/Chain/Blockfrost/TimeHandle.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | Module to deal with time in Blockfrost cardano chain layer. Defines the --- means to 'queryTimeHandle'. -module Hydra.Chain.Blockfrost.TimeHandle where - -import Hydra.Prelude - -import Blockfrost.Client qualified as Blockfrost -import Cardano.Slotting.Slot (SlotNo (SlotNo)) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Hydra.Cardano.Api ( - SystemStart (..), - ) -import Hydra.Cardano.Api.Prelude (ChainPoint (ChainPoint, ChainPointAtGenesis)) -import Hydra.Chain.Blockfrost.Client (mkEraHistory, queryGenesis, queryTip, runBlockfrostM) -import Hydra.Chain.CardanoClient ( - QueryPoint (QueryTip), - ) -import Hydra.Chain.Direct.TimeHandle (TimeHandle, mkTimeHandle) - --- | Query node for system start and era history before constructing a --- 'TimeHandle' using the slot at the tip of the network. -queryTimeHandle :: Blockfrost.Project -> IO TimeHandle -queryTimeHandle prj = runBlockfrostM prj $ do - tip <- queryTip QueryTip - - Blockfrost.Genesis{_genesisSystemStart} <- queryGenesis - let systemStart = SystemStart $ posixSecondsToUTCTime _genesisSystemStart - eraHistory <- mkEraHistory - currentTipSlot <- - case tip of - ChainPointAtGenesis -> pure $ SlotNo 0 - ChainPoint slotNo _ -> pure slotNo - - pure $ mkTimeHandle currentTipSlot systemStart eraHistory diff --git a/hydra-node/src/Hydra/Chain/Cardano.hs b/hydra-node/src/Hydra/Chain/Cardano.hs new file mode 100644 index 00000000000..124d71b1d60 --- /dev/null +++ b/hydra-node/src/Hydra/Chain/Cardano.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Hydra.Chain.Cardano where + +import Hydra.Prelude + +import Cardano.Ledger.Shelley.API qualified as Ledger +import Cardano.Ledger.Slot (EpochInfo) +import Cardano.Slotting.EpochInfo (hoistEpochInfo) +import Control.Monad.Trans.Except (runExcept) +import Hydra.Cardano.Api ( + EraHistory (EraHistory), + Tx, + toLedgerUTxO, + ) +import Hydra.Chain (ChainComponent, ChainStateHistory) +import Hydra.Chain.Backend (ChainBackend (..)) +import Hydra.Chain.Blockfrost (BlockfrostBackend (..), withBlockfrostChain) +import Hydra.Chain.CardanoClient ( + QueryPoint (..), + ) +import Hydra.Chain.Direct (DirectBackend (..), withDirectChain) +import Hydra.Chain.Direct.Handlers (CardanoChainLog (..)) +import Hydra.Chain.Direct.State ( + ChainContext (..), + ) +import Hydra.Chain.Direct.Wallet ( + TinyWallet (..), + WalletInfoOnChain (..), + newTinyWallet, + ) +import Hydra.Logging (Tracer) +import Hydra.Node.Util (readKeyPair) +import Hydra.Options (CardanoChainConfig (..), ChainBackendOptions (..)) +import Hydra.Tx (Party) +import Ouroboros.Consensus.HardFork.History qualified as Consensus + +withCardanoChain :: + forall a. + Tracer IO CardanoChainLog -> + CardanoChainConfig -> + Party -> + -- | Chain state loaded from persistence. + ChainStateHistory Tx -> + ChainComponent Tx IO a +withCardanoChain tracer cfg party chainStateHistory callback action = + case chainBackendOptions of + Direct directOptions -> do + let directBackend = DirectBackend directOptions + wallet <- mkTinyWallet directBackend tracer cfg + ctx <- loadChainContext directBackend cfg party + withDirectChain directBackend tracer cfg ctx wallet chainStateHistory callback action + Blockfrost blockfrostOptions -> do + let blockfrostBackend = BlockfrostBackend blockfrostOptions + wallet <- mkTinyWallet blockfrostBackend tracer cfg + ctx <- loadChainContext blockfrostBackend cfg party + withBlockfrostChain blockfrostBackend tracer cfg ctx wallet chainStateHistory callback action + where + CardanoChainConfig{chainBackendOptions} = cfg + +-- | Build the 'ChainContext' from a 'ChainConfig' and additional information. +loadChainContext :: + forall backend. + ChainBackend backend => + backend -> + CardanoChainConfig -> + -- | Hydra party of our hydra node. + Party -> + -- | The current running era we can use to query the node + IO ChainContext +loadChainContext backend config party = do + (vk, _) <- readKeyPair cardanoSigningKey + scriptRegistry <- queryScriptRegistry backend hydraScriptsTxId + networkId <- queryNetworkId backend + pure $ + ChainContext + { networkId + , ownVerificationKey = vk + , ownParty = party + , scriptRegistry + } + where + CardanoChainConfig + { hydraScriptsTxId + , cardanoSigningKey + } = config + +mkTinyWallet :: + forall backend. + ChainBackend backend => + backend -> + Tracer IO CardanoChainLog -> + CardanoChainConfig -> + IO (TinyWallet IO) +mkTinyWallet backend tracer config = do + keyPair <- readKeyPair cardanoSigningKey + networkId <- queryNetworkId backend + newTinyWallet (contramap Wallet tracer) networkId keyPair queryWalletInfo queryEpochInfo querySomePParams + where + CardanoChainConfig{cardanoSigningKey} = config + + queryEpochInfo = toEpochInfo <$> queryEraHistory backend QueryTip + + querySomePParams = queryProtocolParameters backend QueryTip + queryWalletInfo queryPoint address = do + point <- case queryPoint of + QueryAt point -> pure point + QueryTip -> queryTip backend + walletUTxO <- Ledger.unUTxO . toLedgerUTxO <$> queryUTxO backend [address] + systemStart <- querySystemStart backend QueryTip + pure $ WalletInfoOnChain{walletUTxO, systemStart, tip = point} + + toEpochInfo :: EraHistory -> EpochInfo (Either Text) + toEpochInfo (EraHistory interpreter) = + hoistEpochInfo (first show . runExcept) $ + Consensus.interpreterToEpochInfo interpreter diff --git a/hydra-node/src/Hydra/Chain/Direct.hs b/hydra-node/src/Hydra/Chain/Direct.hs index b688c7b26dc..22d6b23aeb6 100644 --- a/hydra-node/src/Hydra/Chain/Direct.hs +++ b/hydra-node/src/Hydra/Chain/Direct.hs @@ -9,9 +9,7 @@ module Hydra.Chain.Direct ( import Hydra.Prelude -import Cardano.Ledger.Shelley.API qualified as Ledger -import Cardano.Ledger.Slot (EpochInfo) -import Cardano.Slotting.EpochInfo (hoistEpochInfo) +import Cardano.Api.Consensus (EraMismatch (..)) import Control.Concurrent.Class.MonadSTM ( newEmptyTMVar, newTQueueIO, @@ -21,16 +19,14 @@ import Control.Concurrent.Class.MonadSTM ( writeTQueue, ) import Control.Exception (IOException) -import Control.Monad.Trans.Except (runExcept) import Hydra.Cardano.Api ( AnyCardanoEra (..), BlockInMode (..), CardanoEra (..), - ChainPoint, + ChainPoint (..), ChainTip, ConsensusModeParams (..), EpochSlots (..), - EraHistory (EraHistory), IsShelleyBasedEra (..), LocalChainSyncClient (..), LocalNodeClientProtocols (..), @@ -47,7 +43,6 @@ import Hydra.Cardano.Api ( getBlockTxs, getTxBody, getTxId, - toLedgerUTxO, ) import Hydra.Chain ( ChainComponent, @@ -55,20 +50,11 @@ import Hydra.Chain ( PostTxError (FailedToPostTx, failureReason), currentState, ) -import Hydra.Chain.CardanoClient ( - QueryException (..), - QueryPoint (..), - queryCurrentEraExpr, - queryEraHistory, - queryInShelleyBasedEraExpr, - querySystemStart, - queryTip, - queryUTxO, - runQueryExpr, - ) +import Hydra.Chain.Backend (ChainBackend (..)) +import Hydra.Chain.CardanoClient qualified as CardanoClient import Hydra.Chain.Direct.Handlers ( + CardanoChainLog (..), ChainSyncHandler, - DirectChainLog (..), chainSyncHandler, mkChain, newLocalChainState, @@ -82,16 +68,10 @@ import Hydra.Chain.Direct.State ( import Hydra.Chain.Direct.TimeHandle (queryTimeHandle) import Hydra.Chain.Direct.Wallet ( TinyWallet (..), - WalletInfoOnChain (..), - newTinyWallet, ) -import Hydra.Chain.ScriptRegistry (queryScriptRegistry) +import Hydra.Chain.ScriptRegistry qualified as ScriptRegistry import Hydra.Logging (Tracer, traceWith) -import Hydra.Node.Util (readKeyPair) -import Hydra.Options (DirectChainConfig (..)) -import Hydra.Tx (Party) -import Ouroboros.Consensus.Cardano.Block (EraMismatch (..)) -import Ouroboros.Consensus.HardFork.History qualified as Consensus +import Hydra.Options (CardanoChainConfig (..), DirectOptions (..)) import Ouroboros.Network.Magic (NetworkMagic (..)) import Ouroboros.Network.Protocol.ChainSync.Client ( ChainSyncClient (..), @@ -106,82 +86,67 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Client ( ) import Text.Printf (printf) --- | Build the 'ChainContext' from a 'ChainConfig' and additional information. -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 - scriptRegistry <- queryScriptRegistry networkId nodeSocket hydraScriptsTxId - pure $ - ChainContext - { networkId - , ownVerificationKey = vk - , ownParty = party - , scriptRegistry - } - where - DirectChainConfig - { networkId - , nodeSocket - , hydraScriptsTxId - , cardanoSigningKey - } = config - -mkTinyWallet :: - Tracer IO DirectChainLog -> - DirectChainConfig -> - IO (TinyWallet IO) -mkTinyWallet tracer config = do - keyPair <- readKeyPair cardanoSigningKey - newTinyWallet (contramap Wallet tracer) networkId keyPair queryWalletInfo queryEpochInfo querySomePParams - where - DirectChainConfig{networkId, nodeSocket, cardanoSigningKey} = config +newtype DirectBackend = DirectBackend {options :: DirectOptions} + +instance ChainBackend DirectBackend where + queryGenesisParameters (DirectBackend DirectOptions{networkId, nodeSocket}) = + liftIO $ CardanoClient.queryGenesisParameters networkId nodeSocket CardanoClient.QueryTip + + queryScriptRegistry (DirectBackend DirectOptions{networkId, nodeSocket}) = + ScriptRegistry.queryScriptRegistry networkId nodeSocket + + queryNetworkId (DirectBackend DirectOptions{networkId}) = pure networkId - queryEpochInfo = toEpochInfo <$> queryEraHistory networkId nodeSocket QueryTip + queryTip (DirectBackend DirectOptions{networkId, nodeSocket}) = + liftIO $ CardanoClient.queryTip networkId nodeSocket - querySomePParams = - runQueryExpr networkId nodeSocket QueryTip $ do - AnyCardanoEra era <- queryCurrentEraExpr + queryUTxO (DirectBackend DirectOptions{networkId, nodeSocket}) addresses = + liftIO $ CardanoClient.queryUTxO networkId nodeSocket CardanoClient.QueryTip addresses + + queryEraHistory (DirectBackend DirectOptions{networkId, nodeSocket}) queryPoint = + liftIO $ CardanoClient.queryEraHistory networkId nodeSocket queryPoint + + querySystemStart (DirectBackend DirectOptions{networkId, nodeSocket}) queryPoint = + liftIO $ CardanoClient.querySystemStart networkId nodeSocket queryPoint + + queryProtocolParameters (DirectBackend DirectOptions{networkId, nodeSocket}) queryPoint = + liftIO $ CardanoClient.runQueryExpr networkId nodeSocket queryPoint $ do + AnyCardanoEra era <- CardanoClient.queryCurrentEraExpr case era of - ConwayEra{} -> queryInShelleyBasedEraExpr shelleyBasedEra QueryProtocolParameters - _ -> liftIO . throwIO $ QueryEraMismatchException EraMismatch{ledgerEraName = show era, otherEraName = "Conway"} - - queryWalletInfo queryPoint address = do - point <- case queryPoint of - QueryAt point -> pure point - QueryTip -> queryTip networkId nodeSocket - walletUTxO <- Ledger.unUTxO . toLedgerUTxO <$> queryUTxO networkId nodeSocket QueryTip [address] - systemStart <- querySystemStart networkId nodeSocket QueryTip - pure $ WalletInfoOnChain{walletUTxO, systemStart, tip = point} - - toEpochInfo :: EraHistory -> EpochInfo (Either Text) - toEpochInfo (EraHistory interpreter) = - hoistEpochInfo (first show . runExcept) $ - Consensus.interpreterToEpochInfo interpreter + ConwayEra{} -> CardanoClient.queryInShelleyBasedEraExpr shelleyBasedEra QueryProtocolParameters + _ -> liftIO . throwIO $ CardanoClient.QueryEraMismatchException EraMismatch{ledgerEraName = show era, otherEraName = "Conway"} + queryStakePools (DirectBackend DirectOptions{networkId, nodeSocket}) queryPoint = + liftIO $ CardanoClient.queryStakePools networkId nodeSocket queryPoint + + queryUTxOFor (DirectBackend DirectOptions{networkId, nodeSocket}) queryPoint vk = + liftIO $ CardanoClient.queryUTxOFor networkId nodeSocket queryPoint vk + + submitTransaction (DirectBackend DirectOptions{networkId, nodeSocket}) tx = + liftIO $ CardanoClient.submitTransaction networkId nodeSocket tx + + awaitTransaction (DirectBackend DirectOptions{networkId, nodeSocket}) tx = + liftIO $ CardanoClient.awaitTransaction networkId nodeSocket tx withDirectChain :: - Tracer IO DirectChainLog -> - DirectChainConfig -> + DirectBackend -> + Tracer IO CardanoChainLog -> + CardanoChainConfig -> ChainContext -> TinyWallet IO -> -- | Chain state loaded from persistence. ChainStateHistory Tx -> ChainComponent Tx IO a -withDirectChain tracer config ctx wallet chainStateHistory callback action = do +withDirectChain backend tracer config ctx wallet chainStateHistory callback action = do -- Last known point on chain as loaded from persistence. let persistedPoint = recordedAt (currentState chainStateHistory) queue <- newTQueueIO -- Select a chain point from which to start synchronizing - chainPoint <- maybe (queryTip networkId nodeSocket) pure $ do + chainPoint <- maybe (queryTip backend) pure $ do (max <$> startChainFrom <*> persistedPoint) <|> persistedPoint <|> startChainFrom - let getTimeHandle = queryTimeHandle networkId nodeSocket + let getTimeHandle = queryTimeHandle backend localChainState <- newLocalChainState chainStateHistory let chainHandle = mkChain @@ -197,7 +162,7 @@ withDirectChain tracer config ctx wallet chainStateHistory callback action = do race ( handle onIOException $ connectToLocalNode - connectInfo + (connectInfo networkId nodeSocket) (clientProtocols chainPoint queue handler) ) (action chainHandle) @@ -205,16 +170,17 @@ withDirectChain tracer config ctx wallet chainStateHistory callback action = do Left () -> error "'connectTo' cannot terminate but did?" Right a -> pure a where - DirectChainConfig{networkId, nodeSocket, startChainFrom} = config + DirectBackend{options = DirectOptions{networkId, nodeSocket}} = backend + CardanoChainConfig{startChainFrom} = config - connectInfo = + connectInfo networkId' nodeSocket' = LocalNodeConnectInfo { -- REVIEW: This was 432000 before, but all usages in the -- cardano-node repository are using this value. This is only -- relevant for the Byron era. localConsensusModeParams = CardanoModeParams (EpochSlots 21600) - , localNodeNetworkId = networkId - , localNodeSocketPath = nodeSocket + , localNodeNetworkId = networkId' + , localNodeSocketPath = nodeSocket' } clientProtocols point queue handler = @@ -236,20 +202,20 @@ withDirectChain tracer config ctx wallet chainStateHistory callback action = do onIOException :: IOException -> IO () onIOException ioException = throwIO $ - ConnectException + DirectConnectException { ioException , nodeSocket , networkId } -data ConnectException = ConnectException +data DirectConnectException = DirectConnectException { ioException :: IOException , nodeSocket :: SocketPath , networkId :: NetworkId } deriving stock (Show) -instance Exception ConnectException +instance Exception DirectConnectException -- | Thrown when the user-provided custom point of intersection is unknown to -- the local node. This may happen if users shut down their node quickly after @@ -344,7 +310,7 @@ chainSyncClient handler wallet startingPoint = txSubmissionClient :: forall m. (MonadSTM m, MonadDelay m) => - Tracer m DirectChainLog -> + Tracer m CardanoChainLog -> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx))) -> LocalTxSubmissionClient TxInMode TxValidationErrorInCardanoMode m () txSubmissionClient tracer queue = diff --git a/hydra-node/src/Hydra/Chain/Direct/Handlers.hs b/hydra-node/src/Hydra/Chain/Direct/Handlers.hs index f1e40df3c7c..6bc12d2c291 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Handlers.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Handlers.hs @@ -148,7 +148,7 @@ type GetTimeHandle m = m TimeHandle -- for simulations and testing. mkChain :: (MonadSTM m, MonadThrow (STM m)) => - Tracer m DirectChainLog -> + Tracer m CardanoChainLog -> -- | Means to acquire a new 'TimeHandle'. GetTimeHandle m -> TinyWallet m -> @@ -254,7 +254,7 @@ chainSyncHandler :: forall m. (MonadSTM m, MonadThrow m) => -- | Tracer for logging - Tracer m DirectChainLog -> + Tracer m CardanoChainLog -> ChainCallback Tx m -> -- | Means to acquire a new 'TimeHandle'. GetTimeHandle m -> @@ -452,7 +452,7 @@ maxGraceTime = 200 -- Tracing -- -data DirectChainLog +data CardanoChainLog = ToPost {toPost :: PostChainTx Tx} | PostingTx {txId :: TxId} | PostedTx {txId :: TxId} diff --git a/hydra-node/src/Hydra/Chain/Direct/TimeHandle.hs b/hydra-node/src/Hydra/Chain/Direct/TimeHandle.hs index d382c623ede..ff3bb615d1b 100644 --- a/hydra-node/src/Hydra/Chain/Direct/TimeHandle.hs +++ b/hydra-node/src/Hydra/Chain/Direct/TimeHandle.hs @@ -9,18 +9,10 @@ import Cardano.Slotting.Slot (SlotNo (SlotNo)) import Cardano.Slotting.Time (SystemStart (SystemStart), fromRelativeTime, toRelativeTime) import Data.Time (secondsToNominalDiffTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Hydra.Cardano.Api ( - EraHistory (EraHistory), - NetworkId, - SocketPath, - ) +import Hydra.Cardano.Api (EraHistory (EraHistory)) import Hydra.Cardano.Api.Prelude (ChainPoint (ChainPoint, ChainPointAtGenesis)) -import Hydra.Chain.CardanoClient ( - QueryPoint (QueryTip), - queryEraHistory, - querySystemStart, - queryTip, - ) +import Hydra.Chain.Backend (ChainBackend (..)) +import Hydra.Chain.CardanoClient (QueryPoint (QueryTip)) import Hydra.Ledger.Cardano.Evaluate (eraHistoryWithHorizonAt) import Hydra.Tx.Close (PointInTime) import Ouroboros.Consensus.HardFork.History.Qry (interpretQuery, slotToWallclock, wallclockToSlot) @@ -101,13 +93,13 @@ mkTimeHandle currentSlotNo systemStart eraHistory = do (EraHistory interpreter) = eraHistory --- | Query node for system start and era history before constructing a +-- | Query the chain for system start and era history before constructing a -- 'TimeHandle' using the slot at the tip of the network. -queryTimeHandle :: NetworkId -> SocketPath -> IO TimeHandle -queryTimeHandle networkId socketPath = do - tip <- queryTip networkId socketPath - systemStart <- querySystemStart networkId socketPath QueryTip - eraHistory <- queryEraHistory networkId socketPath QueryTip +queryTimeHandle :: ChainBackend backend => backend -> IO TimeHandle +queryTimeHandle backend = do + tip <- queryTip backend + systemStart <- querySystemStart backend QueryTip + eraHistory <- queryEraHistory backend QueryTip currentTipSlot <- case tip of ChainPointAtGenesis -> pure $ SlotNo 0 diff --git a/hydra-node/src/Hydra/Chain/ScriptRegistry.hs b/hydra-node/src/Hydra/Chain/ScriptRegistry.hs index c6987904ed4..2e6df2d33d0 100644 --- a/hydra-node/src/Hydra/Chain/ScriptRegistry.hs +++ b/hydra-node/src/Hydra/Chain/ScriptRegistry.hs @@ -36,17 +36,11 @@ import Hydra.Cardano.Api ( pattern TxOutDatumNone, ) import Hydra.Cardano.Api.Tx (signTx) +import Hydra.Chain.Backend (ChainBackend (..)) import Hydra.Chain.CardanoClient ( QueryPoint (..), - awaitTransaction, buildTransactionWithPParams', - queryEraHistory, - queryProtocolParameters, - queryStakePools, - querySystemStart, queryUTxOByTxIn, - queryUTxOFor, - submitTransaction, ) import Hydra.Contract.Head qualified as Head import Hydra.Plutus (commitValidatorScript, initialValidatorScript) @@ -78,23 +72,22 @@ queryScriptRegistry networkId socketPath txIds = do candidates = map (\txid -> TxIn txid (TxIx 0)) txIds publishHydraScripts :: - -- | Expected network discriminant. - NetworkId -> - -- | Path to the cardano-node's domain socket - SocketPath -> + ChainBackend backend => + backend -> -- | Keys assumed to hold funds to pay for the publishing transaction. SigningKey PaymentKey -> IO [TxId] -publishHydraScripts networkId socketPath sk = do - pparams <- queryProtocolParameters networkId socketPath QueryTip - systemStart <- querySystemStart networkId socketPath QueryTip - eraHistory <- queryEraHistory networkId socketPath QueryTip - stakePools <- queryStakePools networkId socketPath QueryTip - utxo <- queryUTxOFor networkId socketPath QueryTip vk +publishHydraScripts backend sk = do + networkId <- queryNetworkId backend + pparams <- queryProtocolParameters backend QueryTip + systemStart <- querySystemStart backend QueryTip + eraHistory <- queryEraHistory backend QueryTip + stakePools <- queryStakePools backend QueryTip + utxo <- queryUTxOFor backend QueryTip vk txs <- buildScriptPublishingTxs pparams systemStart networkId eraHistory stakePools utxo sk forM txs $ \tx -> do - submitTransaction networkId socketPath tx - void $ awaitTransaction networkId socketPath tx + submitTransaction backend tx + void $ awaitTransaction backend tx pure $ txId tx where vk = getVerificationKey sk diff --git a/hydra-node/src/Hydra/Logging/Messages.hs b/hydra-node/src/Hydra/Logging/Messages.hs index 495b14dffc8..e0d74ee8b63 100644 --- a/hydra-node/src/Hydra/Logging/Messages.hs +++ b/hydra-node/src/Hydra/Logging/Messages.hs @@ -11,13 +11,13 @@ module Hydra.Logging.Messages where import Hydra.Prelude import Hydra.API.APIServerLog (APIServerLog) -import Hydra.Chain.Direct.Handlers (DirectChainLog) +import Hydra.Chain.Direct.Handlers (CardanoChainLog) import Hydra.Node (HydraNodeLog) import Hydra.Node.Network (NetworkLog) import Hydra.Options (RunOptions) data HydraLog tx - = DirectChain {directChain :: DirectChainLog} + = DirectChain {directChain :: CardanoChainLog} | APIServer {api :: APIServerLog} | Network {network :: NetworkLog} | Node {node :: HydraNodeLog tx} diff --git a/hydra-node/src/Hydra/Node.hs b/hydra-node/src/Hydra/Node.hs index 0681abda330..1aa7189baa3 100644 --- a/hydra-node/src/Hydra/Node.hs +++ b/hydra-node/src/Hydra/Node.hs @@ -21,7 +21,9 @@ import Control.Concurrent.Class.MonadSTM ( import Control.Monad.Trans.Writer (execWriter, tell) import Hydra.API.ClientInput (ClientInput) import Hydra.API.Server (Server, sendMessage) -import Hydra.Cardano.Api (getVerificationKey) +import Hydra.Cardano.Api ( + getVerificationKey, + ) import Hydra.Chain ( Chain (..), ChainEvent (..), @@ -54,7 +56,7 @@ import Hydra.Node.Environment (Environment (..)) import Hydra.Node.InputQueue (InputQueue (..), Queued (..), createInputQueue) import Hydra.Node.ParameterMismatch (ParamMismatch (..), ParameterMismatch (..)) import Hydra.Node.Util (readFileTextEnvelopeThrow) -import Hydra.Options (ChainConfig (..), DirectChainConfig (..), RunOptions (..), defaultContestationPeriod, defaultDepositPeriod) +import Hydra.Options (CardanoChainConfig (..), ChainConfig (..), RunOptions (..), defaultContestationPeriod, defaultDepositPeriod) import Hydra.Tx (HasParty (..), HeadParameters (..), Party (..), deriveParty) import Hydra.Tx.Utils (verificationKeyToOnChainId) @@ -81,8 +83,8 @@ initEnvironment options = do getParticipants = case chainConfig of Offline{} -> pure [] - Direct - DirectChainConfig + Cardano + CardanoChainConfig { cardanoVerificationKeys , cardanoSigningKey } -> do @@ -92,11 +94,10 @@ initEnvironment options = do contestationPeriod = case chainConfig of Offline{} -> defaultContestationPeriod - Direct DirectChainConfig{contestationPeriod = cp} -> cp - + Cardano CardanoChainConfig{contestationPeriod = cp} -> cp depositPeriod = case chainConfig of Offline{} -> defaultDepositPeriod - Direct DirectChainConfig{depositPeriod = dp} -> dp + Cardano CardanoChainConfig{depositPeriod = dp} -> dp loadParty p = Party <$> readFileTextEnvelopeThrow p diff --git a/hydra-node/src/Hydra/Node/Run.hs b/hydra-node/src/Hydra/Node/Run.hs index 5499f4ca8bd..de208ba2161 100644 --- a/hydra-node/src/Hydra/Node/Run.hs +++ b/hydra-node/src/Hydra/Node/Run.hs @@ -16,8 +16,10 @@ import Hydra.Cardano.Api ( toShelleyNetwork, ) import Hydra.Chain (maximumNumberOfParties) -import Hydra.Chain.CardanoClient (QueryPoint (..), queryGenesisParameters) -import Hydra.Chain.Direct (loadChainContext, mkTinyWallet, withDirectChain) +import Hydra.Chain.Backend (ChainBackend (queryGenesisParameters)) +import Hydra.Chain.Blockfrost (BlockfrostBackend (..)) +import Hydra.Chain.Cardano (withCardanoChain) +import Hydra.Chain.Direct (DirectBackend (..)) import Hydra.Chain.Direct.State (initialChainState) import Hydra.Chain.Offline (loadGenesisFile, withOfflineChain) import Hydra.Events.FileBased (eventPairFromPersistenceIncremental) @@ -39,8 +41,9 @@ import Hydra.Node ( import Hydra.Node.Environment (Environment (..)) import Hydra.Node.Network (NetworkConfiguration (..), withNetwork) import Hydra.Options ( + CardanoChainConfig (..), + ChainBackendOptions (..), ChainConfig (..), - DirectChainConfig (..), InvalidOptions (..), LedgerConfig (..), OfflineChainConfig (..), @@ -122,12 +125,8 @@ run opts = do in action (cardanoLedger globals ledgerEnv) prepareChainComponent tracer Environment{party, otherParties} = \case - Offline cfg -> - pure $ withOfflineChain cfg party otherParties - Direct cfg -> do - ctx <- loadChainContext cfg party - wallet <- mkTinyWallet (contramap DirectChain tracer) cfg - pure $ withDirectChain (contramap DirectChain tracer) cfg ctx wallet + Offline cfg -> pure $ withOfflineChain cfg party otherParties + Cardano cfg -> pure $ withCardanoChain (contramap DirectChain tracer) cfg party RunOptions { verbosity @@ -151,8 +150,10 @@ getGlobalsForChain = \case Offline OfflineChainConfig{ledgerGenesisFile} -> loadGenesisFile ledgerGenesisFile >>= newGlobals - Direct DirectChainConfig{networkId, nodeSocket} -> - queryGenesisParameters networkId nodeSocket QueryTip + Cardano CardanoChainConfig{chainBackendOptions} -> + case chainBackendOptions of + Direct directOptions -> queryGenesisParameters (DirectBackend directOptions) + Blockfrost blockfrostOptions -> queryGenesisParameters (BlockfrostBackend blockfrostOptions) >>= newGlobals data GlobalsTranslationException = GlobalsTranslationException diff --git a/hydra-node/src/Hydra/Options.hs b/hydra-node/src/Hydra/Options.hs index 6886e2a398f..1d5f3f5f40a 100644 --- a/hydra-node/src/Hydra/Options.hs +++ b/hydra-node/src/Hydra/Options.hs @@ -134,39 +134,51 @@ commandParser = ) data PublishOptions = PublishOptions - { chainBackend :: ChainBackend + { chainBackendOptions :: ChainBackendOptions , publishSigningKey :: FilePath } - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) -- | Default options as they should also be provided by 'runOptionsParser'. defaultPublishOptions :: PublishOptions defaultPublishOptions = PublishOptions - { chainBackend = defaultDirectBackend + { chainBackendOptions = Direct defaultDirectOptions , publishSigningKey = "cardano.sk" } -defaultDirectBackend :: ChainBackend -defaultDirectBackend = - DirectBackend - { publishNetworkId = Testnet (NetworkMagic 42) - , publishNodeSocket = "node.socket" +defaultDirectOptions :: DirectOptions +defaultDirectOptions = + DirectOptions + { networkId = Testnet (NetworkMagic 42) + , nodeSocket = "node.socket" } -data ChainBackend - = DirectBackend - { publishNetworkId :: NetworkId - , publishNodeSocket :: SocketPath - } - | BlockfrostBackend - { projectPath :: FilePath - } - deriving stock (Show, Eq) +data ChainBackendOptions + = Direct DirectOptions + | Blockfrost BlockfrostOptions + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, FromJSON) + +data DirectOptions = DirectOptions + { networkId :: NetworkId + -- ^ Network identifer to which we expect to connect. + , nodeSocket :: SocketPath + -- ^ Path to a domain socket used to connect to the server. + } + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, FromJSON) + +newtype BlockfrostOptions = BlockfrostOptions + { projectPath :: FilePath + -- ^ Path to the blockfrost project file + } + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, FromJSON) publishOptionsParser :: Parser PublishOptions publishOptionsParser = - PublishOptions <$> chainBackendParser <*> cardanoSigningKeyFileParser + PublishOptions <$> chainBackendOptionsParser <*> cardanoSigningKeyFileParser data RunOptions = RunOptions { verbosity :: Verbosity @@ -251,7 +263,7 @@ defaultRunOptions = , hydraSigningKey = "hydra.sk" , hydraVerificationKeys = [] , persistenceDir = "./" - , chainConfig = Direct defaultDirectChainConfig + , chainConfig = Cardano defaultCardanoChainConfig , ledgerConfig = defaultLedgerConfig , whichEtcd = EmbeddedEtcd } @@ -290,20 +302,22 @@ whichEtcdParser = chainConfigParser :: Parser ChainConfig chainConfigParser = - Direct <$> directChainConfigParser + Cardano <$> cardanoChainConfigParser <|> Offline <$> offlineChainConfigParser -chainBackendParser :: Parser ChainBackend -chainBackendParser = directBackendParser <|> blockfrostBackendParser +chainBackendOptionsParser :: Parser ChainBackendOptions +chainBackendOptionsParser = directOptionsParser <|> blockfrostOptionsParser where - directBackendParser = - DirectBackend - <$> networkIdParser - <*> nodeSocketParser + directOptionsParser = + fmap Direct $ + DirectOptions + <$> networkIdParser + <*> nodeSocketParser - blockfrostBackendParser = - BlockfrostBackend - <$> blockfrostProjectPathParser + blockfrostOptionsParser = + fmap Blockfrost $ + BlockfrostOptions + <$> blockfrostProjectPathParser newtype GenerateKeyPair = GenerateKeyPair { outputFile :: FilePath @@ -355,20 +369,20 @@ cardanoLedgerProtocolParametersParser = data ChainConfig = Offline OfflineChainConfig - | Direct DirectChainConfig + | Cardano CardanoChainConfig deriving stock (Eq, Show, Generic) instance ToJSON ChainConfig where toJSON = \case Offline cfg -> toJSON cfg & atKey "tag" ?~ String "OfflineChainConfig" - Direct cfg -> toJSON cfg & atKey "tag" ?~ String "DirectChainConfig" + Cardano cfg -> toJSON cfg & atKey "tag" ?~ String "CardanoChainConfig" instance FromJSON ChainConfig where parseJSON = withObject "ChainConfig" $ \o -> o .: "tag" >>= \case "OfflineChainConfig" -> Offline <$> parseJSON (Object o) - "DirectChainConfig" -> Direct <$> parseJSON (Object o) + "CardanoChainConfig" -> Cardano <$> parseJSON (Object o) tag -> fail $ "unexpected tag " <> tag data OfflineChainConfig = OfflineChainConfig @@ -382,12 +396,8 @@ data OfflineChainConfig = OfflineChainConfig deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON) -data DirectChainConfig = DirectChainConfig - { networkId :: NetworkId - -- ^ Network identifer to which we expect to connect. - , nodeSocket :: SocketPath - -- ^ Path to a domain socket used to connect to the server. - , hydraScriptsTxId :: [TxId] +data CardanoChainConfig = CardanoChainConfig + { hydraScriptsTxId :: [TxId] -- ^ Identifier of transaction holding the hydra scripts to use. , cardanoSigningKey :: FilePath -- ^ Path to the cardano signing key of the internal wallet. @@ -397,21 +407,21 @@ data DirectChainConfig = DirectChainConfig -- ^ Point at which to start following the chain. , contestationPeriod :: ContestationPeriod , depositPeriod :: DepositPeriod + , chainBackendOptions :: ChainBackendOptions } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON) -defaultDirectChainConfig :: DirectChainConfig -defaultDirectChainConfig = - DirectChainConfig - { networkId = Testnet (NetworkMagic 42) - , nodeSocket = "node.socket" - , hydraScriptsTxId = [] +defaultCardanoChainConfig :: CardanoChainConfig +defaultCardanoChainConfig = + CardanoChainConfig + { hydraScriptsTxId = [] , cardanoSigningKey = "cardano.sk" , cardanoVerificationKeys = [] , startChainFrom = Nothing , contestationPeriod = defaultContestationPeriod , depositPeriod = defaultDepositPeriod + , chainBackendOptions = Direct defaultDirectOptions } data BlockfrostChainConfig = BlockfrostChainConfig @@ -419,35 +429,39 @@ data BlockfrostChainConfig = BlockfrostChainConfig -- ^ Path to the blockfrost project file , cardanoSigningKey :: FilePath -- ^ Path to the cardano signing key of the internal wallet. + , hydraScriptsTxId :: [TxId] + -- ^ Identifier of transaction holding the hydra scripts to use. } deriving stock (Eq, Show, Generic) instance Arbitrary ChainConfig where arbitrary = oneof - [ Direct <$> genDirectChainConfig + [ Cardano <$> genCardanoChainConfig , Offline <$> genOfflineChainConfig ] where - genDirectChainConfig = do - networkId <- Testnet . NetworkMagic <$> arbitrary - nodeSocket <- File <$> genFilePath "socket" - hydraScriptsTxId <- arbitrary + genCardanoChainConfig = do + hydraScriptsTxId <- reasonablySized arbitrary cardanoSigningKey <- genFilePath "sk" cardanoVerificationKeys <- reasonablySized (listOf (genFilePath "vk")) startChainFrom <- oneof [pure Nothing, Just <$> genChainPoint] contestationPeriod <- arbitrary depositPeriod <- arbitrary + chainBackendOptions <- + oneof + [ pure $ Direct defaultDirectOptions + , pure $ Blockfrost BlockfrostOptions{projectPath = "blockfrost-project.txt"} + ] pure - DirectChainConfig - { networkId - , nodeSocket - , hydraScriptsTxId + CardanoChainConfig + { hydraScriptsTxId , cardanoSigningKey , cardanoVerificationKeys , startChainFrom , contestationPeriod , depositPeriod + , chainBackendOptions } genOfflineChainConfig = do @@ -499,17 +513,16 @@ ledgerGenesisFileParser = <> help "Offline mode: File containing shelley genesis parameters for the simulated L1 chain in offline mode." ) -directChainConfigParser :: Parser DirectChainConfig -directChainConfigParser = - DirectChainConfig - <$> networkIdParser - <*> nodeSocketParser - <*> (hydraScriptsTxIdsParser <|> many hydraScriptsTxIdParser) +cardanoChainConfigParser :: Parser CardanoChainConfig +cardanoChainConfigParser = + CardanoChainConfig + <$> (hydraScriptsTxIdsParser <|> many hydraScriptsTxIdParser) <*> cardanoSigningKeyFileParser <*> many cardanoVerificationKeyFileParser <*> optional startChainFromParser <*> contestationPeriodParser <*> depositPeriodParser + <*> chainBackendOptionsParser blockfrostProjectPathParser :: Parser FilePath blockfrostProjectPathParser = @@ -554,7 +567,7 @@ nodeSocketParser = strOption ( long "node-socket" <> metavar "FILE" - <> value defaultDirectChainConfig.nodeSocket + <> value defaultDirectOptions.nodeSocket <> showDefault <> help "Filepath to local unix domain socket used to communicate with \ @@ -567,7 +580,7 @@ cardanoSigningKeyFileParser = ( long "cardano-signing-key" <> metavar "FILE" <> showDefault - <> value defaultDirectChainConfig.cardanoSigningKey + <> value defaultCardanoChainConfig.cardanoSigningKey <> help "Cardano signing key of our hydra-node. This will be used to authorize \ \Hydra protocol transactions for heads the node takes part in and any \ @@ -879,7 +892,7 @@ validateRunOptions :: RunOptions -> Either InvalidOptions () validateRunOptions RunOptions{hydraVerificationKeys, chainConfig} = case chainConfig of Offline{} -> Right () - Direct DirectChainConfig{cardanoVerificationKeys} + Cardano CardanoChainConfig{cardanoVerificationKeys} | max (length hydraVerificationKeys) (length cardanoVerificationKeys) + 1 > maximumNumberOfParties -> Left MaximumNumberOfPartiesExceeded | length cardanoVerificationKeys /= length hydraVerificationKeys -> @@ -969,19 +982,23 @@ toArgs <> case ledgerGenesisFile of Just fp -> ["--ledger-genesis", fp] Nothing -> [] - Direct - DirectChainConfig - { networkId - , nodeSocket - , hydraScriptsTxId + Cardano + CardanoChainConfig + { hydraScriptsTxId , cardanoSigningKey , cardanoVerificationKeys , startChainFrom , contestationPeriod , depositPeriod + , chainBackendOptions } -> - toArgNetworkId networkId - <> toArgNodeSocket nodeSocket + ( case chainBackendOptions of + Blockfrost BlockfrostOptions{projectPath} -> + ["--blockfrost", projectPath] + Direct DirectOptions{networkId, nodeSocket} -> + toArgNetworkId networkId + <> toArgNodeSocket nodeSocket + ) <> ["--hydra-scripts-tx-id", intercalate "," $ toString . serialiseToRawBytesHexText <$> hydraScriptsTxId] <> ["--cardano-signing-key", cardanoSigningKey] <> ["--contestation-period", show contestationPeriod] diff --git a/hydra-node/test/Hydra/Model/MockChain.hs b/hydra-node/test/Hydra/Model/MockChain.hs index 7ff4f4d7d96..9d8632c5b02 100644 --- a/hydra-node/test/Hydra/Model/MockChain.hs +++ b/hydra-node/test/Hydra/Model/MockChain.hs @@ -43,8 +43,8 @@ import Hydra.Chain ( ) import Hydra.Chain.ChainState (ChainSlot (..)) import Hydra.Chain.Direct.Handlers ( + CardanoChainLog, ChainSyncHandler (..), - DirectChainLog, LocalChainState, SubmitTx, chainSyncHandler, @@ -100,7 +100,7 @@ mockChainAndNetwork :: , MonadFork m , MonadDelay m ) => - Tracer m DirectChainLog -> + Tracer m CardanoChainLog -> [(SigningKey HydraKey, CardanoSigningKey)] -> UTxO -> m (SimulatedChainNetwork Tx m) @@ -373,7 +373,7 @@ data MockHydraNode m = MockHydraNode createMockChain :: (MonadTimer m, MonadThrow (STM m)) => - Tracer m DirectChainLog -> + Tracer m CardanoChainLog -> ChainContext -> SubmitTx m -> m TimeHandle -> diff --git a/hydra-node/test/Hydra/Node/RunSpec.hs b/hydra-node/test/Hydra/Node/RunSpec.hs index 4116af31ba6..861c65ed10e 100644 --- a/hydra-node/test/Hydra/Node/RunSpec.hs +++ b/hydra-node/test/Hydra/Node/RunSpec.hs @@ -5,10 +5,10 @@ import Test.Hydra.Prelude import Hydra.Node.Run (ConfigurationException, run) import Hydra.Options ( + CardanoChainConfig (..), ChainConfig (..), - DirectChainConfig (..), RunOptions (..), - defaultDirectChainConfig, + defaultCardanoChainConfig, defaultRunOptions, genFilePath, ) @@ -21,7 +21,7 @@ spec = hydraVerificationKeys <- generate $ replicateM 2 (genFilePath "vk") run defaultRunOptions - { chainConfig = Direct defaultDirectChainConfig{cardanoVerificationKeys = cardanoKeys} + { chainConfig = Cardano defaultCardanoChainConfig{cardanoVerificationKeys = cardanoKeys} , hydraVerificationKeys } `shouldThrow` aConfigurationException diff --git a/hydra-node/test/Hydra/OptionsSpec.hs b/hydra-node/test/Hydra/OptionsSpec.hs index bc88d4c6aa2..f9b7592c78f 100644 --- a/hydra-node/test/Hydra/OptionsSpec.hs +++ b/hydra-node/test/Hydra/OptionsSpec.hs @@ -1,22 +1,28 @@ +{-# LANGUAGE OverloadedLabels #-} + module Hydra.OptionsSpec where import Hydra.Prelude import Test.Hydra.Prelude +import Control.Lens ((.~)) +import Data.Generics.Labels () import Hydra.Cardano.Api ( ChainPoint (..), NetworkId (..), + NetworkMagic (..), TxId, serialiseToRawBytesHexText, ) import Hydra.Chain (maximumNumberOfParties) -import Hydra.Chain.Direct (NetworkMagic (..)) import Hydra.Network (Host (Host)) import Hydra.Options ( - ChainBackend (..), + BlockfrostOptions (..), + CardanoChainConfig (..), + ChainBackendOptions (..), ChainConfig (..), Command (..), - DirectChainConfig (..), + DirectOptions (..), GenerateKeyPair (GenerateKeyPair), InvalidOptions (..), LedgerConfig (..), @@ -24,8 +30,8 @@ import Hydra.Options ( ParserResult (..), PublishOptions (..), RunOptions (..), - defaultDirectBackend, - defaultDirectChainConfig, + defaultCardanoChainConfig, + defaultDirectOptions, defaultLedgerConfig, defaultPublishOptions, defaultRunOptions, @@ -50,12 +56,12 @@ spec = parallel $ it ("validateRunOptions: using more than " <> show maximumNumberOfParties <> " parties should error out") $ do let (cardanoKeys, hydraKeys) = genCardanoAndHydraKeys (+ 2) (+ 1) - chainCfg = Direct defaultDirectChainConfig{cardanoVerificationKeys = cardanoKeys} + chainCfg = Cardano defaultCardanoChainConfig{cardanoVerificationKeys = cardanoKeys} validateRunOptions (defaultRunOptions{hydraVerificationKeys = hydraKeys, chainConfig = chainCfg}) `shouldBe` Left MaximumNumberOfPartiesExceeded it "validateRunOptions: loaded cardano keys needs to match with the hydra keys length" $ do let (cardanoKeys, hydraKeys) = genCardanoAndHydraKeys (subtract 2) (subtract 1) - chainCfg = Direct defaultDirectChainConfig{cardanoVerificationKeys = cardanoKeys} + chainCfg = Cardano defaultCardanoChainConfig{cardanoVerificationKeys = cardanoKeys} validateRunOptions (defaultRunOptions{hydraVerificationKeys = hydraKeys, chainConfig = chainCfg}) `shouldBe` Left CardanoAndHydraKeysMissmatch @@ -136,28 +142,43 @@ spec = parallel $ `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig - { networkId = Testnet (NetworkMagic 0) - } + Cardano + ( defaultCardanoChainConfig + & #chainBackendOptions + .~ Direct + DirectOptions + { networkId = Testnet (NetworkMagic 0) + , nodeSocket = nodeSocket defaultDirectOptions + } + ) } ["--testnet-magic", "-1"] -- Word32 overflow expected `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig - { networkId = Testnet (NetworkMagic 4294967295) - } + Cardano + ( defaultCardanoChainConfig + & #chainBackendOptions + .~ Direct + DirectOptions + { networkId = Testnet (NetworkMagic 4294967295) + , nodeSocket = nodeSocket defaultDirectOptions + } + ) } ["--testnet-magic", "123"] `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig - { networkId = Testnet (NetworkMagic 123) - } + Cardano + ( defaultCardanoChainConfig + & #chainBackendOptions + .~ Direct + DirectOptions + { networkId = Testnet (NetworkMagic 123) + , nodeSocket = nodeSocket defaultDirectOptions + } + ) } it "parses --mainnet option" $ do @@ -165,17 +186,22 @@ spec = parallel $ `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig - { networkId = Mainnet - } + Cardano + ( defaultCardanoChainConfig + & #chainBackendOptions + .~ Direct + DirectOptions + { networkId = Mainnet + , nodeSocket = nodeSocket defaultDirectOptions + } + ) } it "parses --contestation-period option as a number of seconds" $ do let defaultWithContestationPeriod contestationPeriod = Run defaultRunOptions - { chainConfig = Direct defaultDirectChainConfig{contestationPeriod} + { chainConfig = Cardano defaultCardanoChainConfig{contestationPeriod} } shouldNotParse ["--contestation-period", "3"] shouldNotParse ["--contestation-period", "abc"] @@ -191,7 +217,7 @@ spec = parallel $ let defaultWithDepositPeriod depositPeriod = Run defaultRunOptions - { chainConfig = Direct defaultDirectChainConfig{depositPeriod} + { chainConfig = Cardano defaultCardanoChainConfig{depositPeriod} } shouldNotParse ["--deposit-period", "abc"] shouldNotParse ["--deposit-period", "s"] @@ -207,10 +233,15 @@ spec = parallel $ `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig - { networkId = Mainnet - } + Cardano + ( defaultCardanoChainConfig + & #chainBackendOptions + .~ Direct + DirectOptions + { networkId = Mainnet + , nodeSocket = nodeSocket defaultDirectOptions + } + ) } it "parses --node-socket as a filepath" $ @@ -218,10 +249,15 @@ spec = parallel $ `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig - { nodeSocket = "foo.sock" - } + Cardano + ( defaultCardanoChainConfig + & #chainBackendOptions + .~ Direct + DirectOptions + { networkId = networkId defaultDirectOptions + , nodeSocket = "foo.sock" + } + ) } it "parses --cardano-signing-key option as a filepath" $ @@ -229,10 +265,8 @@ spec = parallel $ `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig - { cardanoSigningKey = "./alice-cardano.sk" - } + Cardano + (defaultCardanoChainConfig & #cardanoSigningKey .~ "./alice-cardano.sk") } it "parses --cardano-verification-key option as a filepath" $ @@ -240,10 +274,8 @@ spec = parallel $ `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig - { cardanoVerificationKeys = ["./alice-cardano.vk"] - } + Cardano + (defaultCardanoChainConfig & #cardanoVerificationKeys .~ ["./alice-cardano.vk"]) } it "parses --ledger-protocol-parameters-file as a filepath" $ @@ -261,8 +293,8 @@ spec = parallel $ `shouldParse` Run defaultRunOptions { chainConfig = - Direct - defaultDirectChainConfig + Cardano + defaultCardanoChainConfig { startChainFrom = Just $ ChainPoint 1000 $ @@ -274,7 +306,7 @@ spec = parallel $ ["--start-chain-from", "0"] `shouldParse` Run defaultRunOptions - { chainConfig = Direct defaultDirectChainConfig{startChainFrom = Just ChainPointAtGenesis} + { chainConfig = Cardano defaultCardanoChainConfig{startChainFrom = Just ChainPointAtGenesis} } prop "parses --hydra-scripts-tx-id as a tx id" $ \(txIds :: NonEmpty TxId) -> do @@ -282,7 +314,14 @@ spec = parallel $ ["--hydra-scripts-tx-id", lineToParse] `shouldParse` Run defaultRunOptions - { chainConfig = Direct defaultDirectChainConfig{hydraScriptsTxId = toList txIds} + { chainConfig = Cardano defaultCardanoChainConfig{hydraScriptsTxId = toList txIds} + } + + it "parses --blockfrost successfully" $ + ["--blockfrost", "blockfrost-project.txt"] + `shouldParse` Run + defaultRunOptions + { chainConfig = Cardano (defaultCardanoChainConfig & #chainBackendOptions .~ Blockfrost (BlockfrostOptions "blockfrost-project.txt")) } it "switches to offline mode when using --offline-head-seed and --initial-utxo" $ @@ -334,7 +373,15 @@ spec = parallel $ , ["--node-socket", "foo"] , ["--mainnet"] ] - `shouldParse` Publish defaultPublishOptions{chainBackend = defaultDirectBackend{publishNodeSocket = "foo", publishNetworkId = Mainnet}} + `shouldParse` Publish + ( defaultPublishOptions + & #chainBackendOptions + .~ Direct + DirectOptions + { networkId = Mainnet + , nodeSocket = "foo" + } + ) it "parses with some missing option (2)" $ mconcat @@ -342,7 +389,7 @@ spec = parallel $ , ["--testnet-magic", "42"] , ["--cardano-signing-key", "foo"] ] - `shouldParse` Publish defaultPublishOptions{chainBackend = defaultDirectBackend{publishNetworkId = Testnet (NetworkMagic 42)}, publishSigningKey = "foo"} + `shouldParse` Publish defaultPublishOptions{chainBackendOptions = Direct defaultDirectOptions{networkId = Testnet (NetworkMagic 42)}, publishSigningKey = "foo"} it "parses with some missing option (3)" $ mconcat @@ -350,7 +397,7 @@ spec = parallel $ , ["--node-socket", "foo"] , ["--cardano-signing-key", "foo"] ] - `shouldParse` Publish defaultPublishOptions{chainBackend = defaultDirectBackend{publishNodeSocket = "foo"}, publishSigningKey = "foo"} + `shouldParse` Publish defaultPublishOptions{chainBackendOptions = Direct defaultDirectOptions{nodeSocket = "foo"}, publishSigningKey = "foo"} it "should parse using testnet and all options" $ mconcat @@ -361,7 +408,7 @@ spec = parallel $ ] `shouldParse` Publish defaultPublishOptions - { chainBackend = defaultDirectBackend{publishNodeSocket = "foo", publishNetworkId = Testnet (NetworkMagic 42)} + { chainBackendOptions = Direct defaultDirectOptions{nodeSocket = "foo", networkId = Testnet (NetworkMagic 42)} , publishSigningKey = "bar" } @@ -374,7 +421,7 @@ spec = parallel $ ] `shouldParse` Publish defaultPublishOptions - { chainBackend = defaultDirectBackend{publishNodeSocket = "baz", publishNetworkId = Mainnet} + { chainBackendOptions = Direct defaultDirectOptions{nodeSocket = "baz", networkId = Mainnet} , publishSigningKey = "crux" } @@ -385,10 +432,11 @@ spec = parallel $ ] `shouldParse` Publish ( PublishOptions - { chainBackend = - BlockfrostBackend - { projectPath = "baz" - } + { chainBackendOptions = + Blockfrost + BlockfrostOptions + { projectPath = "baz" + } , publishSigningKey = "cardano.sk" } ) diff --git a/hydra-tx/src/Hydra/Tx/Abort.hs b/hydra-tx/src/Hydra/Tx/Abort.hs index 5b4b94cc228..e1a6dc0e59c 100644 --- a/hydra-tx/src/Hydra/Tx/Abort.hs +++ b/hydra-tx/src/Hydra/Tx/Abort.hs @@ -14,7 +14,7 @@ import Hydra.Ledger.Cardano.Builder (burnTokens, unsafeBuildTransaction) import Hydra.Plutus (commitValidatorScript, initialValidatorScript) import Hydra.Tx (ScriptRegistry (..)) import Hydra.Tx.HeadId (HeadId (..)) -import Hydra.Tx.Utils (findStateToken, headTokensFromValue) +import Hydra.Tx.Utils (findStateToken, headTokensFromValue, mkHydraHeadV1TxName) -- * Creation @@ -55,6 +55,7 @@ abortTx committedUTxO scriptRegistry vk (headInput, initialHeadOutput) headToken & addTxOuts reimbursedOutputs & burnTokens headTokenScript Burn headTokens & addTxExtraKeyWits [verificationKeyHash vk] + & setTxMetadata (TxMetadataInEra $ mkHydraHeadV1TxName "AbortTx") where headWitness = BuildTxWith $ diff --git a/weeder.toml b/weeder.toml index 3fab9e9ec29..0153ac8a09d 100644 --- a/weeder.toml +++ b/weeder.toml @@ -11,11 +11,8 @@ roots = [ , "spy$" , "spy'$" , "redeemer$" - # toCardanoGenesisParameters, mkTinyWallet, queryTimeHandle will be needed for full blockfrost integration - , "toCardanoGenesisParameters" - , "mkTinyWallet" - , "queryTimeHandle" ] + root-instances = [ # Stock instances are treated as roots. { class = '\.Eq$' }