Use CIP-30 friendly flow in /transactions as well

marlowe-runtime-web/marlowe-runtime-web.cabal

@@ -64,6 +64,7 @@ library
     , base16
     , bytestring
     , containers
+    , http-media
     , lens
     , marlowe-cardano
     , mtl
@@ -100,7 +101,12 @@ library server
     , aeson
     , async
     , async-components
+    , bytestring
     , cardano-api
+    , cardano-binary
+    , cardano-ledger-alonzo
+    , cardano-ledger-core
+    , cardano-ledger-shelley
     , containers
     , errors
     , eventuo11y ^>= { 0.9, 0.10 }

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/DTO.hs

@@ -552,7 +552,7 @@ instance
   , Ledger.Core.Script (ShelleyLedgerEra era) ~ Ledger.Alonzo.Scripts.Script (ShelleyLedgerEra era)
   ) => HasTextEnvelope (ShelleyTxWitness era) where
   textEnvelopeType _ = do
-    "ShelleyTxWitness:" <> case shelleyBasedEra :: ShelleyBasedEra era of
+    "ShelleyTxWitness " <> case shelleyBasedEra :: ShelleyBasedEra era of
        ShelleyBasedEraAlonzo -> "Alonzo"
        ShelleyBasedEraBabbage -> "Babbage"
 

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Contracts.hs

@@ -9,20 +9,9 @@
 module Language.Marlowe.Runtime.Web.Server.REST.Contracts
   where
 
-import Cardano.Api
-  ( BabbageEra
-  , ScriptValidity(ScriptInvalid, ScriptValid)
-  , TxBody
-  , TxScriptValidity(TxScriptValidity, TxScriptValidityNone)
-  , getTxBody
-  , makeSignedTransaction
-  )
+import Cardano.Api (BabbageEra, TxBody, getTxBody, makeSignedTransaction)
 import qualified Cardano.Api as Cardano
-import Cardano.Api.Shelley (Tx(ShelleyTx), TxBody(ShelleyTxBody))
-import Cardano.Ledger.Alonzo.Tx (ValidatedTx(ValidatedTx))
-import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
 import Cardano.Ledger.Alonzo.TxWitness (TxWitness(TxWitness))
-import Cardano.Ledger.BaseTypes (maybeToStrictMaybe)
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (Value(Null))
@@ -50,6 +39,7 @@ import qualified Language.Marlowe.Runtime.Web.Server.REST.ApiError as ApiError
 import qualified Language.Marlowe.Runtime.Web.Server.REST.Transactions as Transactions
 import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx(TempTx), TempTxStatus(Unsigned), TxClientSelector)
 import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx(TempTx), TempTxStatus(Unsigned))
+import Language.Marlowe.Runtime.Web.Server.Util (makeSignedTxWithWitnessKeys)
 import Observe.Event (Event, EventBackend, addField, reference, withEvent)
 import Observe.Event.Backend (narrowEventBackend)
 import Observe.Event.BackendModification (setAncestor)
@@ -87,8 +77,8 @@ compile $ SelectorSpec "contracts"
       , "addresses" ≔ ''Addresses
       , "collateral" ≔ ''TxOutRefs
       , ["post", "error"] ≔ ''String
-      , ["post", "response"] ≔ ''CreateTxBody
-      , ["post", "response", "create", "tx"] ≔ ''CreateTx
+      , ["post", "response", "txBody"] ≔ [t|CreateTxBody CardanoTxBody|]
+      , ["post", "response", "tx"] ≔ [t|CreateTxBody CardanoTx|]
       ]
   , ["get", "one"] ≔ FieldSpec ["get", "one"]
       [ ["get", "id"] ≔ ''TxOutRef
@@ -145,12 +135,12 @@ postCreateTxBodyResponse
   -> Address
   -> Maybe (CommaList Address)
   -> Maybe (CommaList TxOutRef)
-  -> AppM r PostContractsResponse
+  -> AppM r (PostContractsResponse CardanoTxBody)
 postCreateTxBodyResponse eb req changeAddressDTO mAddresses mCollateralUtxos = withEvent (hoistEventBackend liftIO eb) Post \ev -> do
   res <- postCreateTxBody ev req changeAddressDTO mAddresses mCollateralUtxos
   let (contractId', txBody') = toDTO res
   let body = CreateTxBody contractId' txBody'
-  addField ev $ PostResponse body
+  addField ev $ PostResponseTxBody body
   pure $ IncludeLink (Proxy @"contract") body
 
 postCreateTxResponse
@@ -159,13 +149,13 @@ postCreateTxResponse
   -> Address
   -> Maybe (CommaList Address)
   -> Maybe (CommaList TxOutRef)
-  -> AppM r PostContractsCreateTxResponse
+  -> AppM r (PostContractsResponse CardanoTx)
 postCreateTxResponse eb req changeAddressDTO mAddresses mCollateralUtxos = withEvent (hoistEventBackend liftIO eb) Post \ev -> do
   (contractId, txBody) <- postCreateTxBody ev req changeAddressDTO mAddresses mCollateralUtxos
   let tx = makeSignedTransaction [] txBody
   let (contractId', tx') = toDTO (contractId, tx)
-  let body = CreateTx contractId' tx'
-  addField ev $ PostResponseCreateTx body
+  let body = CreateTxBody contractId' tx'
+  addField ev $ PostResponseTx body
   pure $ IncludeLink (Proxy @"contract") body
 
 get
@@ -237,18 +227,23 @@ put eb contractId body = withEvent (hoistEventBackend liftIO eb) Put \ev -> do
 --       unless (getTxBody tx == txBody) $ throwError (badRequest' "Provided transaction body differs from the original one")
 --       submitContract contractId' (narrowEventBackend (injectSelector RunTx) $ setAncestorEventBackend (reference ev) eb) tx >>= \case
 -- =======
-      let
-        -- `<|>` gives me error here
-        req :: Maybe (Either (Cardano.Tx BabbageEra) (ShelleyTxWitness BabbageEra))
-        req = case fromDTO (Left body) of
-          Just res -> pure res
-          Nothing -> fromDTO (Right body)
+--       let
+--         -- `<|>` gives me error here
+--         req :: Maybe (Either (Cardano.Tx BabbageEra) (ShelleyTxWitness BabbageEra))
+--         req = case fromDTO (Left body) of
+--           Just res -> pure res
+--           Nothing -> fromDTO (Right body)
+-- =======
+      (req :: Maybe (Either (Cardano.Tx BabbageEra) (ShelleyTxWitness BabbageEra))) <- case teType body of
+        "Tx BabbageEra" -> pure $ Left <$> fromDTO body
+        "ShelleyTxWitness BabbageEra" -> pure $ Right <$> fromDTO body
+        _ -> throwError $ badRequest' "Unknown envelope type - allowed types are: \"Tx BabbageEra\", \"ShelleyTxWitness BabbageEra\""
 
       for_ (fromDTO body :: Maybe Cardano.TextEnvelope) \te ->
         addField ev $ Body te
 
       tx <- case req of
-        Nothing -> throwError $ badRequest' "Invalid body value"
+        Nothing -> throwError $ badRequest' "Invalid text envelope cbor value"
         Just (Left tx) -> do
           unless (getTxBody tx == txBody) $ throwError (badRequest' "Provided transaction body differs from the original one")
           pure tx
@@ -257,37 +252,10 @@ put eb contractId body = withEvent (hoistEventBackend liftIO eb) Put \ev -> do
         -- > Only the portions of the witness set that were signed as a result of this call are returned to
         -- > encourage dApps to verify the contents returned by this endpoint while building the final transaction.
         Just (Right (ShelleyTxWitness (TxWitness wtKeys _ _ _ _))) -> do
-          let
-            txScriptValidityToScriptValidity :: TxScriptValidity era -> ScriptValidity
-            txScriptValidityToScriptValidity TxScriptValidityNone = ScriptValid
-            txScriptValidityToScriptValidity (TxScriptValidity _ scriptValidity) = scriptValidity
-
-            scriptValidityToIsValid :: ScriptValidity -> Alonzo.IsValid
-            scriptValidityToIsValid ScriptInvalid = Alonzo.IsValid False
-            scriptValidityToIsValid ScriptValid = Alonzo.IsValid True
-
-            txScriptValidityToIsValid :: TxScriptValidity era -> Alonzo.IsValid
-            txScriptValidityToIsValid = scriptValidityToIsValid . txScriptValidityToScriptValidity
-
-            tx = case (txBody, makeSignedTransaction [] txBody) of
-              (ShelleyTxBody era txBody' _ _ txmetadata scriptValidity, ShelleyTx _ (ValidatedTx _ bkTxWitness _ _)) -> do
-                let
-                  TxWitness _ bkBoot bkScripts bkDats bkRdmrs = bkTxWitness
-                  wt' =
-                    TxWitness
-                      wtKeys
-                      bkBoot
-                      bkScripts
-                      bkDats
-                      bkRdmrs
-
-                ShelleyTx era $ ValidatedTx
-                  txBody'
-                  wt'
-                  (txScriptValidityToIsValid scriptValidity)
-                  (maybeToStrictMaybe txmetadata)
-          pure tx
-      submitContract contractId' (setAncestor $ reference ev) tx >>= \case
+          case makeSignedTxWithWitnessKeys txBody wtKeys of
+            Just tx -> pure tx
+            Nothing -> throwError $ badRequest' "Invalid witness keys"
+      submitContract contractId' (narrowEventBackend (injectSelector RunTx) $ setAncestorEventBackend (reference ev) eb) tx >>= \case
         Nothing -> pure NoContent
         Just err -> do
           addField ev $ Error $ show err

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/Transactions.hs

@@ -9,13 +9,15 @@
 module Language.Marlowe.Runtime.Web.Server.REST.Transactions
   where
 
-import Cardano.Api (AsType(..), deserialiseFromTextEnvelope, getTxBody, getTxId)
-import qualified Cardano.Api.SerialiseTextEnvelope as Cardano
+import Cardano.Api (BabbageEra, TxBody, getTxBody, getTxId, makeSignedTransaction)
+import qualified Cardano.Api as Cardano
+import Cardano.Ledger.Alonzo.TxWitness (TxWitness(TxWitness))
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (Value(Null))
 import Data.Foldable (traverse_)
 import qualified Data.Map as Map
+import Data.Foldable (for_, traverse_)
 import Data.Maybe (fromMaybe)
 import qualified Data.Set as Set
 import Language.Marlowe.Protocol.Query.Types (Page(..))
@@ -45,6 +47,11 @@ import Observe.Event.Explicit
   , setAncestorEventBackend
   , withEvent
   )
+import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx(TempTx), TempTxStatus(..))
+import Language.Marlowe.Runtime.Web.Server.Util (makeSignedTxWithWitnessKeys)
+import Observe.Event (Event, EventBackend, addField, reference, withEvent)
+import Observe.Event.BackendModification (setAncestor)
+import Observe.Event.DSL (FieldSpec(..), SelectorSpec(..))
 import Observe.Event.Render.JSON.DSL.Compile (compile)
 import Observe.Event.Syntax ((≔))
 import Servant
@@ -69,7 +76,8 @@ compile $ SelectorSpec "transactions"
       , "addresses" ≔ ''Addresses
       , "collateral" ≔ ''TxOutRefs
       , ["post", "error"] ≔ ''String
-      , ["post", "response"] ≔ ''ApplyInputsTxBody
+      , ["post", "response", "txBody"] ≔ [t|ApplyInputsTxBody CardanoTxBody|]
+      , ["post", "response", "tx"] ≔ [t|ApplyInputsTxBody CardanoTx|]
       ]
   , ["get", "one"] ≔ FieldSpec ["get", "one"]
       [ ["get", "one", "contract", "id"] ≔ ''TxOutRef
@@ -90,7 +98,7 @@ server
   -> TxOutRef
   -> ServerT TransactionsAPI (AppM r)
 server eb contractId = get eb contractId
-                  :<|> post eb contractId
+                  :<|> (postCreateTxBodyResponse eb contractId :<|> postCreateTxResponse eb contractId)
                   :<|> transactionServer eb contractId
 
 get
@@ -117,15 +125,15 @@ get eb contractId ranges = withEvent (hoistEventBackend liftIO eb) Get \ev -> do
       addField ev $ TxHeaders headers'
       addHeader totalCount . fmap ListObject <$> returnRange range (IncludeLink (Proxy @"transaction") <$> headers')
 
-post
-  :: EventBackend IO r TransactionsSelector
+postCreateTxBody
+  :: Event (AppM r) r' s PostField
   -> TxOutRef
   -> PostTransactionsRequest
   -> Address
   -> Maybe (CommaList Address)
   -> Maybe (CommaList TxOutRef)
-  -> AppM r PostTransactionsResponse
-post eb contractId req@PostTransactionsRequest{..} changeAddressDTO mAddresses mCollateralUtxos = withEvent (hoistEventBackend liftIO eb) Post \ev -> do
+  -> AppM r (TxBody BabbageEra)
+postCreateTxBody ev contractId req@PostTransactionsRequest{..} changeAddressDTO mAddresses mCollateralUtxos = do
   addField ev $ NewContract req
   addField ev $ ChangeAddress changeAddressDTO
   traverse_ (addField ev . Addresses) mAddresses
@@ -144,11 +152,41 @@ post eb contractId req@PostTransactionsRequest{..} changeAddressDTO mAddresses m
       addField ev $ PostError $ show err
       throwDTOError err
     Right InputsApplied{txBody} -> do
-      let txBody' = toDTO txBody
-      let txId = toDTO $ fromCardanoTxId $ getTxId txBody
-      let body = ApplyInputsTxBody contractId txId txBody'
-      addField ev $ PostResponse body
-      pure $ IncludeLink (Proxy @"transaction") body
+      pure txBody
+
+postCreateTxBodyResponse
+  :: EventBackend IO r TransactionsSelector
+  -> TxOutRef
+  -> PostTransactionsRequest
+  -> Address
+  -> Maybe (CommaList Address)
+  -> Maybe (CommaList TxOutRef)
+  -> AppM r (PostTransactionsResponse CardanoTxBody)
+postCreateTxBodyResponse eb contractId req changeAddressDTO mAddresses mCollateralUtxos = withEvent eb Post \ev -> do
+  txBody <- postCreateTxBody ev contractId req changeAddressDTO mAddresses mCollateralUtxos
+  let txBody' = toDTO txBody
+  let txId = toDTO $ fromCardanoTxId $ getTxId txBody
+  let body = ApplyInputsTxBody contractId txId txBody'
+  addField ev $ PostResponseTxBody body
+  pure $ IncludeLink (Proxy @"transaction") body
+
+postCreateTxResponse
+  :: EventBackend IO r TransactionsSelector
+  -> TxOutRef
+  -> PostTransactionsRequest
+  -> Address
+  -> Maybe (CommaList Address)
+  -> Maybe (CommaList TxOutRef)
+  -> AppM r (PostTransactionsResponse CardanoTx)
+postCreateTxResponse eb contractId req changeAddressDTO mAddresses mCollateralUtxos = withEvent eb Post \ev -> do
+  txBody <- postCreateTxBody ev contractId req changeAddressDTO mAddresses mCollateralUtxos
+  let txId = toDTO $ fromCardanoTxId $ getTxId txBody
+  let tx = makeSignedTransaction [] txBody
+  let tx' = toDTO tx
+  let body = ApplyInputsTxBody contractId txId tx'
+  addField ev $ PostResponseTx body
+  pure $ IncludeLink (Proxy @"transaction") body
+
 
 transactionServer
   :: EventBackend IO r TransactionsSelector
@@ -191,10 +229,23 @@ put eb contractId txId body = withEvent (hoistEventBackend liftIO eb) Put \ev ->
   loadTransaction contractId' txId' >>= \case
     Nothing -> throwError $ notFound' "Transaction not found"
     Just (Left (TempTx _ Unsigned Tx.InputsApplied{txBody})) -> do
-      textEnvelope <- fromDTOThrow (badRequest' "Invalid body value") body
-      addField ev $ Body textEnvelope
-      tx <- either (const $ throwError $ badRequest' "Invalid body text envelope content") pure $ deserialiseFromTextEnvelope (AsTx AsBabbage) textEnvelope
-      unless (getTxBody tx == txBody) $ throwError (badRequest' "Provided transaction body differs from the original one")
+      (req :: Maybe (Either (Cardano.Tx BabbageEra) (ShelleyTxWitness BabbageEra))) <- case teType body of
+        "Tx BabbageEra" -> pure $ Left <$> fromDTO body
+        "ShelleyTxWitness BabbageEra" -> pure $ Right <$> fromDTO body
+        _ -> throwError $ badRequest' "Unknown envelope type - allowed types are: \"Tx BabbageEra\", \"ShelleyTxWitness BabbageEra\""
+
+      for_ (fromDTO body :: Maybe Cardano.TextEnvelope) \te ->
+        addField ev $ Body te
+
+      tx <- case req of
+        Nothing -> throwError $ badRequest' "Invalid text envelope cbor value"
+        Just (Left tx) -> do
+          unless (getTxBody tx == txBody) $ throwError (badRequest' "Provided transaction body differs from the original one")
+          pure tx
+        Just (Right (ShelleyTxWitness (TxWitness wtKeys _ _ _ _))) -> do
+          case makeSignedTxWithWitnessKeys txBody wtKeys of
+            Just tx -> pure tx
+            Nothing -> throwError $ badRequest' "Invalid witness keys"
       submitTransaction contractId' txId' (narrowEventBackend (injectSelector RunTx) $ setAncestorEventBackend (reference ev) eb) tx >>= \case
         Nothing -> pure NoContent
         Just err -> do

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/Util.hs

@@ -1,9 +1,29 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 module Language.Marlowe.Runtime.Web.Server.Util
   where
 
 import Data.Function (on)
 import qualified Data.List as List
-import Servant.Pagination (RangeOrder(..))
+
+import Cardano.Api
+  ( ScriptValidity(ScriptInvalid, ScriptValid)
+  , TxScriptValidity(TxScriptValidity, TxScriptValidityNone)
+  , makeSignedTransaction
+  )
+import Cardano.Api.Shelley (ShelleyLedgerEra, Tx(ShelleyTx), TxBody(ShelleyTxBody))
+import qualified Cardano.Ledger.Alonzo.Scripts
+import Cardano.Ledger.Alonzo.Tx (ValidatedTx(ValidatedTx))
+import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
+import Cardano.Ledger.Alonzo.TxWitness (TxWitness(TxWitness))
+import Cardano.Ledger.BaseTypes (maybeToStrictMaybe)
+import qualified Cardano.Ledger.Core
+import Cardano.Ledger.Era (Era(Crypto))
+import Cardano.Ledger.Keys (KeyRole(Witness))
+import Cardano.Ledger.Shelley.TxBody (WitVKey)
+import Data.Set (Set)
+import Servant.Pagination
 
 applyRangeToAscList :: Eq f => (a -> f) -> Maybe f -> Int -> Int -> RangeOrder -> [a] -> Maybe [a]
 applyRangeToAscList getField startFrom limit offset order =
@@ -19,3 +39,41 @@ applyRangeToAscList getField startFrom limit offset order =
         RangeDesc -> reverse
         RangeAsc -> id
     . List.nubBy (on (==) getField)
+
+type WitVKeys era = Set (WitVKey 'Witness (Crypto (ShelleyLedgerEra era)))
+
+makeSignedTxWithWitnessKeys ::
+  ( ShelleyLedgerEra era ~ shelleyLedgerEra
+  , Cardano.Ledger.Era.Era shelleyLedgerEra
+  , Cardano.Ledger.Core.Tx shelleyLedgerEra ~ ValidatedTx shelleyLedgerEra
+  , Cardano.Ledger.Core.Script shelleyLedgerEra ~ Cardano.Ledger.Alonzo.Scripts.Script shelleyLedgerEra
+  ) => TxBody era
+    -> WitVKeys era
+    -> Maybe (Tx era)
+makeSignedTxWithWitnessKeys txBody wtKeys = do
+  let
+    txScriptValidityToIsValid :: TxScriptValidity era -> Alonzo.IsValid
+    txScriptValidityToIsValid TxScriptValidityNone = Alonzo.IsValid True
+    txScriptValidityToIsValid (TxScriptValidity _ scriptValidity) = case scriptValidity of
+      ScriptValid -> Alonzo.IsValid True
+      ScriptInvalid -> Alonzo.IsValid False
+
+  case (txBody, makeSignedTransaction [] txBody) of
+    (ShelleyTxBody era txBody' _ _ txmetadata scriptValidity, ShelleyTx _ (ValidatedTx _ bkTxWitness _ _)) -> do
+      let
+        TxWitness _ bkBoot bkScripts bkDats bkRdmrs = bkTxWitness
+        wt' =
+          TxWitness
+            wtKeys
+            bkBoot
+            bkScripts
+            bkDats
+            bkRdmrs
+
+      Just $ ShelleyTx era $ ValidatedTx
+        txBody'
+        wt'
+        (txScriptValidityToIsValid scriptValidity)
+        (maybeToStrictMaybe txmetadata)
+    _ -> Nothing
+