Implement getMerkleizedInputs

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

@@ -21,13 +21,22 @@ import Network.Protocol.Query.Types
 
 data ContractRequest a where
   GetContract :: DatumHash -> ContractRequest (Maybe ContractWithAdjacency)
-  GetMerkleizedInputs :: DatumHash -> State -> [InputContent] -> ContractRequest (Either GetMerkleizedInputsError [Input])
+  GetMerkleizedInputs
+    :: DatumHash
+    -> State
+    -> TimeInterval
+    -> [InputContent]
+    -> ContractRequest (Either GetMerkleizedInputsError [Input])
 
 deriving instance Show (ContractRequest a)
 deriving instance Eq (ContractRequest a)
 
-data GetMerkleizedInputsError = GetMerkleizedInputsError
-  deriving stock (Show, Eq, Ord, Generic)
+data GetMerkleizedInputsError
+  = GetMerkleizedInputsContractNotFound DatumHash
+  | GetMerkleizedInputsApplyNoMatch InputContent
+  | GetMerkleizedInputsApplyAmbiguousInterval InputContent
+  | GetMerkleizedInputsIntervalError IntervalError
+  deriving stock (Show, Eq, Generic)
   deriving anyclass (Binary, Variations)
 
 getContract :: Applicative m => DatumHash -> QueryClient ContractRequest m (Maybe ContractWithAdjacency)
@@ -37,9 +46,10 @@ getMerkleizedInputs
   :: Applicative m
   => DatumHash
   -> State
+  -> TimeInterval
   -> [InputContent]
   -> QueryClient ContractRequest m (Either GetMerkleizedInputsError [Input])
-getMerkleizedInputs = (fmap . fmap) request . GetMerkleizedInputs
+getMerkleizedInputs = (fmap . fmap . fmap) request . GetMerkleizedInputs
 
 instance HasSignature ContractRequest where
   signature _ = "ContractRequest"
@@ -68,15 +78,17 @@ instance BinaryRequest ContractRequest where
     GetContract hash -> do
       putWord8 0x00
       put hash
-    GetMerkleizedInputs hash state inputs -> do
+    GetMerkleizedInputs hash state timeInterval inputs -> do
       putWord8 0x01
       put hash
       put state
+      put timeInterval
       put inputs
   getReq = do
     tag <- getWord8
     case tag of
       0x00 -> SomeRequest . GetContract <$> get
+      0x01 -> SomeRequest <$> (GetMerkleizedInputs <$> get <*> get <*> get <*> get)
       _ -> fail $ "Invalid ContractRequest tag " <> show tag
   putResult = \case
     TagGetContract -> put
@@ -102,7 +114,7 @@ instance RequestVariations ContractRequest where
     ]
   requestVariations = \case
     TagGetContract -> GetContract <$> variations
-    TagGetMerkleizedInputs -> GetMerkleizedInputs <$> variations `varyAp` variations `varyAp` variations
+    TagGetMerkleizedInputs -> GetMerkleizedInputs <$> variations `varyAp` variations `varyAp` variations `varyAp` variations
   resultVariations = \case
     TagGetContract -> variations
     TagGetMerkleizedInputs -> variations

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, getMerkleizedInputs)
 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
+      GetMerkleizedInputs hash state interval inputs -> getMerkleizedInputs contractStore hash state interval inputs

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

@@ -8,20 +8,29 @@ import Control.Monad.Event.Class
 import Data.Foldable (traverse_)
 import Data.Set (Set)
 import Data.Void (Void)
-import Language.Marlowe.Core.V1.Semantics.Types (Contract)
+import Language.Marlowe.Core.V1.Semantics.Types (Contract, Input, InputContent, State, TimeInterval)
 import Language.Marlowe.Runtime.ChainSync.Api (DatumHash)
-import Language.Marlowe.Runtime.Contract.Api (ContractWithAdjacency)
+import Language.Marlowe.Runtime.Contract.Api (ContractWithAdjacency, GetMerkleizedInputsError)
 import Observe.Event (InjectSelector, addField, injectSelector, reference)
 import Observe.Event.Backend (setInitialCauseEventBackend)
 
 data ContractStoreSelector f where
   CreateContractStagingArea :: ContractStoreSelector Void
   ContractStagingAreaSelector :: ContractStagingAreaSelector f -> ContractStoreSelector f
   GetContract :: DatumHash -> ContractStoreSelector ContractWithAdjacency
+  GetMerkleizedInputs  :: ContractStoreSelector GetMerkleizedInputsField
+
+data GetMerkleizedInputsField
+  = GetMerkleizedInputsContractHash DatumHash
+  | GetMerkleizedInputsState State
+  | GetMerkleizedInputsInterval TimeInterval
+  | GetMerkleizedInputsInputs  [InputContent]
+  | GetMerkleizedInputsResult  (Either GetMerkleizedInputsError [Input])
 
 data ContractStore m = ContractStore
   { createContractStagingArea :: m (ContractStagingArea m)
   , getContract :: DatumHash -> m (Maybe ContractWithAdjacency)
+  , getMerkleizedInputs :: DatumHash -> State -> TimeInterval -> [InputContent] -> m (Either GetMerkleizedInputsError [Input])
   }
 
 hoistContractStore
@@ -32,6 +41,7 @@ hoistContractStore
 hoistContractStore f ContractStore{..} = ContractStore
   { createContractStagingArea = f $ hoistContractStagingArea f <$> createContractStagingArea
   , getContract = f . getContract
+  , getMerkleizedInputs = (fmap . fmap . fmap) f . getMerkleizedInputs
   }
 
 traceContractStore
@@ -48,6 +58,14 @@ traceContractStore inj ContractStore{..} = ContractStore
       result <- getContract hash
       traverse_ (addField ev) result
       pure result
+  , getMerkleizedInputs = \hash state interval inputs -> withInjectEvent inj GetMerkleizedInputs \ev -> do
+      addField ev $ GetMerkleizedInputsContractHash hash
+      addField ev $ GetMerkleizedInputsState state
+      addField ev $ GetMerkleizedInputsInterval interval
+      addField ev $ GetMerkleizedInputsInputs inputs
+      result <- getMerkleizedInputs hash state interval inputs
+      addField ev $ GetMerkleizedInputsResult result
+      pure result
   }
 
 data ContractStagingAreaSelector f where

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

@@ -29,6 +29,7 @@ import Language.Marlowe.Runtime.Cardano.Api (fromCardanoDatumHash, toCardanoScri
 import Language.Marlowe.Runtime.ChainSync.Api (DatumHash(..), toDatum)
 import Language.Marlowe.Runtime.Contract.Api hiding (getContract)
 import Language.Marlowe.Runtime.Contract.Store
+import Language.Marlowe.Runtime.Contract.Store.Memory (getMerkleizedInputsDefault)
 import Language.Marlowe.Runtime.Core.Api ()
 import Plutus.V2.Ledger.Api (fromBuiltin)
 import System.FilePath (takeBaseName, (<.>), (</>))
@@ -77,7 +78,15 @@ createContractStore ContractStoreOptions{..} = do
   let lockfile = contractStoreDirectory </> "lockfile"
   pure ContractStore
     { createContractStagingArea = createContractStagingArea lockfile
-    , getContract = getContract lockfile
+    , getContract = getContract True lockfile
+    , getMerkleizedInputs = \hash state interval input ->
+        withLockFile lockingParameters lockfile
+          $ getMerkleizedInputsDefault
+              ((fmap . fmap) (\ContractWithAdjacency{..} -> contract) . getContract False lockfile)
+              hash
+              state
+              interval
+              input
     }
 
   where
@@ -86,14 +95,14 @@ createContractStore ContractStoreOptions{..} = do
       , retryToAcquireLock = NumberOfTimes 20
       }
 
-    getContract lockfile contractHash
+    getContract lock lockfile contractHash
       | contractHash == closeHash = pure $ Just ContractWithAdjacency
           { contract = Close
           , contractHash = closeHash
           , adjacency = mempty
           , closure = Set.singleton closeHash
           }
-      | otherwise = withLockFile lockingParameters lockfile $ runMaybeT do
+      | otherwise = (if lock then withLockFile lockingParameters lockfile else id) $ runMaybeT do
           let mkFilePath = (contractStoreDirectory </>) . (read (show contractHash) <.>)
           let contractFilePath = mkFilePath "contract"
           let adjacencyFilePath = mkFilePath "adjacency"

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

@@ -2,6 +2,8 @@ module Language.Marlowe.Runtime.Contract.Store.Memory
   where
 
 import Cardano.Api (hashScriptData)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (except, runExceptT, throwE)
 import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -10,9 +12,11 @@ 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.Types (Case(..), Contract)
+import Language.Marlowe.Core.V1.Semantics (ApplyAction(..), applyAction, fixInterval)
+import Language.Marlowe.Core.V1.Semantics.Types
+  (Case(..), Contract(..), Environment, Input(..), InputContent, IntervalResult(..), State, TimeInterval, getAction)
 import Language.Marlowe.Runtime.Cardano.Api (fromCardanoDatumHash, toCardanoScriptData)
-import Language.Marlowe.Runtime.ChainSync.Api (DatumHash(DatumHash), toDatum)
+import Language.Marlowe.Runtime.ChainSync.Api (DatumHash(..), toDatum)
 import Language.Marlowe.Runtime.Contract.Api hiding (getContract)
 import Language.Marlowe.Runtime.Contract.Store
 import qualified Plutus.V2.Ledger.Api as PV2
@@ -26,6 +30,10 @@ createContractStoreInMemory = do
   pure ContractStore
     { createContractStagingArea = createContractStagingAreaInMemory store
     , getContract = getContract store
+    , getMerkleizedInputs =
+        getMerkleizedInputsDefault
+          $ (fmap . fmap) (\ContractWithAdjacency {..} -> contract)
+          . getContract store
     }
   where
     createContractStagingAreaInMemory store = do
@@ -83,3 +91,65 @@ computeAdjacency = foldMap getHash . extractAll
   getHash = \case
     MerkleizedCase _ hash -> Set.singleton $ DatumHash $ PV2.fromBuiltin hash
     _ -> mempty
+
+toPlutusDatumHash :: DatumHash -> PV2.BuiltinByteString
+toPlutusDatumHash = PV2.toBuiltin . unDatumHash
+
+getMerkleizedInputsDefault
+  :: Monad m
+  => (DatumHash -> m (Maybe Contract))
+  -> DatumHash
+  -> State
+  -> TimeInterval
+  -> [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
+
+      go env state inputs contract acc = case inputs of
+        [] -> pure (reverse acc, state)
+        input : inputs' -> do
+          (continuation, state') <- except $ applyInputContent state env input contract
+          case continuation of
+            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)
+
+applyInputContent
+  :: State
+  -> Environment
+  -> InputContent
+  -> Contract
+  -> Either GetMerkleizedInputsError (Either Contract PV2.BuiltinByteString, State)
+applyInputContent state env input = \case
+  When cases _ _ -> applyInputContentCases state env input cases
+  _ -> Left $ GetMerkleizedInputsApplyNoMatch input
+
+applyInputContentCases
+  :: State
+  -> Environment
+  -> InputContent
+  -> [Case Contract]
+  -> Either GetMerkleizedInputsError (Either Contract PV2.BuiltinByteString, State)
+applyInputContentCases state env input = \case
+  [] -> Left $ GetMerkleizedInputsApplyNoMatch input
+  c : cs ->
+    let
+      action = getAction c
+      continuation = case c of
+        Case _ contract -> Left contract
+        MerkleizedCase _ hash -> Right hash
+    in
+      case applyAction env state input action of
+        AppliedAction _ state' -> pure (continuation, state')
+        NotAppliedAction -> applyInputContentCases state env input cs

marlowe-runtime/marlowe-contract/Logging.hs

@@ -17,7 +17,7 @@ import Language.Marlowe.Protocol.Load.Types (MarloweLoad)
 import Language.Marlowe.Runtime.Contract.Api (ContractRequest)
 import Language.Marlowe.Runtime.Contract.LoadServer (LoadServerSelector(..))
 import Language.Marlowe.Runtime.Contract.Store
-  (ContractStagingAreaSelector(..), ContractStoreSelector(..), StageContractField(..))
+  (ContractStagingAreaSelector(..), ContractStoreSelector(..), GetMerkleizedInputsField(..), StageContractField(..))
 import Network.Protocol.Driver.Trace (TcpServerSelector, renderTcpServerSelectorOTel)
 import Network.Protocol.Handshake.Types (Handshake)
 import Network.Protocol.Query.Types (Query)
@@ -72,6 +72,23 @@ renderContractStoreSelectorOTel = \case
     , eventKind = Client
     , renderField = const [("marlowe.contract.contract_exists", toAttribute True)]
     }
+  GetMerkleizedInputs -> OTelRendered
+    { eventName = "marlowe/contract/get_merkleized_inputs"
+    , eventKind = Client
+    , renderField = \case
+        GetMerkleizedInputsState state -> [("marlowe.state", toAttribute $ toStrict $ encodeToLazyText state)]
+        GetMerkleizedInputsContractHash hash -> [("marlowe.contract_hash", fromString $ read $ show hash)]
+        GetMerkleizedInputsInterval (lo, hi) ->
+          [ ("marlowe.interval_low" , toAttribute $ IntAttribute $ fromIntegral lo)
+          , ("marlowe.interval_high" , toAttribute $ IntAttribute $ fromIntegral hi)
+          ]
+        GetMerkleizedInputsInputs inputs ->
+          [("marlowe.contract.input_contents", toAttribute $ toStrict . encodeToLazyText <$> inputs)]
+        GetMerkleizedInputsResult (Left err) ->
+          [("error", fromString $ show err)]
+        GetMerkleizedInputsResult (Right inputs) ->
+          [("marlowe.inputs", toAttribute $ toStrict . encodeToLazyText <$> inputs)]
+    }
 
 renderContractStagingAreaSelectorOTel :: RenderSelectorOTel ContractStagingAreaSelector
 renderContractStagingAreaSelectorOTel = \case

marlowe-runtime/src/Language/Marlowe/Runtime/Core/Api.hs

@@ -513,6 +513,7 @@ instance Binary V1.Payee
 instance Binary V1.State
 instance Binary V1.Token
 instance Binary V1.ValueId
+instance Binary V1.IntervalError
 instance Binary a => Binary (V1.Case a)
 instance Binary a => Binary (V1.Value a)
 
@@ -535,6 +536,7 @@ instance Variations V1.Payee
 instance Variations V1.State
 instance Variations V1.Token
 instance Variations V1.ValueId
+instance Variations V1.IntervalError
 
 instance Variations V1.Party where
   variations = NE.fromList $ NE.filter (not . hasStakingPointer) $ to <$> gVariations