Implement PUT /contracts/:contractId/transactions/:transactionId

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

@@ -136,6 +136,7 @@ server = proc ServerDependencies{..} -> do
         , _createContract = createContract
         , _applyInputs = applyInputs
         , _submitContract = submitContract
+        , _submitTransaction = submitTransaction
         }
     , eventBackend
     , openAPIEnabled

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

@@ -16,6 +16,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Reader (MonadReader, ReaderT, asks)
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Coerce (coerce)
+import Language.Marlowe.Runtime.ChainSync.Api (TxId)
 import Language.Marlowe.Runtime.Core.Api (ContractId)
 import Language.Marlowe.Runtime.Web.Server.ContractHeaderIndexer (LoadContractHeaders)
 import Language.Marlowe.Runtime.Web.Server.HistoryClient (LoadContract, LoadTransaction, LoadTransactions)
@@ -55,6 +56,7 @@ data AppEnv r = AppEnv
   , _createContract :: CreateContract IO
   , _applyInputs :: ApplyInputs IO
   , _submitContract :: ContractId -> Submit r IO
+  , _submitTransaction :: ContractId -> TxId -> Submit r IO
   }
 
 -- | Load a list of contract headers.
@@ -98,3 +100,9 @@ submitContract :: ContractId -> Submit r (AppM r)
 submitContract contractId mods tx = do
   submit <- asks _submitContract
   liftIO $ submit contractId mods tx
+
+-- | Submit an apply inputs transaction to the node
+submitTransaction :: ContractId -> TxId -> Submit r (AppM r)
+submitTransaction contractId txId mods tx = do
+  submit <- asks _submitTransaction
+  liftIO $ submit contractId txId mods tx

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

@@ -9,7 +9,9 @@
 module Language.Marlowe.Runtime.Web.Server.REST.Transactions
   where
 
-import Cardano.Api (getTxId)
+import Cardano.Api (AsType(..), deserialiseFromTextEnvelope, getTxBody, getTxId)
+import qualified Cardano.Api.SerialiseTextEnvelope as Cardano
+import Control.Monad (unless)
 import Data.Foldable (traverse_)
 import Data.Maybe (fromMaybe)
 import qualified Data.Set as Set
@@ -22,11 +24,14 @@ import Language.Marlowe.Runtime.Transaction.Api
   , LoadMarloweContextError(..)
   , WalletAddresses(..)
   )
+import qualified Language.Marlowe.Runtime.Transaction.Api as Tx
 import Language.Marlowe.Runtime.Transaction.Constraints (ConstraintError(..))
-import Language.Marlowe.Runtime.Web
+import Language.Marlowe.Runtime.Web hiding (Unsigned)
 import Language.Marlowe.Runtime.Web.Server.DTO
 import Language.Marlowe.Runtime.Web.Server.HistoryClient (LoadTxError(..))
-import Language.Marlowe.Runtime.Web.Server.Monad (AppM, applyInputs, loadTransaction, loadTransactions)
+import Language.Marlowe.Runtime.Web.Server.Monad
+  (AppM, applyInputs, loadTransaction, loadTransactions, submitTransaction)
+import Language.Marlowe.Runtime.Web.Server.TxClient (TempTx(TempTx), TempTxStatus(..))
 import Observe.Event (EventBackend, addField, reference, withEvent)
 import Observe.Event.BackendModification (setAncestor)
 import Observe.Event.DSL (FieldSpec(..), SelectorSpec(..))
@@ -61,6 +66,12 @@ compile $ SelectorSpec "transactions"
       , ["get", "tx", "id"] ≔ ''TxId
       , ["get", "result"] ≔ ''Tx
       ]
+  , "put" ≔ FieldSpec "put"
+      [ ["put", "contract", "id"] ≔ ''TxOutRef
+      , ["put", "tx", "id"] ≔ ''TxId
+      , "body" ≔ ''Cardano.TextEnvelope
+      , "error" ≔ ''String
+      ]
   ]
 
 server
@@ -154,11 +165,19 @@ post eb contractId req@PostTransactionsRequest{..} changeAddressDTO mAddresses m
       pure $ IncludeLink (Proxy @"transaction") body
 
 transactionServer
+  :: EventBackend (AppM r) r TransactionsSelector
+  -> TxOutRef
+  -> TxId
+  -> ServerT TransactionAPI (AppM r)
+transactionServer eb contractId txId = getOne eb contractId txId
+                                  :<|> put eb contractId txId
+
+getOne
   :: EventBackend (AppM r) r TransactionsSelector
   -> TxOutRef
   -> TxId
   -> AppM r GetTransactionResponse
-transactionServer eb contractId txId = withEvent eb GetOne \ev -> do
+getOne eb contractId txId = withEvent eb GetOne \ev -> do
   addField ev $ GetOneContractId contractId
   addField ev $ GetTxId txId
   contractId' <- fromDTOThrow err400 contractId
@@ -171,3 +190,28 @@ transactionServer eb contractId txId = withEvent eb GetOne \ev -> do
       pure
         $ IncludeLink (Proxy @"previous")
         $ IncludeLink (Proxy @"next") contractState
+
+put
+  :: EventBackend (AppM r) r TransactionsSelector
+  -> TxOutRef
+  -> TxId
+  -> TextEnvelope
+  -> AppM r NoContent
+put eb contractId txId body = withEvent eb Put \ev -> do
+  addField ev $ PutContractId contractId
+  addField ev $ PutTxId txId
+  contractId' <- fromDTOThrow err400 contractId
+  txId' <- fromDTOThrow err400 txId
+  loadTransaction (setAncestor $ reference ev) contractId' txId' >>= \case
+    Nothing -> throwError err404
+    Just (Left (TempTx _ Unsigned Tx.InputsApplied{txBody})) -> do
+      textEnvelope <- fromDTOThrow err400 body
+      addField ev $ Body textEnvelope
+      tx <- either (const $ throwError err400) pure $ deserialiseFromTextEnvelope (AsTx AsBabbage) textEnvelope
+      unless (getTxBody tx == txBody) $ throwError err400
+      submitTransaction contractId' txId' (setAncestor $ reference ev) tx >>= \case
+        Nothing -> pure NoContent
+        Just err -> do
+          addField ev $ Error $ show err
+          throwError err403
+    Just _  -> throwError err409

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

@@ -14,6 +14,7 @@ import Control.Concurrent.Async (concurrently_)
 import Control.Concurrent.Component
 import Control.Concurrent.STM
   ( STM
+  , TVar
   , atomically
   , modifyTVar
   , newEmptyTMVar
@@ -103,6 +104,7 @@ data TxClient r = TxClient
   { createContract :: CreateContract IO
   , applyInputs :: ApplyInputs IO
   , submitContract :: ContractId -> Submit r IO
+  , submitTransaction :: ContractId -> TxId -> Submit r IO
   , lookupTempContract :: ContractId -> STM (Maybe (TempTx ContractCreated))
   , getTempContracts :: STM [TempTx ContractCreated]
   , lookupTempTransaction :: ContractId -> TxId -> STM (Maybe (TempTx InputsApplied))
@@ -111,14 +113,30 @@ data TxClient r = TxClient
 
 data SomeEventBackendModifiers r = forall r'. SomeEventBackendModifiers (EventBackendModifiers r r')
 
+-- Basically a lens to the actual map of temp txs to modify within a structure.
+-- For example, tempTransactions is a (Map ContractId (Map TxId (TempTx InputsApplie))),
+-- so to apply the given map modification to the inner map, we provide
+-- \update -> Map.update (Just . update txId) contractId
+type WithMapUpdate k tx a
+   = (k -> Map.Map k (TempTx tx) -> Map.Map k (TempTx tx)) -- ^ Takes a function that, given a key in a map, modifies a map of temp txs
+  -> (a -> a)                                              -- ^ And turns it into a function that modifies values of some type a
+
+-- Pack a TVar of a's with a lens for modifying some inner map in the TVar and
+-- existentialize the type parameters.
+data SomeTVarWithMapUpdate = forall k tx a. Ord k => SomeTVarWithMapUpdate (TVar a) (WithMapUpdate k tx a)
+
 txClient :: forall r. Component IO (TxClientDependencies r) (TxClient r)
 txClient = component \TxClientDependencies{..} -> do
   tempContracts <- newTVar mempty
   tempTransactions <- newTVar mempty
-  submitContractQueue <- newTQueue
+  submitQueue <- newTQueue
 
   let
-    runSubmitContract contractId tx sender (SomeEventBackendModifiers mods) = do
+    runSubmitGeneric
+      (SomeTVarWithMapUpdate tempVar updateTemp)
+      tx
+      sender
+      (SomeEventBackendModifiers mods) = do
       let
         eb = modifyEventBackend mods eventBackend
         cmd = Submit tx
@@ -128,18 +146,18 @@ txClient = component \TxClientDependencies{..} -> do
               addField ev $ show err
               atomically do
                 when report $ putTMVar sender $ Just err
-                modifyTVar tempContracts $ Map.update (Just . toUnsigned) contractId
+                modifyTVar tempVar $ updateTemp $ Map.update (Just . toUnsigned)
           , recvMsgSucceed = \_ -> withEvent eb SubmitSuccess \_ -> do
               atomically do
-                modifyTVar tempContracts $ Map.delete contractId
+                modifyTVar tempVar $ updateTemp Map.delete
                 when report $ putTMVar sender Nothing
           , recvMsgAwait = \status _ -> withEvent eb SubmitAwait \ev -> do
               addField ev $ show status
               report' <- case status of
                 Accepted -> do
                   when report $ atomically do
                     putTMVar sender Nothing
-                    modifyTVar tempContracts $ Map.update (Just . toSubmitted) contractId
+                    modifyTVar tempVar $ updateTemp $ Map.update (Just . toSubmitted)
                   pure False
                 _ -> pure report
               delay <- newDelay 1_000_000
@@ -148,9 +166,24 @@ txClient = component \TxClientDependencies{..} -> do
           }
       runTxJobClient client
 
+    genericSubmit
+      :: SomeTVarWithMapUpdate
+      -> EventBackendModifiers r r'
+      -> Tx BabbageEra
+      -> IO (Maybe SubmitError)
+    genericSubmit tVarWithUpdate mods tx =
+      withEvent (modifyEventBackend mods eventBackend) SubmitTx \ev -> do
+        sender <- atomically do
+          sender <- newEmptyTMVar
+          writeTQueue submitQueue (tVarWithUpdate, tx, sender, SomeEventBackendModifiers $ setAncestor (reference ev) <<< mods)
+          pure sender
+        atomically $ takeTMVar sender
+
     runTxClient = do
-      (contractId, tx, sender, mods) <- atomically $ readTQueue submitContractQueue
-      concurrently_ (try @SomeException $ runSubmitContract contractId tx sender mods) runTxClient
+      (tVarWithUpdate, tx, sender, mods) <- atomically $ readTQueue submitQueue
+      concurrently_
+        (try @SomeException $ runSubmitGeneric tVarWithUpdate tx sender mods)
+        runTxClient
 
   pure (runTxClient, TxClient
     { createContract = \stakeCredential version addresses roles metadata minUTxODeposit contract -> do
@@ -173,12 +206,8 @@ txClient = component \TxClientDependencies{..} -> do
             $ modifyTVar tempTransactions
             $ Map.alter (Just . maybe (Map.singleton txId tempTx) (Map.insert txId tempTx)) contractId
         pure response
-    , submitContract = \contractId mods tx -> withEvent (modifyEventBackend mods eventBackend) SubmitTx \ev -> do
-        sender <- atomically do
-          sender <- newEmptyTMVar
-          writeTQueue submitContractQueue (contractId, tx, sender, SomeEventBackendModifiers $ setAncestor (reference ev) <<< mods)
-          pure sender
-        atomically $ takeTMVar sender
+    , submitContract = \contractId -> genericSubmit $ SomeTVarWithMapUpdate tempContracts ($ contractId)
+    , submitTransaction = \contractId txId -> genericSubmit $ SomeTVarWithMapUpdate tempTransactions \update -> Map.update (Just . update txId) contractId
     , lookupTempContract = \contractId -> Map.lookup contractId <$> readTVar tempContracts
     , getTempContracts = fmap snd . Map.toAscList <$> readTVar tempContracts
     , lookupTempTransaction = \contractId txId -> (Map.lookup txId <=< Map.lookup contractId) <$> readTVar tempTransactions

marlowe-runtime/web/Language/Marlowe/Runtime/Web/API.hs

@@ -80,7 +80,7 @@ instance HasNamedLink CreateTxBody API "contract" where
 
 -- | /contracts/:contractId sup-API
 type ContractAPI = GetContractAPI
-              :<|> PutContractAPI
+              :<|> PutSignedTxAPI
               :<|> "transactions" :> TransactionsAPI
 
 -- | GET /contracts/:contractId sub-API
@@ -94,9 +94,6 @@ instance HasNamedLink ContractState API "transactions" where
     (Proxy @("contracts" :> Capture "contractId" TxOutRef :> "transactions" :> GetTransactionsAPI))
     contractId
 
--- | PUT /contracts/:contractId sub-API
-type PutContractAPI = ReqBody '[JSON] TextEnvelope :> PutAccepted '[JSON] NoContent
-
 -- | /contracts/:contractId/transactions sup-API
 type TransactionsAPI = GetTransactionsAPI
                   :<|> PostTransactionsAPI
@@ -140,12 +137,15 @@ instance HasNamedLink TxHeader API "transaction" where
 
 -- | /contracts/:contractId/transactions/:transactionId sup-API
 type TransactionAPI = GetTransactionAPI
+                 :<|> PutSignedTxAPI
 
 -- | GET /contracts/:contractId/transactions/:transactionId sub-API
 type GetTransactionAPI = Get '[JSON] GetTransactionResponse
 
 type GetTransactionResponse = WithLink "previous" (WithLink "next" Tx)
 
+type PutSignedTxAPI = ReqBody '[JSON] TextEnvelope :> PutAccepted '[JSON] NoContent
+
 instance HasNamedLink Tx API "previous" where
   namedLink _ _ Tx{..} = guard (inputUtxo /= contractId) $> safeLink
     api