PLT-5850 Merkleize Inputs query

deploy/nomadTasks.nix

@@ -152,6 +152,8 @@ rec
       MARLOWE_CHAIN_SYNC_PORT = "\${NOMAD_PORT_marlowe_chain_sync}";
       MARLOWE_CHAIN_SYNC_QUERY_PORT = "\${NOMAD_PORT_marlowe_chain_sync_query}";
       MARLOWE_CHAIN_SYNC_COMMAND_PORT = "\${NOMAD_PORT_marlowe_chain_sync_command}";
+      CONTRACT_HOST = "localhost";
+      CONTRACT_QUERY_PORT = "\${NOMAD_PORT_contract_query}";
       HTTP_PORT = "\${NOMAD_PORT_tx_http}";
     };
     config.image = ociNamer oci-images.marlowe-tx;
@@ -194,7 +196,7 @@ rec
       TX_PORT = "\${NOMAD_PORT_tx}";
       CONTRACT_HOST = "localhost";
       LOAD_PORT = "\${NOMAD_PORT_marlowe_load}";
-      QUERY_PORT = "\${NOMAD_PORT_contract_query}";
+      CONTRACT_QUERY_PORT = "\${NOMAD_PORT_contract_query}";
       SYNC_HOST = "localhost";
       MARLOWE_SYNC_PORT = "\${NOMAD_PORT_marlowe_sync}";
       MARLOWE_HEADER_SYNC_PORT = "\${NOMAD_PORT_marlowe_header_sync}";

deploy/operables.nix

@@ -359,6 +359,7 @@ in
       #################
       # HOST, PORT: network binding
       # MARLOWE_CHAIN_SYNC_HOST, MARLOWE_CHAIN_SYNC_PORT, MARLOWE_CHAIN_SYNC_QUERY_PORT, MARLOWE_CHAIN_SYNC_COMMAND_PORT: connection info to marlowe-chain-sync
+      # CONTRACT_HOST, CONTRACT_QUERY_PORT: connection info to marlowe-contract
       # HTTP_PORT: port number for the HTTP healthcheck server
 
       #################
@@ -373,6 +374,8 @@ in
       [ -z "''${MARLOWE_CHAIN_SYNC_PORT:-}" ] && echo "MARLOWE_CHAIN_SYNC_PORT env var must be set -- aborting" && exit 1
       [ -z "''${MARLOWE_CHAIN_SYNC_COMMAND_PORT:-}" ] && echo "MARLOWE_CHAIN_SYNC_COMMAND_PORT env var must be set -- aborting" && exit 1
       [ -z "''${MARLOWE_CHAIN_SYNC_QUERY_PORT:-}" ] && echo "MARLOWE_CHAIN_SYNC_QUERY_PORT env var must be set -- aborting" && exit 1
+      [ -z "''${CONTRACT_HOST:-}" ] && echo "CONTRACT_HOST env var must be set -- aborting" && exit 1
+      [ -z "''${CONTRACT_QUERY_PORT:-}" ] && echo "CONTRACT_QUERY_PORT env var must be set -- aborting" && exit 1
       [ -z "''${HTTP_PORT:-}" ] && echo "HTTP_PORT env var must be set -- aborting" && exit 1
 
       ${wait-for-tcp}/bin/wait-for-tcp "$MARLOWE_CHAIN_SYNC_HOST" "$MARLOWE_CHAIN_SYNC_PORT"
@@ -386,6 +389,8 @@ in
         --chain-sync-query-port "$MARLOWE_CHAIN_SYNC_QUERY_PORT" \
         --chain-sync-command-port "$MARLOWE_CHAIN_SYNC_COMMAND_PORT" \
         --chain-sync-host "$MARLOWE_CHAIN_SYNC_HOST" \
+        --contract-host "$CONTRACT_HOST" \
+        --contract-query-port "$CONTRACT_QUERY_PORT" \
         --http-port "$HTTP_PORT"
     '';
   };
@@ -435,7 +440,7 @@ in
       # HOST, PORT, TRACED_PORT: network binding
       # TX_HOST, TX_PORT: connection info to marlowe-tx
       # SYNC_HOST, MARLOWE_SYNC_PORT, MARLOWE_HEADER_SYNC_PORT, MARLOWE_QUERY_PORT: connection info to marlowe-sync
-      # CONTRACT_HOST, LOAD_PORT, QUERY_PORT: connection info to marlowe-contract
+      # CONTRACT_HOST, LOAD_PORT, CONTRACT_QUERY_PORT: connection info to marlowe-contract
       # HTTP_PORT: port number for the HTTP healthcheck server
 
       #################
@@ -451,7 +456,7 @@ in
       [ -z "''${TX_PORT:-}" ] && echo "TX_PORT env var must be set -- aborting" && exit 1
       [ -z "''${CONTRACT_HOST:-}" ] && echo "CONTRACT_HOST env var must be set -- aborting" && exit 1
       [ -z "''${LOAD_PORT:-}" ] && echo "LOAD_PORT env var must be set -- aborting" && exit 1
-      [ -z "''${QUERY_PORT:-}" ] && echo "QUERY_PORT env var must be set -- aborting" && exit 1
+      [ -z "''${CONTRACT_QUERY_PORT:-}" ] && echo "CONTRACT_QUERY_PORT env var must be set -- aborting" && exit 1
       [ -z "''${SYNC_HOST:-}" ] && echo "SYNC_HOST env var must be set -- aborting" && exit 1
       [ -z "''${MARLOWE_SYNC_PORT:-}" ] && echo "MARLOWE_SYNC_PORT env var must be set -- aborting" && exit 1
       [ -z "''${MARLOWE_HEADER_SYNC_PORT:-}" ] && echo "MARLOWE_HEADER_SYNC_PORT env var must be set -- aborting" && exit 1
@@ -474,7 +479,7 @@ in
         --marlowe-query-port "$MARLOWE_QUERY_PORT" \
         --marlowe-contract-host "$CONTRACT_HOST" \
         --marlowe-load-port "$LOAD_PORT" \
-        --contract-query-port "$QUERY_PORT" \
+        --contract-query-port "$CONTRACT_QUERY_PORT" \
         --tx-host "$TX_HOST" \
         --tx-command-port "$TX_PORT" \
         --http-port "$HTTP_PORT"

marlowe-integration-tests/marlowe-integration-tests.cabal

@@ -80,6 +80,7 @@ executable marlowe-integration-tests
     Language.Marlowe.Runtime.Web.PutWithdrawal
     Language.Marlowe.Runtime.CliSpec
   build-depends:
+    , QuickCheck
     , aeson
     , async-components
     , base >= 4.9 && < 5
@@ -105,9 +106,11 @@ executable marlowe-integration-tests
     , marlowe-runtime:history-api
     , marlowe-runtime:sync-api
     , marlowe-runtime:tx-api
+    , marlowe-test
     , mtl
     , network-uri
     , plutus-ledger-api
+    , plutus-tx
     , resourcet
     , servant-client
     , servant-pagination

marlowe-integration-tests/test/Language/Marlowe/Runtime/Integration/Contract.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -17,13 +18,14 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Language.Marlowe.Core.V1.Merkle (deepMerkleize)
 import Language.Marlowe.Core.V1.Plate (extractAll)
+import Language.Marlowe.Core.V1.Semantics (TransactionInput(..), TransactionOutput(..), computeTransaction)
 import Language.Marlowe.Core.V1.Semantics.Types
 import Language.Marlowe.Protocol.Load.Client (MarloweLoadClient, marloweLoadClientPeer, pushContract)
 import Language.Marlowe.Protocol.Load.Server (marloweLoadServerPeer)
 import Language.Marlowe.Runtime.Cardano.Api (fromCardanoDatumHash, toCardanoScriptData)
 import Language.Marlowe.Runtime.ChainSync.Api (DatumHash(..), toDatum)
-import Language.Marlowe.Runtime.Contract
-import Language.Marlowe.Runtime.Contract.Api (ContractWithAdjacency(adjacency))
+import qualified Language.Marlowe.Runtime.Contract as Contract
+import Language.Marlowe.Runtime.Contract.Api (ContractWithAdjacency(adjacency), merkleizeInputs)
 import qualified Language.Marlowe.Runtime.Contract.Api as Api
 import Language.Marlowe.Runtime.Contract.Store.File (ContractStoreOptions(..), createContractStore)
 import Network.Protocol.Connection
@@ -33,13 +35,39 @@ import Network.Protocol.Query.Client (QueryClient, queryClientPeer)
 import Network.Protocol.Query.Server (queryServerPeer)
 import Network.TypedProtocol (unsafeIntToNat)
 import qualified Plutus.V2.Ledger.Api as PV2
+import Spec.Marlowe.Semantics.Arbitrary (arbitraryNonnegativeInteger)
+import Spec.Marlowe.Semantics.Path (genContractPath, getContract, getInputs)
 import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
 import Test.Integration.Marlowe (createWorkspace, resolveWorkspacePath)
+import Test.QuickCheck (Gen, counterexample, forAll)
 import UnliftIO (atomically, liftIO, race_)
 
 spec :: Spec
 spec = parallel $ describe "MarloweContract" do
   getContractSpec
+  getMerkleizedInputsSpec
+
+getMerkleizedInputsSpec :: Spec
+getMerkleizedInputsSpec = describe "merkleizeInputs" do
+  prop "Produces equivalent inputs" \state -> forAll (genTimeInterval state) \interval -> forAll (genContractPath (Environment interval) state) \path ->
+    let
+      contract = getContract path
+      inputs = getInputs [] path
+    in counterexample (show inputs)
+      $ counterexample (show contract) $ runContractTest do
+        hash <- expectJust "failed to push contract" $ runLoad $ pushContract contract
+        let input = TransactionInput interval $ NormalInput <$> inputs
+        input' <- either (fail . show) pure =<< runQuery (merkleizeInputs hash state input)
+        Api.ContractWithAdjacency{contract = merkleizedContract} <- expectJust "Failed to get contract" $ runQuery $ Api.getContract hash
+        let expected = computeTransaction input state contract
+        let
+          expected' = case expected of
+            TransactionOutput warnings payment state' contract' ->
+              TransactionOutput warnings payment state' $ fst $ runWriter $ deepMerkleize contract'
+            a -> a
+        let actual = computeTransaction input' state merkleizedContract
+        liftIO $ actual `shouldBe` expected'
 
 getContractSpec :: Spec
 getContractSpec = describe "getContract" do
@@ -166,7 +194,7 @@ runContractTest test = runResourceT do
       { loadConnector = SomeConnectorTraced inject $ clientConnector loadPair
       , queryConnector = SomeConnectorTraced inject $ clientConnector queryPair
       }
-  runNoopEventT $ flip runReaderT testHandle $ race_ test $ runComponent_ (void contract) ContractDependencies
+  runNoopEventT $ flip runReaderT testHandle $ race_ test $ runComponent_ (void Contract.contract) Contract.ContractDependencies
     { batchSize = unsafeIntToNat 10
     , contractStore
     , loadSource = SomeConnectionSourceTraced inject $ connectionSource loadPair
@@ -192,3 +220,10 @@ data AnySelector f where
 
 instance Inject s AnySelector where
   inject s f = f (AnySelector s) id
+
+genTimeInterval :: State -> Gen TimeInterval
+genTimeInterval State{..} = do
+  dStart <- arbitraryNonnegativeInteger
+  let start = PV2.getPOSIXTime minTime + dStart
+  duration <- arbitraryNonnegativeInteger
+  pure (PV2.POSIXTime start, PV2.POSIXTime $ start + duration)

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

@@ -13,8 +13,10 @@ import Data.Time.Clock (nominalDiffTimeToSeconds)
 import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
 import Language.Marlowe.Core.V1.Semantics.Types
 import Language.Marlowe.Extended.V1 (ada)
+import Language.Marlowe.Protocol.Load.Client (pushContract)
 import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader)
-import Language.Marlowe.Runtime.Client (createContract)
+import Language.Marlowe.Runtime.Client (createContract, runContractQueryClient, runMarloweLoadClient)
+import qualified Language.Marlowe.Runtime.Contract.Api as Contract
 import Language.Marlowe.Runtime.Core.Api
   ( ContractId
   , MarloweMetadata(..)
@@ -86,6 +88,9 @@ createStandardContractWithTags tags partyAWallet partyBWallet = do
   partyBAddress <- expectJust "Failed to convert party B address" $ toPlutusAddress $ changeAddress $ addresses partyBWallet
   now <- liftIO getCurrentTime
   let (contract, partyA, partyB) = standardContract partyBAddress now $ secondsToNominalDiffTime 100
+  contractHash <- expectJust "Failed to push contract" =<< runMarloweLoadClient (pushContract contract)
+  Contract.ContractWithAdjacency{ contract = contract' } <-
+    expectJust "Failed to load merkleized contract" =<< runContractQueryClient (Contract.getContract contractHash)
   result <- createContract
     Nothing
     MarloweV1
@@ -101,7 +106,7 @@ createStandardContractWithTags tags partyAWallet partyBWallet = do
           }
     )
     2_000_000
-    contract
+    contract'
   contractCreated@ContractCreated{contractId, txBody = createTxBody} <- expectRight "failed to create standard contract" result
   createdBlock <- submit partyAWallet createTxBody
 

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/changelog.d/20230531_163411_jhbertra_plt_5850_get_merkleized_inputs.md

@@ -0,0 +1,12 @@
+### Added
+
+- `MarkleizeInputs` request to `ContractRequest` (`marlowe-contract` query API)
+
+### Changed
+
+- `Apply` will auto-merkleize normal inputs to a contract if the contract is in
+  the store.
+  - E.g. Given an on-chain contract `When [MerkleizedCase (Notify TrueObs) "foo"] 0 Close`,
+    a client can call `Apply` with `[NormalInput INotify]` and `marlowe-tx` will
+    merkleize it automatically if it can find the contract in the store.
+    Clients can still pass manually merkleized inputs to `Apply` if desired.

marlowe-runtime/contract-api/Language/Marlowe/Runtime/Contract/Api.hs

@@ -11,35 +11,63 @@ import Data.Data (type (:~:)(..))
 import qualified Data.List.NonEmpty as NE
 import Data.Set (Set)
 import GHC.Generics (Generic)
+import Language.Marlowe.Core.V1.Semantics (TransactionInput)
 import Language.Marlowe.Core.V1.Semantics.Types
 import Language.Marlowe.Runtime.ChainSync.Api (DatumHash)
 import Language.Marlowe.Runtime.Core.Api ()
-import Network.Protocol.Codec.Spec (Variations(variations))
+import Network.Protocol.Codec.Spec (Variations(variations), varyAp)
 import Network.Protocol.Handshake.Types (HasSignature, signature)
 import Network.Protocol.Query.Client (QueryClient, request)
 import Network.Protocol.Query.Types
 
 data ContractRequest a where
   GetContract :: DatumHash -> ContractRequest (Maybe ContractWithAdjacency)
+  MerkleizeInputs
+    :: DatumHash
+    -> State
+    -> TransactionInput
+    -> ContractRequest (Either MerkleizeInputsError TransactionInput)
+
+deriving instance Show (ContractRequest a)
+deriving instance Eq (ContractRequest a)
+
+data MerkleizeInputsError
+  = MerkleizeInputsContractNotFound DatumHash
+  | MerkleizeInputsApplyNoMatch Input
+  | MerkleizeInputsApplyAmbiguousInterval Input
+  | MerkleizeInputsReduceAmbiguousInterval Input
+  | MerkleizeInputsIntervalError IntervalError
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (Binary, Variations)
 
 getContract :: Applicative m => DatumHash -> QueryClient ContractRequest m (Maybe ContractWithAdjacency)
 getContract = request . GetContract
 
-deriving instance Show (ContractRequest a)
-deriving instance Eq (ContractRequest a)
-deriving instance Ord (ContractRequest a)
+merkleizeInputs
+  :: Applicative m
+  => DatumHash
+  -> State
+  -> TransactionInput
+  -> QueryClient ContractRequest m (Either MerkleizeInputsError TransactionInput)
+merkleizeInputs = (fmap . fmap) request . MerkleizeInputs
 
 instance HasSignature ContractRequest where
   signature _ = "ContractRequest"
 
 instance Request ContractRequest where
   data Tag ContractRequest a where
     TagGetContract :: Tag ContractRequest (Maybe ContractWithAdjacency)
+    TagMerkleizeInputs :: Tag ContractRequest (Either MerkleizeInputsError TransactionInput)
   tagFromReq = \case
     GetContract{} -> TagGetContract
+    MerkleizeInputs{} -> TagMerkleizeInputs
   tagEq = \case
     TagGetContract -> \case
       TagGetContract -> Just Refl
+      _ -> Nothing
+    TagMerkleizeInputs -> \case
+      TagMerkleizeInputs -> Just Refl
+      _ -> Nothing
 
 deriving instance Show (Tag ContractRequest a)
 deriving instance Eq (Tag ContractRequest a)
@@ -50,37 +78,50 @@ instance BinaryRequest ContractRequest where
     GetContract hash -> do
       putWord8 0x00
       put hash
+    MerkleizeInputs hash state input -> do
+      putWord8 0x01
+      put hash
+      put state
+      put input
   getReq = do
     tag <- getWord8
     case tag of
       0x00 -> SomeRequest . GetContract <$> get
+      0x01 -> SomeRequest <$> (MerkleizeInputs <$> get <*> get <*> get)
       _ -> fail $ "Invalid ContractRequest tag " <> show tag
   putResult = \case
     TagGetContract -> put
+    TagMerkleizeInputs -> put
   getResult = \case
     TagGetContract -> get
+    TagMerkleizeInputs -> get
 
 instance ShowRequest ContractRequest where
   showsPrecResult p = \case
     TagGetContract -> showsPrec p
+    TagMerkleizeInputs -> showsPrec p
 
 instance OTelRequest ContractRequest where
   reqTypeName _ = "contract_request"
   reqName = \case
     TagGetContract -> "get_contract"
+    TagMerkleizeInputs -> "get_merkleized_inputs"
 
 instance RequestVariations ContractRequest where
   tagVariations = NE.fromList
     [ SomeTag TagGetContract
     ]
   requestVariations = \case
     TagGetContract -> GetContract <$> variations
+    TagMerkleizeInputs -> MerkleizeInputs <$> variations `varyAp` variations `varyAp` variations
   resultVariations = \case
     TagGetContract -> variations
+    TagMerkleizeInputs -> variations
 
 instance RequestEq ContractRequest where
   resultEq = \case
     TagGetContract -> (==)
+    TagMerkleizeInputs -> (==)
 
 -- | A contract with its adjacency and closure information.
 data ContractWithAdjacency = ContractWithAdjacency

marlowe-runtime/contract/Language/Marlowe/Runtime/Contract/QueryServer.hs

@@ -8,7 +8,7 @@ module Language.Marlowe.Runtime.Contract.QueryServer
 
 import Control.Concurrent.Component
 import Control.Monad.Event.Class
-import Language.Marlowe.Runtime.Contract.Api hiding (getContract)
+import Language.Marlowe.Runtime.Contract.Api hiding (getContract, merkleizeInputs)
 import Language.Marlowe.Runtime.Contract.Store (ContractStore(..))
 import Network.Protocol.Connection
 import Network.Protocol.Driver.Trace (HasSpanContext, runSomeConnectorTraced)
@@ -41,3 +41,4 @@ worker WorkerDependencies{..} = runSomeConnectorTraced connector server
   where
     server = respond concurrently \case
       GetContract hash -> getContract contractStore hash
+      MerkleizeInputs hash state input -> merkleizeInputs contractStore hash state input