Create a blueprint tx from provided UTxO

Still missing to tackle the tx redeemers

mkBlueprintTx is adding outputs and still has to deal with
adding witnesses, datums and redeemers.

hydra-node/src/Hydra/API/HTTPServer.hs

@@ -1,38 +1,24 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Hydra.API.HTTPServer where
 
 import Hydra.Prelude
 
 import Cardano.Api.UTxO qualified as UTxO
+import Cardano.Ledger.Api (Redeemers (..), TxDats (TxDats), datsTxWitsL, hashData, hashScriptTxWitsL, mkBasicTx, mkBasicTxBody, outputsTxBodyL, rdmrsTxWitsL, unRedeemers, unTxDats, witsTxL)
 import Cardano.Ledger.Core (PParams)
+import Control.Lens ((.~), (^.))
 import Data.Aeson (KeyValue ((.=)), Value (Object), object, withObject, (.:), (.:?))
 import Data.Aeson qualified as Aeson
 import Data.Aeson.KeyMap qualified as KeyMap
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString.Short ()
+import Data.Map.Strict qualified as Map
+import Data.Sequence.Strict qualified as StrictSeq
 import Data.Text (pack)
 import Hydra.API.APIServerLog (APIServerLog (..), Method (..), PathInfo (..))
-import Hydra.Cardano.Api (
-  CtxUTxO,
-  HashableScriptData,
-  KeyWitnessInCtx (..),
-  LedgerEra,
-  PlutusScript,
-  ScriptDatum (InlineScriptDatum, ScriptDatumForTxIn),
-  ScriptWitnessInCtx (ScriptWitnessForSpending),
-  Tx,
-  TxOut,
-  UTxO',
-  deserialiseFromTextEnvelope,
-  fromLedgerPParams,
-  mkScriptWitness,
-  proxyToAsType,
-  serialiseToTextEnvelope,
-  shelleyBasedEra,
-  pattern KeyWitness,
-  pattern ScriptWitness,
- )
+import Hydra.Cardano.Api (CtxUTxO, HashableScriptData, LedgerEra, PlutusScript, Tx, TxOut, UTxO', deserialiseFromTextEnvelope, fromLedgerPParams, fromLedgerTx, proxyToAsType, serialiseToTextEnvelope, shelleyBasedEra, toLedgerData, toLedgerScript, toLedgerTxOut)
 import Hydra.Chain (Chain (..), IsChainState, PostTxError (..), draftCommitTx)
 import Hydra.Chain.Direct.State ()
 import Hydra.HeadId (HeadId)
@@ -270,45 +256,74 @@ handleDraftCommitUtxo directChain getInitializingHeadId body = do
     Left err ->
       pure $ responseLBS status400 [] (Aeson.encode $ Aeson.String $ pack err)
     Right FullCommitRequest{blueprintTx} -> do
-      pure undefined
+      atomically getInitializingHeadId >>= \case
+        Just headId -> do
+          let utxo = undefined
+          draftCommit headId utxo blueprintTx
+        Nothing -> pure $ responseLBS status500 [] (Aeson.encode $ FailedToDraftTxNotInitializing @Tx)
     Right SimpleCommitRequest{utxoToCommit} -> do
       atomically getInitializingHeadId >>= \case
         Just headId -> do
-          -- TODO: revisit
-          let blueprintTx = undefined
-          let utxo = undefined -- (fromTxOutWithWitness <$> utxoToCommit)
-          draftCommitTx headId undefined blueprintTx <&> \case
-            Left e ->
-              -- Distinguish between errors users can actually benefit from and
-              -- other errors that are turned into 500 responses.
-              case e of
-                CannotCommitReferenceScript -> return400 e
-                CommittedTooMuchADAForMainnet _ _ -> return400 e
-                UnsupportedLegacyOutput _ -> return400 e
-                walletUtxoErr@SpendingNodeUtxoForbidden -> return400 walletUtxoErr
-                _ -> responseLBS status500 [] (Aeson.encode $ toJSON e)
-            Right commitTx ->
-              responseLBS status200 [] (Aeson.encode $ DraftCommitTxResponse commitTx)
+          let blueprintTx = mkBlueprintTx utxoToCommit
+          let utxo =
+                UTxO.fromPairs $
+                  (\(txin, TxOutWithWitness{txOut}) -> (txin, txOut))
+                    <$> Map.assocs (UTxO.toMap utxoToCommit)
+          draftCommit headId utxo blueprintTx
         -- XXX: This is not really an internal server error
         Nothing -> pure $ responseLBS status500 [] (Aeson.encode $ FailedToDraftTxNotInitializing @Tx)
  where
+  draftCommit headId utxo blueprintTx =
+    draftCommitTx headId utxo blueprintTx <&> \case
+      Left e ->
+        -- Distinguish between errors users can actually benefit from and
+        -- other errors that are turned into 500 responses.
+        case e of
+          CannotCommitReferenceScript -> return400 e
+          CommittedTooMuchADAForMainnet _ _ -> return400 e
+          UnsupportedLegacyOutput _ -> return400 e
+          walletUtxoErr@SpendingNodeUtxoForbidden -> return400 walletUtxoErr
+          _ -> responseLBS status500 [] (Aeson.encode $ toJSON e)
+      Right commitTx ->
+        responseLBS status200 [] (Aeson.encode $ DraftCommitTxResponse commitTx)
   Chain{draftCommitTx} = directChain
 
-  fromTxOutWithWitness TxOutWithWitness{txOut, witness} =
-    (txOut, toScriptWitness witness)
-   where
-    toScriptWitness = \case
-      Nothing ->
-        KeyWitness KeyWitnessForSpending
-      Just ScriptInfo{redeemer, datum, plutusV2Script} ->
-        ScriptWitness ScriptWitnessForSpending $
-          case datum of
-            Nothing ->
-              -- In case the datum field is not present we are assumming the datum
-              -- is inlined.
-              mkScriptWitness plutusV2Script InlineScriptDatum redeemer
-            Just d ->
-              mkScriptWitness plutusV2Script (ScriptDatumForTxIn d) redeemer
+mkBlueprintTx :: UTxO' TxOutWithWitness -> Tx
+mkBlueprintTx utxoWithWitnesses =
+  let utxoWithWitneses' = Map.elems $ UTxO.toMap utxoWithWitnesses
+      tx = mkBasicTx (foldl' addOutputsToBody mkBasicTxBody utxoWithWitneses')
+   in fromLedgerTx $ addWitnessesToTx tx utxoWithWitneses'
+ where
+  addWitnessesToTx tx =
+    \case
+      [] -> tx
+      (TxOutWithWitness{witness} : rest) ->
+        case witness of
+          Nothing -> addWitnessesToTx tx rest
+          Just ScriptInfo{datum, redeemer, plutusV2Script} ->
+            let
+              existingWits = tx ^. witsTxL
+              existingDats = existingWits ^. datsTxWitsL
+              existingRedeemers = existingWits ^. rdmrsTxWitsL
+              redeemerData = toLedgerData @LedgerEra redeemer
+              dat =
+                case datum of
+                  Nothing -> existingDats
+                  Just dat' ->
+                    TxDats $ Map.insert (hashData (toLedgerData @LedgerEra dat')) (toLedgerData dat') (unTxDats existingDats)
+              -- TODO: tackle the redeemers
+              redeemers = Redeemers (unRedeemers existingRedeemers)
+              wits =
+                existingWits
+                  & hashScriptTxWitsL .~ [toLedgerScript plutusV2Script]
+                  & datsTxWitsL .~ dat
+             in
+              -- & rdmrsTxWitsL .~ redeemers
+
+              addWitnessesToTx (tx & witsTxL .~ wits) rest
+
+  addOutputsToBody txbody TxOutWithWitness{txOut} =
+    txbody & outputsTxBodyL .~ StrictSeq.singleton (toLedgerTxOut txOut)
 
 -- | Handle request to submit a cardano transaction.
 handleSubmitUserTx ::

hydra-node/src/Hydra/Chain.hs

@@ -19,13 +19,8 @@ import Hydra.Cardano.Api (
   Address,
   ByronAddr,
   Coin (..),
-  CtxUTxO,
   Tx,
-  TxOut,
   UTxO,
-  UTxO',
-  WitCtxTxIn,
-  Witness,
  )
 import Hydra.ContestationPeriod (ContestationPeriod)
 import Hydra.Environment (Environment (..))
@@ -252,7 +247,7 @@ data Chain tx m = Chain
       Tx ->
       m (Either (PostTxError Tx) Tx)
   -- ^ Create a commit transaction using user provided utxos (zero or many) and
-  -- information to spend from a script. Errors are handled at the call site.
+  -- a _blueprint_ transaction. Errors are handled at the call site.
   , submitTx :: MonadThrow m => Tx -> m ()
   -- ^ Submit a cardano transaction.
   --

hydra-node/test/Hydra/Chain/Direct/TxSpec.hs

@@ -42,6 +42,7 @@ import Test.QuickCheck (
   Property,
   choose,
   counterexample,
+  coverTable,
   elements,
   forAll,
   forAllBlind,
@@ -52,7 +53,7 @@ import Test.QuickCheck (
   withMaxSuccess,
   (.&&.),
   (=/=),
-  (===), coverTable,
+  (===),
  )
 import Test.QuickCheck.Instances.Semigroup ()
 import Test.QuickCheck.Monadic (monadicIO)
@@ -168,7 +169,6 @@ spec =
                     .&&. property (length (blueprintBody ^. referenceInputsTxBodyL) <= length (commitTxBody ^. referenceInputsTxBodyL))
                     .&&. property (length (blueprintBody ^. reqSignerHashesTxBodyL) <= length (commitTxBody ^. reqSignerHashesTxBodyL))
 
-
 withinTxExecutionBudget :: EvaluationReport -> Property
 withinTxExecutionBudget report =
   (totalMem <= maxMem && totalCpu <= maxCpu)