Add unsigned contracts to GET responses

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

@@ -114,17 +114,19 @@ newtype Server = Server
 
 mkServer :: ServerDependencies r -> STM Server
 mkServer ServerDependencies{..} = do
+  TxClient{..} <- mkTxClient TxClientDependencies
+    { runTxJobClient
+    }
   ContractHeaderIndexer{..} <- mkContractHeaderIndexer ContractHeaderIndexerDependencies
     { runMarloweHeaderSyncClient
+    , getTempContracts
     , eventBackend = narrowEventBackend ContractIndexer eventBackend
     }
   HistoryClient{..} <- mkHistoryClient HistoryClientDependencies
     { runMarloweSyncClient
+    , lookupTempContract
     , eventBackend = narrowEventBackend History eventBackend
     }
-  TxClient{..} <- mkTxClient TxClientDependencies
-    { runTxJobClient
-    }
   let
     env = AppEnv
       { _loadContractHeaders = loadContractHeaders

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

@@ -24,8 +24,10 @@ import Language.Marlowe.Protocol.HeaderSync.Client
 import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain
 import Language.Marlowe.Runtime.Core.Api (ContractId)
 import Language.Marlowe.Runtime.Discovery.Api
+import qualified Language.Marlowe.Runtime.Transaction.Api as Tx
 import qualified Language.Marlowe.Runtime.Web as Web
 import Language.Marlowe.Runtime.Web.Server.DTO (toDTO)
+import Language.Marlowe.Runtime.Web.Server.TxClient
 import Language.Marlowe.Runtime.Web.Server.Util (applyRangeToAscList)
 import Network.Protocol.Driver (RunClient)
 import Observe.Event (EventBackend, addField, withEvent)
@@ -55,6 +57,7 @@ compile $ SelectorSpec ["contract", "header", "indexer"]
 -- | Dependencies for the a ContractHeaderIndexer
 data ContractHeaderIndexerDependencies r = ContractHeaderIndexerDependencies
   { runMarloweHeaderSyncClient :: RunClient IO MarloweHeaderSyncClient
+  , getTempContracts :: STM [TempContract]
   , eventBackend :: EventBackend IO r ContractHeaderIndexerSelector
   }
 
@@ -64,7 +67,7 @@ type LoadContractHeaders m
   -> Int -- ^ Limit: the maximum number of contract headers to load.
   -> Int -- ^ Offset: how many contract headers after the initial one to skip.
   -> RangeOrder -- ^ Whether to load an ascending or descending list.
-  -> m (Maybe [ContractHeader]) -- ^ Nothing if the initial ID is not found
+  -> m (Maybe [Either TempContract ContractHeader]) -- ^ Nothing if the initial ID is not found
 
 -- | Public API of the ContractHeaderIndexer
 data ContractHeaderIndexer = ContractHeaderIndexer
@@ -126,9 +129,15 @@ mkContractHeaderIndexer ContractHeaderIndexerDependencies{..} = do
         -- Wait until we are in sync.
         readTMVar inSync
         contracts <- readTVar contractsTVar
+        let contractsList = fmap snd . Map.toAscList . snd =<< IntMap.toAscList contracts
+        let
+          getContractId = \case
+            Left (Created Tx.ContractCreationRecord{..}) -> contractId
+            Right ContractHeader{..} -> contractId
+        tempContracts <- getTempContracts
         pure
-          $ applyRangeToAscList contractId startFrom limit offset order
-          $ fmap snd . Map.toAscList . snd =<< IntMap.toAscList contracts
+          $ applyRangeToAscList getContractId startFrom limit offset order
+          $ (Right <$> contractsList) <> (Left <$> tempContracts)
     }
 
 -- Updates the state of the indexer to exclude values after a particular chain point.

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

@@ -9,8 +9,6 @@
 module Language.Marlowe.Runtime.Web.Server.DTO
   where
 
-import Language.Marlowe.Runtime.Discovery.Api
-
 import Cardano.Api
   ( AsType(AsTxBody)
   , IsCardanoEra(cardanoEra)
@@ -49,10 +47,12 @@ import Language.Marlowe.Runtime.Core.Api
   , TransactionOutput(..)
   , TransactionScriptOutput(..)
   )
+import qualified Language.Marlowe.Runtime.Discovery.Api as Discovery
 import Language.Marlowe.Runtime.History.Api (CreateStep(..))
 import Language.Marlowe.Runtime.Plutus.V2.Api (fromPlutusCurrencySymbol)
-import Language.Marlowe.Runtime.Transaction.Api (Mint(..), NFTMetadata, RoleTokensConfig(..), mkMint, mkNFTMetadata)
+import qualified Language.Marlowe.Runtime.Transaction.Api as Tx
 import qualified Language.Marlowe.Runtime.Web as Web
+import Language.Marlowe.Runtime.Web.Server.TxClient (TempContract(..))
 
 -- | A class that states a type has a DTO representation.
 class HasDTO a where
@@ -97,6 +97,15 @@ instance (FromDTO a, FromDTO b) => FromDTO (a, b) where
 instance (ToDTO a, ToDTO b) => ToDTO (a, b) where
   toDTO (a, b) = (toDTO a, toDTO b)
 
+instance HasDTO (Either a b) where
+  type DTO (Either a b) = Either (DTO a) (DTO b)
+
+instance (FromDTO a, FromDTO b) => FromDTO (Either a b) where
+  fromDTO = either (fmap Left . fromDTO) (fmap Right . fromDTO)
+
+instance (ToDTO a, ToDTO b) => ToDTO (Either a b) where
+  toDTO = either (Left . toDTO) (Right . toDTO)
+
 instance HasDTO (Maybe a) where
   type DTO (Maybe a) = Maybe (DTO a)
 
@@ -106,11 +115,11 @@ instance ToDTO a => ToDTO (Maybe a) where
 instance FromDTO a => FromDTO (Maybe a) where
   fromDTO = traverse fromDTO
 
-instance HasDTO ContractHeader where
-  type DTO ContractHeader = Web.ContractHeader
+instance HasDTO Discovery.ContractHeader where
+  type DTO Discovery.ContractHeader = Web.ContractHeader
 
-instance ToDTO ContractHeader where
-  toDTO ContractHeader{..} = Web.ContractHeader
+instance ToDTO Discovery.ContractHeader where
+  toDTO Discovery.ContractHeader{..} = Web.ContractHeader
     { contractId = toDTO contractId
     , roleTokenMintingPolicyId = toDTO rolesCurrency
     , version = toDTO marloweVersion
@@ -255,8 +264,39 @@ instance ToDTO ContractRecord where
       , currentContract = maybe Sem.Close (Sem.marloweContract . datum) output
       , state = Sem.marloweState . datum <$> output
       , utxo = toDTO . utxo <$> output
+      , txBody = Nothing
       }
 
+instance HasDTO (Tx.ContractCreationRecord era v) where
+  type DTO (Tx.ContractCreationRecord era v) = Web.ContractState
+
+instance IsCardanoEra era => ToDTO (Tx.ContractCreationRecord era v) where
+  toDTO Tx.ContractCreationRecord{..} =
+    Web.ContractState
+      { contractId = toDTO contractId
+      , roleTokenMintingPolicyId = toDTO rolesCurrency
+      , version = case version of
+          MarloweV1 -> Web.V1
+      , metadata = toDTO metadata
+      , status = Web.Unsigned
+      , block = Nothing
+      , initialContract = case version of
+          MarloweV1 -> Sem.marloweContract datum
+      , currentContract = case version of
+          MarloweV1 -> Sem.marloweContract datum
+      , state = case version of
+          MarloweV1 -> Just $ Sem.marloweState datum
+      , utxo = Nothing
+      , txBody = Just $ toDTO txBody
+      }
+
+instance HasDTO TempContract where
+  type DTO TempContract = Web.ContractState
+
+instance ToDTO TempContract where
+  toDTO = \case
+    Created contract -> toDTO contract
+
 instance HasDTO SomeTransaction where
   type DTO SomeTransaction = Web.TxHeader
 
@@ -315,20 +355,20 @@ instance FromDTO TextEnvelope where
       , teRawCBOR = Web.unBase16 teCborHex
       }
 
-instance HasDTO RoleTokensConfig where
-  type DTO RoleTokensConfig = Maybe Web.RolesConfig
+instance HasDTO Tx.RoleTokensConfig where
+  type DTO Tx.RoleTokensConfig = Maybe Web.RolesConfig
 
-instance FromDTO RoleTokensConfig where
+instance FromDTO Tx.RoleTokensConfig where
   fromDTO = \case
-    Nothing -> pure RoleTokensNone
-    Just (Web.UsePolicy policy) -> RoleTokensUsePolicy <$> fromDTO policy
-    Just (Web.Mint mint) -> RoleTokensMint <$> fromDTO mint
+    Nothing -> pure Tx.RoleTokensNone
+    Just (Web.UsePolicy policy) -> Tx.RoleTokensUsePolicy <$> fromDTO policy
+    Just (Web.Mint mint) -> Tx.RoleTokensMint <$> fromDTO mint
 
-instance HasDTO Mint where
-  type DTO Mint = Map Text Web.RoleTokenConfig
+instance HasDTO Tx.Mint where
+  type DTO Tx.Mint = Map Text Web.RoleTokenConfig
 
-instance FromDTO Mint where
-  fromDTO = fmap mkMint
+instance FromDTO Tx.Mint where
+  fromDTO = fmap Tx.mkMint
     . traverse (sequence . bimap tokenNameToText convertConfig)
     <=< toNonEmpty
     . Map.toList
@@ -339,11 +379,11 @@ instance FromDTO Mint where
           <$> fromDTO address
           <*> fromDTO metadata
 
-instance HasDTO NFTMetadata where
-  type DTO NFTMetadata = Web.TokenMetadata
+instance HasDTO Tx.NFTMetadata where
+  type DTO Tx.NFTMetadata = Web.TokenMetadata
 
-instance FromDTO NFTMetadata where
-  fromDTO = mkNFTMetadata <=< Chain.fromJSONEncodedMetadata . toJSON
+instance FromDTO Tx.NFTMetadata where
+  fromDTO = Tx.mkNFTMetadata <=< Chain.fromJSONEncodedMetadata . toJSON
 
 tokenNameToText :: Text -> Chain.TokenName
 tokenNameToText = Chain.TokenName . fromString . T.unpack

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

@@ -6,7 +6,7 @@
 module Language.Marlowe.Runtime.Web.Server.HistoryClient
   where
 
-import Control.Concurrent.STM (STM)
+import Control.Concurrent.STM (STM, atomically)
 import Control.Error (note)
 import Data.List (sortOn)
 import Data.Maybe (isNothing, listToMaybe, mapMaybe)
@@ -18,6 +18,7 @@ import Language.Marlowe.Runtime.Core.Api
   (ContractId, MarloweVersion, Transaction(..), TransactionOutput(..), TransactionScriptOutput)
 import Language.Marlowe.Runtime.History.Api (ContractStep(..), CreateStep(..))
 import Language.Marlowe.Runtime.Web.Server.DTO (ContractRecord(..), SomeTransaction(..))
+import Language.Marlowe.Runtime.Web.Server.TxClient (TempContract)
 import Language.Marlowe.Runtime.Web.Server.Util (applyRangeToAscList)
 import Observe.Event (EventBackend, addField, withEvent)
 import Observe.Event.BackendModification (EventBackendModifiers, modifyEventBackend)
@@ -43,6 +44,7 @@ compile $ SelectorSpec ["history", "client"]
 
 data HistoryClientDependencies r = HistoryClientDependencies
   { runMarloweSyncClient :: forall a. MarloweSyncClient IO a -> IO a
+  , lookupTempContract :: ContractId -> STM (Maybe TempContract)
   , eventBackend :: EventBackend IO r HistoryClientSelector
   }
 
@@ -51,7 +53,7 @@ type LoadContract r m
    = forall r'
    . EventBackendModifiers r r'
   -> ContractId               -- ^ ID of the contract to load
-  -> m (Maybe ContractRecord) -- ^ Nothing if the ID is not found
+  -> m (Maybe (Either TempContract ContractRecord)) -- ^ Nothing if the ID is not found
 
 data LoadContractHeadersError
   = ContractNotFound
@@ -76,8 +78,11 @@ data HistoryClient r = HistoryClient
 
 mkHistoryClient :: HistoryClientDependencies r -> STM (HistoryClient r)
 mkHistoryClient HistoryClientDependencies{..} = pure HistoryClient
-  { loadContract = \mods ->
-      runMarloweSyncClient . loadContractClient (modifyEventBackend mods eventBackend)
+  { loadContract = \mods contractId -> do
+      result <- runMarloweSyncClient $ loadContractClient (modifyEventBackend mods eventBackend) contractId
+      case result of
+        Nothing -> atomically $ fmap Left <$> lookupTempContract contractId
+        Just contract -> pure $ Just $ Right contract
   , loadTransactions = \mods contractId startFrom limit offset order ->
       (note InitialTransactionNotFound . applyRangeToAscList transactionId' startFrom limit offset order =<<)
         <$> runMarloweSyncClient (loadTransactionsClient (modifyEventBackend mods eventBackend) contractId)

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

@@ -15,7 +15,12 @@ import qualified Data.Set as Set
 import Language.Marlowe.Runtime.ChainSync.Api (Lovelace(..))
 import Language.Marlowe.Runtime.Core.Api (MarloweVersion(..), SomeMarloweVersion(..))
 import Language.Marlowe.Runtime.Transaction.Api
-  (CreateBuildupError(..), CreateError(..), LoadMarloweContextError(..), WalletAddresses(..))
+  ( ContractCreationRecord(..)
+  , CreateBuildupError(..)
+  , CreateError(..)
+  , LoadMarloweContextError(..)
+  , WalletAddresses(..)
+  )
 import Language.Marlowe.Runtime.Transaction.Constraints (ConstraintError(..))
 import Language.Marlowe.Runtime.Web
 import Language.Marlowe.Runtime.Web.Server.DTO
@@ -105,7 +110,7 @@ post eb req@PostContractsRequest{..} changeAddressDTO mAddresses mCollateralUtxo
         CreateBuildupFailed (AddressDecodingFailed _) -> throwError err500
         CreateBuildupFailed (MintingScriptDecodingFailed _) -> throwError err500
         CreateToCardanoError -> throwError err400
-    Right (contractId, txBody) -> do
+    Right ContractCreationRecord{contractId, txBody} -> do
       let (contractId', txBody') = toDTO (contractId, txBody)
       let body = CreateTxBody contractId' txBody'
       addField ev $ PostResponse body
@@ -127,11 +132,14 @@ get eb ranges = withEvent eb Get \ev -> do
   loadContractHeaders startFrom rangeLimit rangeOffset rangeOrder >>= \case
     Nothing -> throwError err416
     Just headers -> do
-      let headers' = toDTO headers
+      let headers' = either toContractHeader id <$> toDTO headers
       addField ev $ ContractHeaders headers'
       let response = IncludeLink (Proxy @"contract") <$> headers'
       addHeader (length headers) <$> returnRange range response
 
+toContractHeader :: ContractState -> ContractHeader
+toContractHeader ContractState{..} = ContractHeader{..}
+
 contractServer
   :: EventBackend (AppM r) r ContractsSelector
   -> TxOutRef
@@ -148,7 +156,9 @@ getOne eb contractId = withEvent eb GetOne \ev -> do
   contractId' <- fromDTOThrow err400 contractId
   loadContract (setAncestor $ reference ev) contractId' >>= \case
     Nothing -> throwError err404
-    Just contractRecord -> do
-      let contractState = toDTO contractRecord
+    Just result -> do
+      let contractState = either toDTO toDTO result
       addField ev $ GetResult contractState
-      pure $ IncludeLink (Proxy @"transactions") contractState
+      pure case result of
+        Left _ -> OmitLink contractState
+        Right _ -> IncludeLink (Proxy @"transactions") contractState

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

@@ -1,12 +1,16 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 module Language.Marlowe.Runtime.Web.Server.TxClient
   where
 
-import Cardano.Api (BabbageEra, TxBody)
-import Control.Concurrent.STM (STM)
+import Cardano.Api (BabbageEra)
+import Control.Concurrent.STM (STM, atomically, modifyTVar, newTVar, readTVar)
+import Data.Foldable (for_)
+import qualified Data.Map as Map
 import Language.Marlowe.Runtime.ChainSync.Api (Lovelace, StakeCredential, TransactionMetadata)
 import Language.Marlowe.Runtime.Core.Api (Contract, ContractId, MarloweVersion)
-import Language.Marlowe.Runtime.Transaction.Api (CreateError, MarloweTxCommand(..), RoleTokensConfig, WalletAddresses)
+import Language.Marlowe.Runtime.Transaction.Api
+  (ContractCreationRecord(..), CreateError, MarloweTxCommand(..), RoleTokensConfig, WalletAddresses)
 import Network.Protocol.Driver (RunClient)
 import Network.Protocol.Job.Client
 
@@ -23,17 +27,31 @@ type CreateContract m
   -> TransactionMetadata
   -> Lovelace
   -> Contract v
-  -> m (Either (CreateError v) (ContractId, TxBody BabbageEra))
+  -> m (Either (CreateError v) (ContractCreationRecord BabbageEra v))
+
+data TempContract where
+  Created :: ContractCreationRecord BabbageEra v -> TempContract
 
 -- | Public API of the TxClient
-newtype TxClient = TxClient
+data TxClient = TxClient
   { createContract :: CreateContract IO -- ^ Load contract headers from the indexer.
+  , lookupTempContract :: ContractId -> STM (Maybe TempContract) -- ^ Lookup contract headers that have been built or are being submitted
+  , getTempContracts :: STM [TempContract]
   }
 
 mkTxClient :: TxClientDependencies -> STM TxClient
-mkTxClient TxClientDependencies{..} = pure TxClient
-  { createContract = \stakeCredential version addresses roles metadata minUTxODeposit contract ->
-      runTxJobClient
-        $ liftCommand
-        $ Create stakeCredential version addresses roles metadata minUTxODeposit contract
-  }
+mkTxClient TxClientDependencies{..} = do
+  tempContracts <- newTVar mempty
+  pure TxClient
+    { createContract = \stakeCredential version addresses roles metadata minUTxODeposit contract -> do
+        response <- runTxJobClient
+          $ liftCommand
+          $ Create stakeCredential version addresses roles metadata minUTxODeposit contract
+        for_ response \creation -> atomically
+          $ modifyTVar tempContracts
+          $ Map.insert (contractId creation)
+          $ Created creation
+        pure response
+    , lookupTempContract = \contractId -> Map.lookup contractId <$> readTVar tempContracts
+    , getTempContracts = fmap snd . Map.toAscList <$> readTVar tempContracts
+    }

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

@@ -219,6 +219,7 @@ data ContractState = ContractState
   , currentContract :: Semantics.Contract
   , state :: Maybe Semantics.State
   , utxo :: Maybe TxOutRef
+  , txBody :: Maybe TextEnvelope
   } deriving (Show, Eq, Generic)
 
 instance ToJSON ContractState