Update Chain.Direct.TxSpec (and collaterals) to work with cardano-api.

hydra-node/src/Hydra/Chain/Direct/Tx.hs

@@ -589,14 +589,6 @@ ownInitial vkey =
 
 -- * Helpers
 
--- | Lookup included datum of given 'TxOut'.
-lookupDatum :: CardanoTx -> TxOut CtxUTxO Era -> Maybe ScriptData
-lookupDatum _wits = undefined
-
---  \case
---  (TxOut _ _ (SJust datumHash)) -> Map.lookup datumHash . unTxDats $ txdats wits
---  _ -> Nothing
-
 -- | Find first occurrence including a transformation.
 findFirst :: Foldable t => (a -> Maybe b) -> t a -> Maybe b
 findFirst fn = getFirst . foldMap (First . fn)

hydra-node/src/Hydra/Ledger/Cardano.hs

@@ -231,6 +231,19 @@ getOutputs tx =
   let TxBody TxBodyContent{txOuts} = getTxBody tx
    in txOuts
 
+executionCost :: Ledger.Alonzo.PParams LedgerEra -> CardanoTx -> Lovelace
+executionCost pparams tx =
+  fromLedgerCoin (Ledger.Alonzo.txscriptfee (Ledger.Alonzo._prices pparams) executionUnits)
+ where
+  executionUnits = foldMap snd $ Ledger.Alonzo.unRedeemers $ Ledger.Alonzo.txrdmrs wits
+  Ledger.Alonzo.ValidatedTx{Ledger.Alonzo.wits = wits} = toLedgerTx tx
+
+getFee :: CardanoTx -> Lovelace
+getFee (getTxBody -> TxBody body) =
+  case txFee body of
+    TxFeeExplicit TxFeesExplicitInAlonzoEra fee -> fee
+    TxFeeImplicit _ -> error "impossible: TxFeeImplicit on non-Byron transaction."
+
 instance ToCBOR CardanoTx where
   toCBOR = CBOR.encodeBytes . serialize' . toLedgerTx
 
@@ -312,8 +325,8 @@ describeCardanoTx :: CardanoTx -> Text
 describeCardanoTx (Tx body _wits) =
   unlines $
     [ show (getTxId body)
-    , "  Inputs (" <> show (length inputs) <> ")"
-    , "  Outputs (" <> show (length outputs) <> ")"
+    , "  Inputs (" <> show (length inps) <> ")"
+    , "  Outputs (" <> show (length outs) <> ")"
     , "    total number of assets: " <> show totalNumberOfAssets
     , "  Scripts (" <> show (length scripts) <> ")"
     , "    total size (bytes):  " <> show totalScriptSize
@@ -322,13 +335,13 @@ describeCardanoTx (Tx body _wits) =
       <> redeemers
  where
   ShelleyTxBody _era lbody scripts scriptsData _auxData _validity = body
-  outputs = Ledger.Alonzo.outputs' lbody
-  inputs = Ledger.Alonzo.inputs' lbody
+  outs = Ledger.Alonzo.outputs' lbody
+  inps = Ledger.Alonzo.inputs' lbody
   totalScriptSize = sum $ BL.length . serialize <$> scripts
   totalNumberOfAssets =
     sum $
       [ foldl' (\n inner -> n + Map.size inner) 0 outer
-      | Ledger.Alonzo.TxOut _ (Ledger.Mary.Value _ outer) _ <- toList outputs
+      | Ledger.Alonzo.TxOut _ (Ledger.Mary.Value _ outer) _ <- toList outs
       ]
 
   datums = case scriptsData of
@@ -385,6 +398,10 @@ mkSimpleCardanoTx (txin, TxOut owner txOutValueIn datum) (recipient, valueOut) s
 mkTxIn :: TxBody era -> Word -> TxIn
 mkTxIn txBody index = TxIn (getTxId txBody) (TxIx index)
 
+inputs :: CardanoTx -> [TxIn]
+inputs (Tx (ShelleyTxBody _ body _ _ _ _) _) =
+  fromLedgerTxIn <$> toList (Ledger.Alonzo.inputs body)
+
 -- ** TxOut
 
 -- XXX(SN): replace with Cardano.Api.TxBody.lovelaceToTxOutValue when available
@@ -408,6 +425,18 @@ getDatum (TxOut _ _ d) = case d of
   TxOutDatum _ dat -> Just dat
   _ -> Nothing
 
+-- | Lookup included datum of given 'TxOut'.
+lookupDatum :: CardanoTx -> TxOut CtxUTxO Era -> Maybe ScriptData
+lookupDatum (Tx (ShelleyTxBody _ _ _ scriptsData _ _) _) = \case
+  TxOut _ _ TxOutDatumNone ->
+    Nothing
+  TxOut _ _ (TxOutDatumHash _ (ScriptDataHash h)) ->
+    fromPlutusData . Ledger.Alonzo.getPlutusData <$> Map.lookup h datums
+ where
+  datums = case scriptsData of
+    TxBodyNoScriptData -> mempty
+    TxBodyScriptData _ (Ledger.Alonzo.TxDats m) _ -> m
+
 modifyTxOutDatum ::
   (TxOutDatum ctx0 Era -> TxOutDatum ctx1 Era) ->
   TxOut ctx0 Era ->
@@ -623,6 +652,19 @@ instance ToTxContext TxOut where
   toTxContext =
     modifyTxOutDatum toTxContext
 
+class ToUtxoContext f where
+  toUtxoContext :: f CtxTx Era -> f CtxUTxO Era
+
+instance ToUtxoContext TxOutDatum where
+  toUtxoContext = \case
+    TxOutDatumNone -> TxOutDatumNone
+    TxOutDatumHash s h -> TxOutDatumHash s h
+    TxOutDatum s d -> TxOutDatumHash s (hashScriptData d)
+
+instance ToUtxoContext TxOut where
+  toUtxoContext =
+    modifyTxOutDatum toUtxoContext
+
 -- * Generators
 
 genKeyPair :: Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
@@ -715,9 +757,9 @@ genUtxo = do
 genUtxoFor :: VerificationKey PaymentKey -> Gen Utxo
 genUtxoFor vk = do
   n <- arbitrary `suchThat` (> 0)
-  inputs <- vectorOf n arbitrary
-  outputs <- vectorOf n (genOutput vk)
-  pure $ Utxo $ Map.fromList $ zip (fromLedgerTxIn <$> inputs) outputs
+  inps <- vectorOf n arbitrary
+  outs <- vectorOf n (genOutput vk)
+  pure $ Utxo $ Map.fromList $ zip (fromLedgerTxIn <$> inps) outs
 
 -- | Generate a single UTXO owned by 'vk'.
 genOneUtxoFor :: VerificationKey PaymentKey -> Gen Utxo
@@ -806,6 +848,14 @@ instance Arbitrary TxId where
 instance Arbitrary (TxOut CtxUTxO AlonzoEra) where
   arbitrary = fromShelleyTxOut ShelleyBasedEraAlonzo <$> arbitrary
 
+instance Arbitrary (VerificationKey PaymentKey) where
+  arbitrary = fst <$> genKeyPair
+
+instance Arbitrary (Hash PaymentKey) where
+  arbitrary = do
+    bytes <- BS.pack <$> vectorOf 28 arbitrary
+    pure $ PaymentKeyHash $ Ledger.KeyHash $ unsafeHashFromBytes bytes
+
 -- * Temporary / Quick-n-dirty
 
 -- NOTE: The constructor for Hash isn't exposed in the cardano-api. Although

hydra-node/src/Hydra/Ledger/Cardano/Isomorphism.hs

@@ -39,6 +39,7 @@ import qualified Cardano.Ledger.Alonzo.Tx as Ledger.Alonzo
 import qualified Cardano.Ledger.Alonzo.TxInfo as Ledger
 import qualified Cardano.Ledger.Alonzo.TxWitness as Ledger.Alonzo
 import qualified Cardano.Ledger.BaseTypes as Ledger
+import qualified Cardano.Ledger.Coin as Ledger
 import qualified Cardano.Ledger.Core as Ledger
 import qualified Cardano.Ledger.Credential as Ledger
 import qualified Cardano.Ledger.Crypto as Ledger (StandardCrypto)
@@ -127,6 +128,11 @@ fromPlutusAddress Plutus.Address{Plutus.addressCredential = credential, Plutus.a
  where
   network = Ledger.Testnet
 
+-- ** Coin
+
+fromLedgerCoin :: Ledger.Coin -> Lovelace
+fromLedgerCoin (Ledger.Coin n) = Lovelace n
+
 -- ** Key
 
 toPlutusKeyHash :: Hash PaymentKey -> Plutus.PubKeyHash

hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs

@@ -4,30 +4,16 @@
 
 module Hydra.Chain.Direct.Contract.Close where
 
+import Hydra.Ledger.Cardano hiding (SigningKey)
 import Hydra.Prelude hiding (label)
 
 import Cardano.Binary (serialize')
-import qualified Cardano.Ledger.Alonzo.Data as Ledger
-import qualified Cardano.Ledger.Shelley.API as Ledger
-import qualified Data.Map as Map
-import Data.Maybe.Strict (StrictMaybe (..))
-import Hydra.Chain.Direct.Contract.Mutation (
-  Mutation (..),
-  SomeMutation (..),
- )
-import Hydra.Chain.Direct.Tx (
-  closeTx,
- )
+import Hydra.Chain.Direct.Contract.Mutation (Mutation (..), SomeMutation (..))
+import Hydra.Chain.Direct.Tx (closeTx)
 import Hydra.Chain.Direct.TxSpec (mkHeadOutput)
 import qualified Hydra.Contract.HeadState as Head
 import Hydra.Data.Party (partyFromVerKey)
 import qualified Hydra.Data.Party as OnChain
-import Hydra.Ledger.Cardano (
-  CardanoTx,
-  Utxo,
-  fromLedgerTx,
-  fromLedgerUtxo,
- )
 import Hydra.Party (
   MultiSigned (MultiSigned),
   SigningKey,
@@ -39,11 +25,7 @@ import Hydra.Party (
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
 import Plutus.Orphans ()
 import Plutus.V1.Ledger.Api (toData)
-import Test.QuickCheck (
-  arbitrarySizedNatural,
-  oneof,
-  suchThat,
- )
+import Test.QuickCheck (arbitrarySizedNatural, oneof, suchThat)
 import Test.QuickCheck.Instances ()
 
 --
@@ -52,15 +34,13 @@ import Test.QuickCheck.Instances ()
 
 healthyCloseTx :: (CardanoTx, Utxo)
 healthyCloseTx =
-  ( fromLedgerTx tx
-  , fromLedgerUtxo lookupUtxo
-  )
+  (tx, lookupUtxo)
  where
   tx = closeTx healthySnapshot (healthySignature healthySnapshotNumber) (headInput, headOutput, headDatum)
   headInput = generateWith arbitrary 42
-  headOutput = mkHeadOutput (SJust headDatum)
-  headDatum = Ledger.Data $ toData healthyCloseDatum
-  lookupUtxo = Ledger.UTxO $ Map.singleton headInput headOutput
+  headOutput = mkHeadOutput $ toUtxoContext (mkTxOutDatum healthyCloseDatum)
+  headDatum = fromPlutusData $ toData healthyCloseDatum
+  lookupUtxo = singletonUtxo (headInput, headOutput)
 
 healthySnapshot :: Snapshot CardanoTx
 healthySnapshot =

hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs

@@ -4,14 +4,17 @@
 
 module Hydra.Chain.Direct.Contract.CollectCom where
 
+import Hydra.Ledger.Cardano
 import Hydra.Prelude hiding (label)
 
-import qualified Cardano.Ledger.Alonzo.Data as Ledger
-import qualified Cardano.Ledger.Shelley.API as Ledger
 import qualified Data.Map as Map
 import Data.Maybe (fromJust)
-import Data.Maybe.Strict (StrictMaybe (..))
-import Hydra.Chain.Direct.Contract.Mutation (Mutation (..), SomeMutation (..), genHash, isHeadOutput)
+import Hydra.Chain.Direct.Contract.Mutation (
+  Mutation (..),
+  SomeMutation (..),
+  genHash,
+  isHeadOutput,
+ )
 import qualified Hydra.Chain.Direct.Fixture as Fixture
 import Hydra.Chain.Direct.Tx (
   collectComTx,
@@ -24,44 +27,11 @@ import qualified Hydra.Contract.Head as Head
 import qualified Hydra.Contract.HeadState as Head
 import qualified Hydra.Data.Party as OnChain
 import qualified Hydra.Data.Party as Party
-import Hydra.Ledger.Cardano (
-  AlonzoEra,
-  CardanoTx,
-  CtxUTxO,
-  LedgerEra,
-  TxIn,
-  TxOut (..),
-  TxOutDatum (..),
-  Utxo,
-  fromLedgerTx,
-  fromLedgerUtxo,
-  fromPlutusScript,
-  genAdaOnlyUtxo,
-  genOutput,
-  genValue,
-  getOutputs,
-  lovelaceToValue,
-  mkScriptAddress,
-  mkTxOutDatum,
-  mkTxOutValue,
-  toCtxUTxOTxOut,
-  toLedgerTxIn,
-  toLedgerTxOut,
-  toPlutusData,
-  txOutValue,
-  utxoPairs,
- )
 import qualified Hydra.Ledger.Cardano as Api
-import Hydra.Party (
-  Party,
-  vkey,
- )
+import Hydra.Party (Party, vkey)
 import Plutus.Orphans ()
 import Plutus.V1.Ledger.Api (fromData, toBuiltin, toData)
-import Test.QuickCheck (
-  oneof,
-  suchThat,
- )
+import Test.QuickCheck (oneof, suchThat)
 import Test.QuickCheck.Instances ()
 import qualified Prelude
 
@@ -71,13 +41,10 @@ import qualified Prelude
 
 healthyCollectComTx :: (CardanoTx, Utxo)
 healthyCollectComTx =
-  ( fromLedgerTx tx
-  , fromLedgerUtxo lookupUtxo
-  )
+  (tx, lookupUtxo)
  where
   lookupUtxo =
-    Ledger.UTxO $
-      Map.singleton headInput headResolvedInput <> (fst <$> commits)
+    singletonUtxo (headInput, headResolvedInput) <> Utxo (fst <$> commits)
 
   tx =
     collectComTx
@@ -93,12 +60,10 @@ healthyCollectComTx =
   commits =
     (uncurry healthyCommitOutput <$> zip healthyCollectComParties committedUtxo)
       & Map.fromList
-      & Map.mapKeys toLedgerTxIn
-      & Map.map (first toLedgerTxOut)
 
   headInput = generateWith arbitrary 42
-  headResolvedInput = mkHeadOutput (SJust headDatum)
-  headDatum = Ledger.Data $ toData healthyCollectComInitialDatum
+  headResolvedInput = mkHeadOutput (toUtxoContext $ mkTxOutDatum healthyCollectComInitialDatum)
+  headDatum = fromPlutusData $ toData healthyCollectComInitialDatum
 
 healthyCollectComInitialDatum :: Head.State
 healthyCollectComInitialDatum =
@@ -125,12 +90,12 @@ genCommittableTxOut =
 healthyCommitOutput ::
   Party ->
   (TxIn, TxOut CtxUTxO AlonzoEra) ->
-  (TxIn, (TxOut CtxUTxO AlonzoEra, Ledger.Data LedgerEra))
+  (TxIn, (TxOut CtxUTxO AlonzoEra, ScriptData))
 healthyCommitOutput party committed =
   ( generateWith arbitrary seed
   ,
     ( toCtxUTxOTxOut (TxOut commitAddress commitValue (mkTxOutDatum commitDatum))
-    , Ledger.Data (toData commitDatum)
+    , fromPlutusData (toData commitDatum)
     )
   )
  where