PLT-9086: Enable Hardware wallet Signing (canonical CBOR format)

marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Common.hs

@@ -14,20 +14,17 @@ module Language.Marlowe.Runtime.Web.Common (
 ) where
 
 import Cardano.Api (
-  AsType (..),
+  BabbageEra,
   ShelleyWitnessSigningKey (..),
-  TextEnvelope (..),
-  TextEnvelopeType (..),
-  deserialiseFromTextEnvelope,
-  serialiseToTextEnvelope,
+  Tx,
+  getTxBody,
+  getTxWitnesses,
   signShelleyTransaction,
  )
 import Control.Concurrent (threadDelay)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.String (IsString (..))
-import qualified Data.Text as T
 import qualified Language.Marlowe as V1
 import Language.Marlowe.Core.V1.Semantics.Types (
   ChoiceId (ChoiceId),
@@ -49,7 +46,7 @@ import Language.Marlowe.Runtime.Web.Client (
   putTransaction,
   putWithdrawal,
  )
-import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO))
+import Language.Marlowe.Runtime.Web.Server.DTO (FromDTO (..), ToDTO (toDTO))
 import qualified PlutusLedgerApi.V2 as PV2
 import Servant.Client.Streaming (ClientM)
 
@@ -60,7 +57,7 @@ createCloseContract Wallet{..} = do
   let webExtraAddresses = Set.map toDTO extraAddresses
   let webCollateralUtxos = Set.map toDTO collateralUtxos
 
-  Web.CreateTxEnvelope{txEnvelope, ..} <-
+  Web.CreateTxEnvelope{tx, ..} <-
     postContract
       Nothing
       webChangeAddress
@@ -76,7 +73,7 @@ createCloseContract Wallet{..} = do
         , tags = mempty
         }
 
-  createTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys
+  createTx <- liftIO $ signShelleyTransaction' tx signingKeys
   putContract contractId createTx
   _ <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
   pure contractId
@@ -87,7 +84,7 @@ applyCloseTransaction Wallet{..} contractId = do
   let webChangeAddress = toDTO changeAddress
   let webExtraAddresses = Set.map toDTO extraAddresses
   let webCollateralUtxos = Set.map toDTO collateralUtxos
-  Web.ApplyInputsTxEnvelope{transactionId, txEnvelope} <-
+  Web.ApplyInputsTxEnvelope{transactionId, tx} <-
     postTransaction
       webChangeAddress
       (Just webExtraAddresses)
@@ -102,7 +99,7 @@ applyCloseTransaction Wallet{..} contractId = do
         , tags = mempty
         }
 
-  applyTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys
+  applyTx <- liftIO $ signShelleyTransaction' tx signingKeys
 
   putTransaction contractId transactionId applyTx
 
@@ -111,30 +108,30 @@ applyCloseTransaction Wallet{..} contractId = do
 
 submitContract
   :: Wallet
-  -> Web.CreateTxEnvelope Web.CardanoTxBody
+  -> Web.CreateTxEnvelope
   -> ClientM Web.BlockHeader
-submitContract Wallet{..} Web.CreateTxEnvelope{contractId, txEnvelope} = do
-  signedCreateTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys
+submitContract Wallet{..} Web.CreateTxEnvelope{contractId, tx} = do
+  signedCreateTx <- liftIO $ signShelleyTransaction' tx signingKeys
   putContract contractId signedCreateTx
   Web.ContractState{block} <- waitUntilConfirmed (\Web.ContractState{status} -> status) $ getContract contractId
   liftIO $ expectJust "Expected block header" block
 
 submitTransaction
   :: Wallet
-  -> Web.ApplyInputsTxEnvelope Web.CardanoTxBody
+  -> Web.ApplyInputsTxEnvelope
   -> ClientM Web.BlockHeader
-submitTransaction Wallet{..} Web.ApplyInputsTxEnvelope{contractId, transactionId, txEnvelope} = do
-  signedTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys
+submitTransaction Wallet{..} Web.ApplyInputsTxEnvelope{contractId, transactionId, tx} = do
+  signedTx <- liftIO $ signShelleyTransaction' tx signingKeys
   putTransaction contractId transactionId signedTx
   Web.Tx{block} <- waitUntilConfirmed (\Web.Tx{status} -> status) $ getTransaction contractId transactionId
   liftIO $ expectJust "Expected a block header" block
 
 submitWithdrawal
   :: Wallet
-  -> Web.WithdrawTxEnvelope Web.CardanoTxBody
+  -> Web.WithdrawTxEnvelope
   -> ClientM Web.BlockHeader
-submitWithdrawal Wallet{..} Web.WithdrawTxEnvelope{withdrawalId, txEnvelope} = do
-  signedWithdrawalTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys
+submitWithdrawal Wallet{..} Web.WithdrawTxEnvelope{withdrawalId, tx} = do
+  signedWithdrawalTx <- liftIO $ signShelleyTransaction' tx signingKeys
   putWithdrawal withdrawalId signedWithdrawalTx
   Web.Withdrawal{block} <- waitUntilConfirmed (\Web.Withdrawal{status} -> status) $ getWithdrawal withdrawalId
   liftIO $ expectJust "Expected a block header" block
@@ -146,7 +143,7 @@ deposit
   -> V1.Party
   -> V1.Token
   -> Integer
-  -> ClientM (Web.ApplyInputsTxEnvelope Web.CardanoTxBody)
+  -> ClientM Web.ApplyInputsTxEnvelope
 deposit wallet contractId intoAccount fromParty ofToken quantity =
   applyInputs wallet contractId [NormalInput $ IDeposit intoAccount fromParty ofToken quantity]
 
@@ -156,20 +153,20 @@ choose
   -> PV2.BuiltinByteString
   -> V1.Party
   -> Integer
-  -> ClientM (Web.ApplyInputsTxEnvelope Web.CardanoTxBody)
+  -> ClientM Web.ApplyInputsTxEnvelope
 choose wallet contractId choice party chosenNum =
   applyInputs wallet contractId [NormalInput $ IChoice (ChoiceId choice party) chosenNum]
 
 notify
   :: Wallet
   -> Web.TxOutRef
-  -> ClientM (Web.ApplyInputsTxEnvelope Web.CardanoTxBody)
+  -> ClientM Web.ApplyInputsTxEnvelope
 notify wallet contractId = applyInputs wallet contractId [NormalInput INotify]
 
 withdraw
   :: Wallet
   -> Set Web.TxOutRef
-  -> ClientM (Web.WithdrawTxEnvelope Web.CardanoTxBody)
+  -> ClientM Web.WithdrawTxEnvelope
 withdraw Wallet{..} payouts = do
   let WalletAddresses{..} = addresses
   let webChangeAddress = toDTO changeAddress
@@ -187,7 +184,7 @@ applyInputs
   :: Wallet
   -> Web.TxOutRef
   -> [V1.Input]
-  -> ClientM (Web.ApplyInputsTxEnvelope Web.CardanoTxBody)
+  -> ClientM Web.ApplyInputsTxEnvelope
 applyInputs Wallet{..} contractId inputs = do
   let WalletAddresses{..} = addresses
   let webChangeAddress = toDTO changeAddress
@@ -208,19 +205,10 @@ applyInputs Wallet{..} contractId inputs = do
       , tags = mempty
       }
 
-signShelleyTransaction' :: Web.TextEnvelope -> [ShelleyWitnessSigningKey] -> IO Web.TextEnvelope
-signShelleyTransaction' Web.TextEnvelope{..} wits = do
-  let te =
-        TextEnvelope
-          { teType = TextEnvelopeType (T.unpack teType)
-          , teDescription = fromString (T.unpack teDescription)
-          , teRawCBOR = Web.unBase16 teCborHex
-          }
-  txBody <- case deserialiseFromTextEnvelope (AsTxBody AsBabbage) te of
-    Left err -> fail $ show err
-    Right a -> pure a
-  pure case serialiseToTextEnvelope Nothing $ signShelleyTransaction txBody wits of
-    TextEnvelope (TextEnvelopeType ty) _ bytes -> Web.TextEnvelope (T.pack ty) "" $ Web.Base16 bytes
+signShelleyTransaction' :: Web.UnwitnessedTx -> [ShelleyWitnessSigningKey] -> IO Web.TxWitness
+signShelleyTransaction' txEnvelope wits = do
+  tx :: Tx BabbageEra <- expectJust "Failed to deserialise tx" $ fromDTO txEnvelope
+  pure $ toDTO $ head $ getTxWitnesses $ signShelleyTransaction (getTxBody tx) wits
 
 waitUntilConfirmed :: (MonadIO m) => (a -> Web.TxStatus) -> m a -> m a
 waitUntilConfirmed getStatus getResource = do

marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Post.hs

@@ -5,14 +5,14 @@ module Language.Marlowe.Runtime.Web.Contracts.Contract.Post where
 import Control.Monad.IO.Class (MonadIO (liftIO))
 
 import Cardano.Api (
-  AsType (..),
+  BabbageEra,
   TxBody (..),
   TxBodyContent (..),
   TxMetadata (TxMetadata),
   TxMetadataInEra (..),
   TxMetadataSupportedInEra (TxMetadataInBabbageEra),
   TxMetadataValue (..),
-  deserialiseFromTextEnvelope,
+  getTxBody,
  )
 import Data.Aeson (Value (String))
 import qualified Data.Aeson.Key as Key
@@ -132,10 +132,8 @@ bugPLT8712 = do
               , tags = mempty
               }
         liftIO do
-          textEnvelope <- expectJust "Failed to convert text envelope" $ fromDTO txEnvelope
-          TxBody TxBodyContent{..} <-
-            expectRight "Failed to deserialise tx body" $
-              deserialiseFromTextEnvelope (AsTxBody AsBabbageEra) textEnvelope
+          tx' <- expectJust "Failed to convert text envelope" $ fromDTO tx
+          let TxBody TxBodyContent{..} = getTxBody @BabbageEra tx'
           case txMetadata of
             TxMetadataNone -> fail "expected metadata"
             TxMetadataInEra TxMetadataInBabbageEra (TxMetadata m) -> do

marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Contract/Put.hs

@@ -36,7 +36,7 @@ spec = describe "POST /contracts/{contractId}/transactions" do
 
       let (contract, _, _) = standardContract partyBAddress now $ secondsToNominalDiffTime 100
 
-      Web.CreateTxEnvelope{contractId, txEnvelope} <-
+      Web.CreateTxEnvelope{contractId, tx} <-
         postContract
           Nothing
           partyAWebChangeAddress
@@ -55,7 +55,7 @@ spec = describe "POST /contracts/{contractId}/transactions" do
             , minUTxODeposit = Nothing
             , tags = mempty
             }
-      signedCreateTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys
+      signedCreateTx <- liftIO $ signShelleyTransaction' tx signingKeys
       putContract contractId signedCreateTx
     case result of
       Left _ -> fail $ "Expected 200 response code - got " <> show result

marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Contracts/Transactions/Transaction/Put.hs

@@ -68,7 +68,7 @@ spec = describe "PUT /contracts/{contractId}/transactions/{transaction}" do
 
       let inputs = [NormalInput $ IDeposit partyA partyA ada 100_000_000]
 
-      Web.ApplyInputsTxEnvelope{transactionId, txEnvelope} <-
+      Web.ApplyInputsTxEnvelope{transactionId, tx} <-
         postTransaction
           partyAWebChangeAddress
           (Just partyAWebExtraAddresses)
@@ -82,7 +82,7 @@ spec = describe "PUT /contracts/{contractId}/transactions/{transaction}" do
             , inputs
             , tags = mempty
             }
-      applyTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys
+      applyTx <- liftIO $ signShelleyTransaction' tx signingKeys
       putTransaction contractId transactionId applyTx
     case result of
       Left _ -> fail $ "Expected 200 response code - got " <> show result

marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/StandardContract.hs

@@ -22,7 +22,6 @@ import Language.Marlowe.Runtime.Transaction.Api (WalletAddresses (..))
 import Language.Marlowe.Runtime.Web (
   ApplyInputsTxEnvelope,
   BlockHeader,
-  CardanoTxBody,
   ContractOrSourceId (..),
   CreateTxEnvelope,
   PayoutHeader (..),
@@ -49,31 +48,31 @@ import Servant.Client.Streaming (ClientM)
 
 data StandardContractInit = StandardContractInit
   { makeInitialDeposit :: ClientM StandardContractFundsDeposited
-  , contractCreated :: CreateTxEnvelope CardanoTxBody
+  , contractCreated :: CreateTxEnvelope
   , createdBlock :: BlockHeader
   }
 
 data StandardContractFundsDeposited = StandardContractFundsDeposited
   { chooseGimmeTheMoney :: ClientM StandardContractChoiceMade
-  , initialFundsDeposited :: ApplyInputsTxEnvelope CardanoTxBody
+  , initialFundsDeposited :: ApplyInputsTxEnvelope
   , initialDepositBlock :: BlockHeader
   }
 
 data StandardContractChoiceMade = StandardContractChoiceMade
   { sendNotify :: ClientM StandardContractNotified
-  , gimmeTheMoneyChosen :: ApplyInputsTxEnvelope CardanoTxBody
+  , gimmeTheMoneyChosen :: ApplyInputsTxEnvelope
   , choiceBlock :: BlockHeader
   }
 
 data StandardContractNotified = StandardContractNotified
   { makeReturnDeposit :: ClientM StandardContractClosed
-  , notified :: ApplyInputsTxEnvelope CardanoTxBody
+  , notified :: ApplyInputsTxEnvelope
   , notifiedBlock :: BlockHeader
   }
 
 data StandardContractClosed = StandardContractClosed
-  { withdrawPartyAFunds :: ClientM (WithdrawTxEnvelope CardanoTxBody, BlockHeader)
-  , returnDeposited :: ApplyInputsTxEnvelope CardanoTxBody
+  { withdrawPartyAFunds :: ClientM (WithdrawTxEnvelope, BlockHeader)
+  , returnDeposited :: ApplyInputsTxEnvelope
   , returnDepositBlock :: BlockHeader
   }
 

marlowe-integration-tests/test/Language/Marlowe/Runtime/Web/Withdrawal/Put.hs

@@ -44,9 +44,9 @@ spec = describe "PUT /contracts/{contractId}/withdrawals/{withdrawalId}" do
       Page{..} <- getPayouts (Just $ Set.singleton contractId) Nothing (Just Available) Nothing
       let payouts = Set.fromList $ payoutId <$> items
 
-      Web.WithdrawTxEnvelope{withdrawalId, txEnvelope} <-
+      Web.WithdrawTxEnvelope{withdrawalId, tx} <-
         postWithdrawal webChangeAddress (Just webExtraAddresses) (Just webCollateralUtxos) Web.PostWithdrawalsRequest{..}
-      signedWithdrawalTx <- liftIO $ signShelleyTransaction' txEnvelope signingKeys
+      signedWithdrawalTx <- liftIO $ signShelleyTransaction' tx signingKeys
       putWithdrawal withdrawalId signedWithdrawalTx
 
     case result of