Attempt to auto-merkleize inputs passed to Apply

marlowe-integration/src/Test/Integration/Marlowe/Local.hs

@@ -614,6 +614,7 @@ runtime = proc RuntimeDependencies{..} -> do
     in
       TransactionDependencies
         { chainSyncConnector = SomeConnectorTraced inject $ clientConnector chainSyncPair
+        , contractQueryConnector = SomeConnectorTraced inject $ clientConnector contractQueryPair
         , connectionSource = SomeConnectionSourceTraced inject $ Connection.connectionSource txJobPair
         , ..
         }

marlowe-runtime/marlowe-runtime.cabal

@@ -386,6 +386,7 @@ library tx
     , marlowe-chain-sync:plutus-compat ==0.0.1
     , marlowe-protocols ==0.1.0.0
     , marlowe-runtime ==0.0.1
+    , marlowe-runtime:contract-api ==0.0.1
     , marlowe-runtime:history-api ==0.0.1
     , marlowe-runtime:plutus-scripts ==0.0.1
     , marlowe-runtime:tx-api ==0.0.1
@@ -568,6 +569,7 @@ executable marlowe-tx
     , marlowe-chain-sync ==0.0.1
     , marlowe-protocols ==0.1.0.0
     , marlowe-runtime ==0.0.1
+    , marlowe-runtime:contract-api ==0.0.1
     , marlowe-runtime:tx ==0.0.1
     , marlowe-runtime:tx-api ==0.0.1
     , network >= 3.1 && < 4

marlowe-runtime/marlowe-tx/Logging.hs

@@ -14,6 +14,7 @@ import qualified Data.Set as Set
 import Data.String (fromString)
 import Language.Marlowe.Runtime.ChainSync.Api
   (ChainSyncCommand, ChainSyncQuery, RuntimeChainSeek, UTxOs(unUTxOs), renderTxOutRef, toBech32, unInterpreter)
+import Language.Marlowe.Runtime.Contract.Api (ContractRequest)
 import Language.Marlowe.Runtime.Core.Api (MarloweVersion(..), renderContractId)
 import Language.Marlowe.Runtime.Core.ScriptRegistry (ReferenceScriptUtxo(..))
 import Language.Marlowe.Runtime.Transaction.Api (MarloweTxCommand)
@@ -34,6 +35,7 @@ data RootSelector f where
   ChainSeekClient :: TcpClientSelector (Handshake RuntimeChainSeek) f -> RootSelector f
   ChainSyncJobClient :: TcpClientSelector (Handshake (Job ChainSyncCommand)) f -> RootSelector f
   ChainSyncQueryClient :: TcpClientSelector (Handshake (Query ChainSyncQuery)) f -> RootSelector f
+  ContractQueryClient :: TcpClientSelector (Handshake (Query ContractRequest)) f -> RootSelector f
   Server :: TcpServerSelector (Handshake (Job MarloweTxCommand)) f -> RootSelector f
   App :: TransactionServerSelector f -> RootSelector f
   LoadWalletContext :: Q.LoadWalletContextSelector f -> RootSelector f
@@ -56,6 +58,7 @@ renderRootSelectorOTel = \case
   ChainSeekClient sel -> renderTcpClientSelectorOTel sel
   ChainSyncJobClient sel -> renderTcpClientSelectorOTel sel
   ChainSyncQueryClient sel -> renderTcpClientSelectorOTel sel
+  ContractQueryClient sel -> renderTcpClientSelectorOTel sel
   Server sel -> renderTcpServerSelectorOTel sel
   App sel -> renderAppSelectorOTel sel
   LoadWalletContext sel -> renderLoadWalletContextSelectorOTel sel

marlowe-runtime/marlowe-tx/Main.hs

@@ -20,6 +20,7 @@ import Data.GeneralAllocate
 import qualified Data.Text as T
 import Data.Version (showVersion)
 import Language.Marlowe.Runtime.ChainSync.Api (BlockNo(..), ChainSyncQuery(..), RuntimeChainSeekClient)
+import Language.Marlowe.Runtime.Contract.Api (ContractRequest)
 import qualified Language.Marlowe.Runtime.Core.ScriptRegistry as ScriptRegistry
 import Language.Marlowe.Runtime.Transaction (TransactionDependencies(..), transaction)
 import qualified Language.Marlowe.Runtime.Transaction.Query as Query
@@ -92,6 +93,11 @@ run Options{..} = flip runComponent_ () proc _ -> do
       $ handshakeClientConnectorTraced
       $ tcpClientTraced (injectSelector ChainSyncQueryClient) chainSeekHost chainSeekQueryPort queryClientPeer
 
+    contractQueryConnector :: SomeClientConnectorTraced (QueryClient ContractRequest) Span RootSelector (AppM Span)
+    contractQueryConnector = SomeConnectorTraced (injectSelector ContractQueryClient)
+      $ handshakeClientConnectorTraced
+      $ tcpClientTraced (injectSelector ContractQueryClient) contractHost contractQueryPort queryClientPeer
+
   probes <- transaction -< TransactionDependencies
     { connectionSource = SomeConnectionSourceTraced (injectSelector Server)
         $ handshakeConnectionSourceTraced serverSource
@@ -147,6 +153,8 @@ data Options = Options
   , chainSeekQueryPort :: PortNumber
   , chainSeekCommandPort :: PortNumber
   , chainSeekHost :: HostName
+  , contractQueryPort :: PortNumber
+  , contractHost :: HostName
   , port :: PortNumber
   , host :: HostName
   , submitConfirmationBlocks :: BlockNo
@@ -161,6 +169,8 @@ getOptions = execParser $ info (helper <*> parser) infoMod
       <*> chainSeekQueryPortParser
       <*> chainSeekCommandPortParser
       <*> chainSeekHostParser
+      <*> contractQueryPortParser
+      <*> contractHostParser
       <*> portParser
       <*> hostParser
       <*> submitConfirmationBlocksParser
@@ -190,6 +200,14 @@ getOptions = execParser $ info (helper <*> parser) infoMod
       , showDefault
       ]
 
+    contractQueryPortParser = option auto $ mconcat
+      [ long "contract-query-port"
+      , value 3728
+      , metavar "PORT_NUMBER"
+      , help "The port number of the contract query server."
+      , showDefault
+      ]
+
     portParser = option auto $ mconcat
       [ long "command-port"
       , value 3723
@@ -206,6 +224,14 @@ getOptions = execParser $ info (helper <*> parser) infoMod
       , showDefault
       ]
 
+    contractHostParser = strOption $ mconcat
+      [ long "contract-host"
+      , value "127.0.0.1"
+      , metavar "HOST_NAME"
+      , help "The host name of the contract server."
+      , showDefault
+      ]
+
     hostParser = strOption $ mconcat
       [ long "host"
       , short 'h'

marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction.hs

@@ -14,6 +14,7 @@ import Control.Concurrent.Component.Probes
 import Control.Concurrent.STM (STM, atomically)
 import Control.Monad.Event.Class (MonadInjectEvent)
 import Language.Marlowe.Runtime.ChainSync.Api (ChainSyncQuery, RuntimeChainSeekClient)
+import Language.Marlowe.Runtime.Contract.Api (ContractRequest)
 import Language.Marlowe.Runtime.Core.Api (MarloweVersion(..))
 import Language.Marlowe.Runtime.Core.ScriptRegistry (MarloweScripts)
 import Language.Marlowe.Runtime.Transaction.Api (MarloweTxCommand)
@@ -34,6 +35,7 @@ data TransactionDependencies r s m = TransactionDependencies
   , loadWalletContext :: LoadWalletContext m
   , loadMarloweContext :: LoadMarloweContext m
   , chainSyncQueryConnector :: SomeClientConnectorTraced (QueryClient ChainSyncQuery) r s m
+  , contractQueryConnector :: SomeClientConnectorTraced (QueryClient ContractRequest) r s m
   , getCurrentScripts :: forall v. MarloweVersion v -> MarloweScripts
   }
 

marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/BuildConstraints.hs

@@ -14,22 +14,24 @@ import qualified Cardano.Api.Byron as C
 import qualified Cardano.Api.Shelley as C
 import qualified Cardano.Ledger.BaseTypes as CL (Network(..))
 import Control.Category ((>>>))
-import Control.Error (note)
+import Control.Error (ExceptT, note)
 import Control.Monad (unless, (>=>))
 import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (except, throwE, withExceptT)
 import Control.Monad.Trans.Writer (WriterT(runWriterT), tell)
 import Data.Bifunctor (first)
 import Data.Foldable (for_, traverse_)
 import Data.Function (on)
 import Data.Functor ((<&>))
 import Data.List (find, sortBy)
 import qualified Data.Map as Map
-import Data.Maybe (catMaybes, listToMaybe, maybeToList)
+import Data.Maybe (catMaybes, fromMaybe, listToMaybe, maybeToList)
 import qualified Data.Set as Set
 import Data.Time (UTCTime, nominalDiffTimeToSeconds, secondsToNominalDiffTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Traversable (for)
 import GHC.Base (Alternative((<|>)))
+import Language.Marlowe.Core.V1.Semantics (TransactionInput)
 import qualified Language.Marlowe.Core.V1.Semantics as V1
 import qualified Language.Marlowe.Core.V1.Semantics.Types as V1
 import qualified Language.Marlowe.Core.V1.Semantics.Types.Address as V1
@@ -263,7 +265,9 @@ type ApplyResults v = (UTCTime, UTCTime, Maybe (Assets, Datum v))
 
 -- applies an input to a contract.
 buildApplyInputsConstraints
-  :: SystemStart
+  :: Monad m
+  => (TransactionInput -> m (Maybe TransactionInput))
+  -> SystemStart
   -> EraHistory CardanoMode -- ^ The era history for converting times to slots.
   -> MarloweVersion v -- ^ The Marlowe version to build the transaction for.
   -> TransactionScriptOutput v -- ^ The previous script output for the contract
@@ -274,24 +278,27 @@ buildApplyInputsConstraints
                    -- If not specified, this is computed from the the timeouts
                    -- in the contract.
   -> Inputs v -- ^ The inputs to apply to the contract.
-  -> Either (ApplyInputsError v) (ApplyResults v, TxConstraints v)
-buildApplyInputsConstraints systemStart eraHistory version marloweOutput tipSlot metadata invalidBefore invalidHereafter inputs =
+  -> ExceptT (ApplyInputsError v) m (ApplyResults v, TxConstraints v)
+buildApplyInputsConstraints merkleizeInputs systemStart eraHistory version marloweOutput tipSlot metadata invalidBefore invalidHereafter inputs =
   case version of
-    MarloweV1 -> buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput tipSlot metadata invalidBefore invalidHereafter inputs
+    MarloweV1 -> buildApplyInputsConstraintsV1 merkleizeInputs systemStart eraHistory marloweOutput tipSlot metadata invalidBefore invalidHereafter inputs
 
 -- | Creates a set of Tx constraints that are used to build a transaction that
 -- applies an input to a contract.
 buildApplyInputsConstraintsV1
-  :: SystemStart
+  :: forall m
+   . Monad m
+  => (TransactionInput -> m (Maybe TransactionInput))
+  -> SystemStart
   -> EraHistory CardanoMode -- ^ The era history for converting times to slots.
   -> TransactionScriptOutput 'V1 -- ^ The previous script output for the contract with raw TxOut.
   -> SlotNo
   -> MarloweTransactionMetadata -- ^ Metadata to attach to the transaction
   -> Maybe UTCTime -- ^ The minimum bound of the validity interval (inclusive).
   -> Maybe UTCTime -- ^ The maximum bound of the validity interval (exclusive).
   -> Inputs 'V1 -- ^ The inputs to apply to the contract.
-  -> Either (ApplyInputsError 'V1) (ApplyResults 'V1, TxConstraints 'V1)
-buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput tipSlot metadata invalidBefore invalidHereafter inputs = runWriterT do
+  -> ExceptT (ApplyInputsError 'V1) m (ApplyResults 'V1, TxConstraints 'V1)
+buildApplyInputsConstraintsV1 merkleizeInputs systemStart eraHistory marloweOutput tipSlot metadata invalidBefore invalidHereafter inputs = runWriterT do
   let
     TransactionScriptOutput _ _ _ datum = marloweOutput
     V1.MarloweData params state contract = datum
@@ -304,9 +311,9 @@ buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput tipSlot metad
 
   invalidBefore' <- lift $ maybe (pure tipSlot') utcTimeToSlotNo invalidBefore
 
-  lift $ unless (invalidBefore' <= tipSlot') $ Left $ ValidityLowerBoundTooHigh tipSlot $ fromCardanoSlotNo invalidBefore'
+  lift $ unless (invalidBefore' <= tipSlot') $ throwE $ ValidityLowerBoundTooHigh tipSlot $ fromCardanoSlotNo invalidBefore'
 
-  invalidHereafter' <- lift case invalidHereafter of
+  invalidHereafter' <- lift $ case invalidHereafter of
     Nothing -> do
       invalidBefore'' <- slotStart invalidBefore'                             -- Find the start time of the validity range.
       pure case nextMarloweTimeoutAfter invalidBefore'' contract of           -- Find the next timeout after the range start, if any.
@@ -346,8 +353,10 @@ buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput tipSlot metad
     -- first invalid slot to get the last millisecond in the last valid slot.
     <*> (subtract 1 <$> slotNoToPOSIXTime invalidHereafter')
   let transactionInput = V1.TransactionInput { txInterval, txInputs = inputs }
-  (possibleContinuation, payments) <- case V1.computeTransaction transactionInput state contract of
-     V1.Error err -> lift $ Left $ ApplyInputsConstraintsBuildupFailed (MarloweComputeTransactionFailed $ show err)
+  -- Try and auto-merkleize the inputs if possible.
+  transactionInput' <- lift $ lift $ fromMaybe transactionInput <$> merkleizeInputs transactionInput
+  (possibleContinuation, payments) <- case V1.computeTransaction transactionInput' state contract of
+     V1.Error err -> lift $ throwE $ ApplyInputsConstraintsBuildupFailed (MarloweComputeTransactionFailed $ show err)
      V1.TransactionOutput _ payments _ V1.Close ->
        pure (Nothing, payments)
      V1.TransactionOutput _ payments state' contract' ->
@@ -399,8 +408,8 @@ buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput tipSlot metad
     EraHistory _ interpreter = eraHistory
 
     -- Calculate slot number which contains a given timestamp
-    utcTimeToSlotNo :: UTCTime -> Either (ApplyInputsError 'V1) C.SlotNo
-    utcTimeToSlotNo = first (SlotConversionFailed . show) . utcTimeToSlotNo'
+    utcTimeToSlotNo :: UTCTime -> ExceptT (ApplyInputsError 'V1) m C.SlotNo
+    utcTimeToSlotNo = withExceptT (SlotConversionFailed . show) . except . utcTimeToSlotNo'
 
     -- Calculate slot number which contains a given timestamp
     utcTimeToSlotNo' :: UTCTime -> Either PastHorizonException C.SlotNo
@@ -410,9 +419,10 @@ buildApplyInputsConstraintsV1 systemStart eraHistory marloweOutput tipSlot metad
         $ wallclockToSlot relativeTime
       pure $ C.SlotNo $ O.unSlotNo slotNo
 
-    slotStart :: C.SlotNo -> Either (ApplyInputsError 'V1) UTCTime
+    slotStart :: C.SlotNo -> ExceptT (ApplyInputsError 'V1) m UTCTime
     slotStart (C.SlotNo slotNo) = do
-      (relativeTime, _) <- first (SlotConversionFailed . show)
+      (relativeTime, _) <- except
+        $ first (SlotConversionFailed . show)
         $ interpretQuery interpreter
         $ slotToWallclock
         $ O.SlotNo slotNo

marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Safety.hs

@@ -47,6 +47,7 @@ import qualified Cardano.Api.Shelley as Shelley
   , SystemStart(..)
   )
 import Control.Monad.IO.Class (MonadIO)
+import Data.Functor.Identity (runIdentity)
 import qualified Data.Map.Strict as M (Map, elems, empty, fromList, keys, map, mapKeys, singleton, size)
 import qualified Data.Set as S (singleton)
 import qualified Language.Marlowe.Core.V1.Merkle as V1 (MerkleizedContract(..))
@@ -220,7 +221,9 @@ checkTransaction solveConstraints version@MarloweV1 marloweContext@MarloweContex
         utcTimeToSlotNo start history now
       constraints <-
         bimap show snd
-          $ buildApplyInputsConstraints start history version marloweOutput tipSlot metadata intervalBegin intervalEnd txInputs
+          $ runIdentity
+          $ runExceptT
+          $ buildApplyInputsConstraints (const $ pure Nothing) start history version marloweOutput tipSlot metadata intervalBegin intervalEnd txInputs
       let
         walletContext = walletForConstraints version marloweContext changeAddress constraints
       pure

marlowe-runtime/tx/Language/Marlowe/Runtime/Transaction/Server.hs

@@ -29,13 +29,14 @@ import Cardano.Api
   , cardanoEra
   , getTxBody
   , getTxId
+  , hashScriptData
   , makeShelleyAddress
   )
 import Cardano.Api.Shelley (ProtocolParameters)
 import Control.Applicative ((<|>))
 import Control.Concurrent.Component
 import Control.Concurrent.STM (STM, modifyTVar, newEmptyTMVar, newTVar, putTMVar, readTMVar, readTVar, retry)
-import Control.Error.Util (hoistMaybe, note, noteT)
+import Control.Error.Util (hoistMaybe, hush, note, noteT)
 import Control.Exception (Exception(..))
 import Control.Monad (unless)
 import Control.Monad.Event.Class
@@ -48,11 +49,19 @@ import qualified Data.Map as Map
 import Data.Maybe (fromJust)
 import Data.Time (UTCTime)
 import Data.Void (Void)
+import qualified Language.Marlowe.Core.V1.Semantics as V1
 import Language.Marlowe.Runtime.Cardano.Api
-  (fromCardanoAddressInEra, fromCardanoTxId, toCardanoPaymentCredential, toCardanoStakeCredential)
+  ( fromCardanoAddressInEra
+  , fromCardanoDatumHash
+  , fromCardanoTxId
+  , toCardanoPaymentCredential
+  , toCardanoScriptData
+  , toCardanoStakeCredential
+  )
 import Language.Marlowe.Runtime.ChainSync.Api
-  (BlockHeader, ChainSyncQuery(..), Credential(..), TokenName, TxId(..), fromCardanoTxMetadata)
+  (BlockHeader, ChainSyncQuery(..), Credential(..), TokenName, TxId(..), fromCardanoTxMetadata, toDatum)
 import qualified Language.Marlowe.Runtime.ChainSync.Api as Chain
+import Language.Marlowe.Runtime.Contract.Api (ContractRequest, merkleizeInputs)
 import Language.Marlowe.Runtime.Core.Api
   ( Contract
   , ContractId(..)
@@ -119,6 +128,7 @@ data TransactionServerDependencies r s m = TransactionServerDependencies
   , loadWalletContext :: LoadWalletContext m
   , loadMarloweContext :: LoadMarloweContext m
   , chainSyncQueryConnector :: SomeClientConnectorTraced (QueryClient ChainSyncQuery) r s m
+  , contractQueryConnector :: SomeClientConnectorTraced (QueryClient ContractRequest) r s m
   , getTip :: STM Chain.ChainPoint
   , getCurrentScripts :: forall v. MarloweVersion v -> MarloweScripts
   }
@@ -143,6 +153,7 @@ data WorkerDependencies r s m = WorkerDependencies
   , loadWalletContext :: LoadWalletContext m
   , loadMarloweContext :: LoadMarloweContext m
   , chainSyncQueryConnector :: SomeClientConnectorTraced (QueryClient ChainSyncQuery) r s m
+  , contractQueryConnector :: SomeClientConnectorTraced (QueryClient ContractRequest) r s m
   , getTip :: STM Chain.ChainPoint
   , getCurrentScripts :: forall v. MarloweVersion v -> MarloweScripts
   }
@@ -191,6 +202,7 @@ worker = component_ \WorkerDependencies{..} -> do
                 contract
             ApplyInputs version addresses contractId metadata invalidBefore invalidHereafter inputs ->
               withEvent ExecApplyInputs \_ -> withMarloweVersion version $ execApplyInputs
+                contractQueryConnector
                 getTip
                 systemStart
                 eraHistory
@@ -326,8 +338,9 @@ findMarloweOutput address = \case
       address == fromCardanoAddressInEra (cardanoEra @era) address'
 
 execApplyInputs
-  :: MonadIO m
-  => STM Chain.ChainPoint
+  :: (MonadUnliftIO m, MonadEvent r s m, HasSpanContext r)
+  => SomeClientConnectorTraced (QueryClient ContractRequest) r s m
+  -> STM Chain.ChainPoint
   -> SystemStart
   -> EraHistory CardanoMode
   -> SolveConstraints
@@ -342,6 +355,7 @@ execApplyInputs
   -> Inputs v
   -> m (ServerStCmd MarloweTxCommand Void (ApplyInputsError v) (InputsApplied BabbageEra v) m ())
 execApplyInputs
+  contractQueryConnector
   getTip
   systemStart
   eraHistory
@@ -363,18 +377,23 @@ execApplyInputs
         Chain.Genesis -> retry
         Chain.At Chain.BlockHeader{..} -> pure slotNo
     tipSlot <- liftIO getTipSlot
-    scriptOutput' <- except $ maybe (Left ScriptOutputNotFound) Right scriptOutput
-    ((invalidBefore, invalidHereafter, mAssetsAndDatum), constraints) <-
-      except $ buildApplyInputsConstraints
-        systemStart
-        eraHistory
-        version
-        scriptOutput'
-        tipSlot
-        metadata
-        invalidBefore'
-        invalidHereafter'
-        inputs
+    scriptOutput'@TransactionScriptOutput{datum = inputDatum} <- except $ maybe (Left ScriptOutputNotFound) Right scriptOutput
+    let
+      (contractHash, state) = case version of
+        MarloweV1 -> case inputDatum of
+          V1.MarloweData{..} -> (fromCardanoDatumHash $ hashScriptData $ toCardanoScriptData $ toDatum marloweContract, marloweState)
+      merkleizeInputs' = fmap hush . runSomeConnectorTraced contractQueryConnector . merkleizeInputs contractHash state
+    ((invalidBefore, invalidHereafter, mAssetsAndDatum), constraints) <- buildApplyInputsConstraints
+      merkleizeInputs'
+      systemStart
+      eraHistory
+      version
+      scriptOutput'
+      tipSlot
+      metadata
+      invalidBefore'
+      invalidHereafter'
+      inputs
     walletContext <- lift $ loadWalletContext addresses
     txBody <- except
       $ first ApplyInputsConstraintError