Publish scripts via blockfrost api

hydra-node/exe/hydra-node/Main.hs

@@ -13,12 +13,7 @@ import Hydra.Chain.Direct.Util (readKeyPair)
 import Hydra.Chain.ScriptRegistry (publishHydraScripts)
 import Hydra.Logging (Verbosity (..))
 import Hydra.Node.Run (run)
-import Hydra.Options (
-  Command (GenHydraKey, Publish, Run),
-  PublishOptions (..),
-  RunOptions (..),
-  parseHydraCommand,
- )
+import Hydra.Options (ChainConfig (..), Command (GenHydraKey, Publish, Run), DirectChainConfig (..), PublishOptions (..), RunOptions (..), parseHydraCommand)
 import Hydra.Utils (genHydraKeys)
 import System.Posix.Signals qualified as Signals
 
@@ -35,11 +30,13 @@ main = do
     GenHydraKey outputFile ->
       either (die . show) pure =<< genHydraKeys outputFile
  where
-  publish opts = do
-    (_, sk) <- readKeyPair (publishSigningKey opts)
-    let PublishOptions{publishNetworkId = networkId, publishNodeSocket} = opts
-    txIds <- publishHydraScripts networkId publishNodeSocket sk
-    putBSLn $ intercalate "," (serialiseToRawBytesHex <$> txIds)
+  publish PublishOptions{publishChainConfig} = case publishChainConfig of
+    Offline _ -> error "not supported"
+    Direct DirectChainConfig{networkId, nodeSocket, cardanoSigningKey} ->
+      do
+        (_, sk) <- readKeyPair cardanoSigningKey
+        txIds <- publishHydraScripts networkId nodeSocket sk
+        putBSLn $ intercalate "," (serialiseToRawBytesHex <$> txIds)
 
 -- | Handle SIGTERM like SIGINT
 --

hydra-node/hydra-node.cabal

@@ -56,6 +56,7 @@ library
     Hydra.API.ServerOutputFilter
     Hydra.API.WSServer
     Hydra.Chain
+    Hydra.Chain.Blockfrost.Client
     Hydra.Chain.CardanoClient
     Hydra.Chain.Direct
     Hydra.Chain.Direct.Handlers
@@ -95,6 +96,7 @@ library
   build-depends:
     , aeson
     , base
+    , blockfrost-client               >=0.9.1.0
     , bytestring
     , cardano-api:internal
     , cardano-binary
@@ -110,6 +112,7 @@ library
     , cardano-ledger-shelley
     , cardano-slotting
     , cardano-strict-containers
+    , cborg
     , conduit
     , containers
     , contra-tracer
@@ -144,6 +147,7 @@ library
     , quickcheck-arbitrary-adt
     , quickcheck-instances
     , resourcet
+    , safe-money
     , serialise
     , stm
     , text

hydra-node/src/Hydra/Chain/Blockfrost/Client.hs

@@ -0,0 +1,211 @@
+module Hydra.Chain.Blockfrost.Client where
+
+import Hydra.Prelude
+
+import Blockfrost.Client (
+  BlockfrostClientT,
+  runBlockfrost,
+ )
+import Blockfrost.Client qualified as Blockfrost
+import Codec.CBOR.Encoding qualified as CBOR
+import Codec.CBOR.Write (toLazyByteString)
+import Data.ByteString.Lazy qualified as BL
+import Data.Time.Clock.POSIX
+import Hydra.Cardano.Api hiding (fromNetworkMagic)
+
+import Cardano.Api.UTxO qualified as UTxO
+import Data.Set qualified as Set
+import Hydra.Cardano.Api.Prelude (StakePoolKey)
+import Hydra.Contract.Head qualified as Head
+import Hydra.Plutus (commitValidatorScript, initialValidatorScript)
+import Money qualified
+
+data APIBlockfrostError
+  = BlockfrostError Text
+  | DecodeError Text
+  deriving (Show, Exception)
+
+runBlockfrostM ::
+  (MonadIO m, MonadThrow m) =>
+  Blockfrost.Project ->
+  BlockfrostClientT IO a ->
+  m a
+runBlockfrostM prj action = do
+  result <- liftIO $ runBlockfrost prj action
+  case result of
+    Left err -> throwIO (BlockfrostError $ 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
+    pparams <- Blockfrost.getLatestEpochProtocolParams
+    Blockfrost.Genesis
+      { _genesisNetworkMagic = networkMagic
+      , _genesisSystemStart = systemStart
+      } <-
+      Blockfrost.getLedgerGenesis
+    let address = Blockfrost.Address (vkAddress networkMagic)
+    let networkId = fromNetworkMagic networkMagic
+    let changeAddress = mkVkAddress networkId vk
+    stakePools <- Blockfrost.listPools
+    forM scripts $ \script -> do
+      utxo <- Blockfrost.getAddressUtxos address
+      liftIO $
+        buildTx pparams networkId systemStart stakePools script changeAddress utxo
+          >>= \case
+            Left err ->
+              liftIO $ throwErrorAsException err
+            Right rawTx -> do
+              let body = getTxBody rawTx
+                  tx = makeSignedTransaction [makeShelleyKeyWitness body (WitnessPaymentKey sk)] body
+                  -- REVIEW! double CBOR encoding
+                  txByteString :: BL.ByteString = toLazyByteString (CBOR.encodeBytes $ serialiseToCBOR tx)
+                  txCborString = Blockfrost.CBORString txByteString
+              txHash <- Blockfrost.submitTx txCborString
+              -- TODO! await transaction confirmed
+              pure undefined
+ where
+  scripts = [initialValidatorScript, commitValidatorScript, Head.validatorScript]
+
+  vk = getVerificationKey sk
+
+  vkAddress networkMagic = textAddrOf (fromNetworkMagic networkMagic) vk
+
+-- TODO!
+buildTx ::
+  Blockfrost.ProtocolParams ->
+  NetworkId ->
+  POSIXTime ->
+  [Blockfrost.PoolId] ->
+  PlutusScript ->
+  -- | Change address to send
+  AddressInEra ->
+  [Blockfrost.AddressUtxo] ->
+  IO (Either (TxBodyErrorAutoBalance Era) Tx)
+buildTx pparams networkId posixTime stakePools script changeAddress utxo = do
+  pure $
+    second (flip Tx [] . balancedTxBody) $
+      makeTransactionBodyAutoBalance
+        shelleyBasedEra
+        systemStart
+        undefined -- (toLedgerEpochInfo eraHistory)
+        undefined -- (LedgerProtocolParameters pparams)
+        (Set.fromList (toApiPoolId <$> stakePools))
+        mempty
+        mempty
+        (UTxO.toApi utxoToSpend)
+        bodyContent
+        changeAddress
+        Nothing
+ where
+  unspendableScriptAddress = mkScriptAddress networkId $ examplePlutusScriptAlwaysFails WitCtxTxIn
+  -- FIXME! mkTxOutAutoBalance with minUTxOValue from pparams
+  outputs = TxOut unspendableScriptAddress mempty TxOutDatumNone <$> [mkScriptRef script]
+  utxo' = toApiUTxO utxo changeAddress
+  totalDeposit = sum (selectLovelace . txOutValue <$> outputs)
+  utxoToSpend = maybe mempty UTxO.singleton $ UTxO.find (\o -> selectLovelace (txOutValue o) > totalDeposit) utxo'
+  systemStart = SystemStart $ posixSecondsToUTCTime posixTime
+  collateral = mempty
+  -- NOTE: 'makeTransactionBodyAutoBalance' overwrites this.
+  dummyFeeForBalancing = TxFeeExplicit 0
+  bodyContent =
+    TxBodyContent
+      (withWitness <$> toList (UTxO.inputSet utxoToSpend))
+      (TxInsCollateral collateral)
+      TxInsReferenceNone
+      outputs
+      TxTotalCollateralNone
+      TxReturnCollateralNone
+      dummyFeeForBalancing
+      TxValidityNoLowerBound
+      TxValidityNoUpperBound
+      TxMetadataNone
+      TxAuxScriptsNone
+      TxExtraKeyWitnessesNone
+      undefined -- (BuildTxWith $ Just $ LedgerProtocolParameters pparams)
+      TxWithdrawalsNone
+      TxCertificatesNone
+      TxUpdateProposalNone
+      TxMintValueNone
+      TxScriptValidityNone
+      Nothing
+      Nothing
+      Nothing
+      Nothing
+
+-- ** Extras
+
+toApiPoolId :: Blockfrost.PoolId -> Hash StakePoolKey
+toApiPoolId (Blockfrost.PoolId textPoolId) =
+  case deserialiseFromRawBytesHex (AsHash AsStakePoolKey) (encodeUtf8 textPoolId) of
+    Left err -> error (show err)
+    Right pool -> pool
+
+toApiUTxO :: [Blockfrost.AddressUtxo] -> AddressInEra -> UTxO' (TxOut CtxUTxO)
+toApiUTxO utxos addr = UTxO.fromPairs (toEntry <$> utxos)
+ where
+  toEntry :: Blockfrost.AddressUtxo -> (TxIn, TxOut CtxUTxO)
+  toEntry utxo = (toApiTxIn utxo, toApiTxOut utxo addr)
+
+toApiTxIn :: Blockfrost.AddressUtxo -> TxIn
+toApiTxIn Blockfrost.AddressUtxo{_addressUtxoTxHash = Blockfrost.TxHash{unTxHash}, _addressUtxoOutputIndex} =
+  case deserialiseFromRawBytesHex AsTxId (encodeUtf8 unTxHash) of
+    Left err -> error (show err)
+    Right txId -> TxIn txId (TxIx (fromIntegral _addressUtxoOutputIndex))
+
+-- REVIEW! TxOutDatumNone and ReferenceScriptNone
+toApiTxOut :: Blockfrost.AddressUtxo -> AddressInEra -> TxOut CtxUTxO
+toApiTxOut Blockfrost.AddressUtxo{_addressUtxoAmount} addr =
+  TxOut addr (toApiValue _addressUtxoAmount) TxOutDatumNone ReferenceScriptNone
+
+toApiPolicyId :: Text -> PolicyId
+toApiPolicyId pid =
+  case deserialiseFromRawBytesHex AsPolicyId (encodeUtf8 pid) of
+    Left err -> error (show err)
+    Right p -> p
+
+toApiAssetName :: Text -> AssetName
+toApiAssetName = AssetName . encodeUtf8
+
+toApiValue :: [Blockfrost.Amount] -> Value
+toApiValue = foldMap convertAmount
+ where
+  convertAmount (Blockfrost.AdaAmount lovelaces) =
+    fromList
+      [
+        ( AdaAssetId
+        , Quantity (toInteger lovelaces)
+        )
+      ]
+  convertAmount (Blockfrost.AssetAmount money) =
+    let currency = Money.someDiscreteCurrency money
+     in fromList
+          [
+            ( AssetId
+                (toApiPolicyId currency)
+                (toApiAssetName currency)
+            , Quantity (Money.someDiscreteAmount money)
+            )
+          ]
+
+-- ** Helpers
+
+unwrapAddress :: AddressInEra -> Text
+unwrapAddress = \case
+  ShelleyAddressInEra addr -> serialiseToBech32 addr
+  ByronAddressInEra{} -> error "Byron."
+
+textAddrOf :: NetworkId -> VerificationKey PaymentKey -> Text
+textAddrOf networkId vk = unwrapAddress (mkVkAddress @Era networkId vk)
+
+fromNetworkMagic :: Integer -> NetworkId
+fromNetworkMagic = \case
+  0 -> Mainnet
+  magicNbr -> Testnet (NetworkMagic (fromInteger magicNbr))

hydra-node/src/Hydra/Options.hs

@@ -133,28 +133,14 @@ commandParser =
           (progDesc "Generate a pair of Hydra signing/verification keys (off-chain keys).")
       )
 
-data PublishOptions = PublishOptions
-  { publishNetworkId :: NetworkId
-  , publishNodeSocket :: SocketPath
-  , publishSigningKey :: FilePath
+newtype PublishOptions = PublishOptions
+  { publishChainConfig :: ChainConfig
   }
   deriving stock (Show, Eq)
 
--- | Default options as they should also be provided by 'runOptionsParser'.
-defaultPublishOptions :: PublishOptions
-defaultPublishOptions =
-  PublishOptions
-    { publishNetworkId = Testnet (NetworkMagic 42)
-    , publishNodeSocket = "node.socket"
-    , publishSigningKey = "cardano.sk"
-    }
-
 publishOptionsParser :: Parser PublishOptions
 publishOptionsParser =
-  PublishOptions
-    <$> networkIdParser
-    <*> nodeSocketParser
-    <*> cardanoSigningKeyFileParser
+  PublishOptions <$> chainConfigParser
 
 data RunOptions = RunOptions
   { verbosity :: Verbosity
@@ -259,11 +245,14 @@ runOptionsParser =
     <*> hydraSigningKeyFileParser
     <*> many hydraVerificationKeyFileParser
     <*> persistenceDirParser
-    <*> ( Direct <$> directChainConfigParser
-            <|> Offline <$> offlineChainConfigParser
-        )
+    <*> chainConfigParser
     <*> ledgerConfigParser
 
+chainConfigParser :: Parser ChainConfig
+chainConfigParser =
+  Direct <$> directChainConfigParser
+    <|> Offline <$> offlineChainConfigParser
+
 newtype GenerateKeyPair = GenerateKeyPair
   { outputFile :: FilePath
   }
@@ -495,7 +484,7 @@ nodeSocketParser =
   strOption
     ( long "node-socket"
         <> metavar "FILE"
-        <> value (publishNodeSocket defaultPublishOptions)
+        <> value (nodeSocket defaultDirectChainConfig)
         <> showDefault
         <> help
           "Filepath to local unix domain socket used to communicate with \
@@ -508,7 +497,7 @@ cardanoSigningKeyFileParser =
     ( long "cardano-signing-key"
         <> metavar "FILE"
         <> showDefault
-        <> value (publishSigningKey defaultPublishOptions)
+        <> value (cardanoSigningKey defaultDirectChainConfig)
         <> 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 \