Add getMerkleizedInputs integration test and fix bugs

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), getMerkleizedInputs)
 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 (ContractPath(PathWhenCases), genWhenPath, 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 "getMerkleizedInputs" do
+  prop "Produces equivalent inputs" \state -> forAll (genTimeInterval state) \interval -> forAll (genWhenPath (Environment interval) state) \whenPath ->
+    let
+      path = PathWhenCases whenPath
+      contract = getContract path
+      inputs = getInputs [] path
+    in counterexample (show inputs)
+      $ counterexample (show contract) $ runContractTest do
+        hash <- expectJust "failed to push contract" $ runLoad $ pushContract contract
+        inputs' <- either (fail . show) pure =<< runQuery (getMerkleizedInputs hash state interval inputs)
+        Api.ContractWithAdjacency{contract = merkleizedContract} <- expectJust "Failed to get contract" $ runQuery $ Api.getContract hash
+        let expected = computeTransaction (TransactionInput interval $ NormalInput <$> inputs) 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 (TransactionInput interval inputs') 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-runtime/contract-api/Language/Marlowe/Runtime/Contract/Api.hs

@@ -35,6 +35,7 @@ data GetMerkleizedInputsError
   = GetMerkleizedInputsContractNotFound DatumHash
   | GetMerkleizedInputsApplyNoMatch InputContent
   | GetMerkleizedInputsApplyAmbiguousInterval InputContent
+  | GetMerkleizedInputsReduceAmbiguousInterval InputContent
   | GetMerkleizedInputsIntervalError IntervalError
   deriving stock (Show, Eq, Generic)
   deriving anyclass (Binary, Variations)

marlowe-runtime/contract/Language/Marlowe/Runtime/Contract/Store/Memory.hs

@@ -12,7 +12,8 @@ import qualified Data.Set as Set
 import GHC.Conc (throwSTM)
 import GHC.IO (mkUserError)
 import Language.Marlowe.Core.V1.Plate (Extract(extractAll))
-import Language.Marlowe.Core.V1.Semantics (ApplyAction(..), applyAction, fixInterval)
+import Language.Marlowe.Core.V1.Semantics
+  (ApplyAction(..), ReduceResult(..), applyAction, fixInterval, reduceContractUntilQuiescent)
 import Language.Marlowe.Core.V1.Semantics.Types
   (Case(..), Contract(..), Environment, Input(..), InputContent, IntervalResult(..), State, TimeInterval, getAction)
 import Language.Marlowe.Runtime.Cardano.Api (fromCardanoDatumHash, toCardanoScriptData)
@@ -104,26 +105,28 @@ getMerkleizedInputsDefault
   -> [InputContent]
   -> m (Either GetMerkleizedInputsError [Input])
 getMerkleizedInputsDefault getContract' = \hash state interval inputs -> runExceptT do
-    case fixInterval interval state of
-      IntervalTrimmed env state' -> do
-        contract <- getContractExcept hash
-        fst <$> go env state' inputs contract []
-      IntervalError err -> throwE $ GetMerkleizedInputsIntervalError err
-    where
-      getContractExcept hash = lift (getContract' hash) >>= \case
-        Nothing -> throwE $ GetMerkleizedInputsContractNotFound hash
-        Just c -> pure c
+  case fixInterval interval state of
+    IntervalTrimmed env state' -> do
+      contract <- getContractExcept hash
+      go env state' inputs contract []
+    IntervalError err -> throwE $ GetMerkleizedInputsIntervalError err
+  where
+    getContractExcept hash = lift (getContract' hash) >>= \case
+      Nothing -> throwE $ GetMerkleizedInputsContractNotFound hash
+      Just c -> pure c
 
-      go env state inputs contract acc = case inputs of
-        [] -> pure (reverse acc, state)
-        input : inputs' -> do
-          (continuation, state') <- except $ applyInputContent state env input contract
+    go env state inputs contract acc = case inputs of
+      [] -> pure $ reverse acc
+      input : inputs' -> case reduceContractUntilQuiescent env state contract of
+        ContractQuiescent _ _ _ state' contract' -> do
+          (continuation, state'') <- except $ applyInputContent state' env input contract'
           case continuation of
-            Left contract' ->
-              go env state' inputs' contract' (NormalInput input : acc)
+            Left contract'' ->
+              go env state'' inputs' contract'' (NormalInput input : acc)
             Right hash -> do
-              contract' <- getContractExcept $ DatumHash $ PV2.fromBuiltin hash
-              go env state' inputs' contract (MerkleizedInput input hash contract' : acc)
+              contract'' <- getContractExcept $ DatumHash $ PV2.fromBuiltin hash
+              go env state'' inputs' contract'' (MerkleizedInput input hash contract'' : acc)
+        RRAmbiguousTimeIntervalError -> throwE $ GetMerkleizedInputsReduceAmbiguousInterval input
 
 applyInputContent
   :: State

marlowe-test/src/Spec/Marlowe/Semantics.hs

@@ -31,9 +31,9 @@ tests :: TestTree
 tests =
   testGroup "Semantics"
     [
-      -- Spec.Marlowe.Semantics.Entropy.tests
-    -- , Spec.Marlowe.Semantics.Functions.tests
-    -- , Spec.Marlowe.Semantics.Compute.tests
-    -- , Spec.Marlowe.Semantics.Golden.tests
-      Spec.Marlowe.Semantics.Path.tests
+      Spec.Marlowe.Semantics.Entropy.tests
+    , Spec.Marlowe.Semantics.Functions.tests
+    , Spec.Marlowe.Semantics.Compute.tests
+    , Spec.Marlowe.Semantics.Golden.tests
+    , Spec.Marlowe.Semantics.Path.tests
     ]

marlowe-test/src/Spec/Marlowe/Semantics/Arbitrary.hs

@@ -961,7 +961,7 @@ instance SemiArbitrary Contract where
         , pure Close
         ]
        else frequency
-        [ (4, Pay <$> semiArbitrary ctx <*> semiArbitrary ctx <*> semiArbitrary ctx <*> semiArbitrary ctx <*> resize (pred size) (semiArbitrary ctx))
+        [ (4 , Pay <$> semiArbitrary ctx <*> semiArbitrary ctx <*> semiArbitrary ctx <*> semiArbitrary ctx <*> resize (pred size) (semiArbitrary ctx))
         , (2, If <$> semiArbitrary ctx <*> resize (size `quot` 2) (semiArbitrary ctx) <*> resize (size `quot` 2) (semiArbitrary ctx))
         , ( 3
           , do
@@ -1051,7 +1051,7 @@ instance SemiArbitrary State where
 
 instance Arbitrary Environment where
   arbitrary = Environment <$> arbitraryTimeInterval
-  shrink (Environment x) = Environment <$> shrink x
+  shrink (Environment x) = Environment <$> shrinkTimeInterval x
 
 instance SemiArbitrary Environment where
   semiArbitrary context = Environment <$> semiArbitrary context