Management of Merkleization

[bwbush]

See GIST https://gist.github.com/jhbertra/2537036687ac003a4cb1597b4af77f3b

[bwbush]

The design looks fine, but I made three comments on the GIST:

• https://gist.github.com/jhbertra/2537036687ac003a4cb1597b4af77f3b?permalink_comment_id=4317047#gistcomment-4317047
• https://gist.github.com/jhbertra/2537036687ac003a4cb1597b4af77f3b?permalink_comment_id=4317051#gistcomment-4317051
• https://gist.github.com/jhbertra/2537036687ac003a4cb1597b4af77f3b?permalink_comment_id=4317055#gistcomment-4317055

[jhbertra]

So, I just realized that maybe this URI layer is not actually necessary. In theory, everything could be managed locally by the runtime. We don't actually need a way to publish and share the continuations. We need a way to recreate them locally. Then the party that initiates the contract could initialize a local index of continuations that the runtime has access to. The other parties to the contract would need a way to obtain the original source of the contract (for example in extended Marlowe) and generate their own local index of continuations that their own runtimes could manage for them. Then the metadata of the create transaction would just need to include a link to the source code in extended Marlowe.

Of course, this means that Extended Marlowe would be the only way to create the contracts, so that's a potential downside of this approach.

[jhbertra]

Picking back up again on this discussion. Since this is a relatively large topic, let's break it down into sub-problems and attack them separately.

1. Creation of Merkleized contracts
2. Storage of continuations
3. Distribution of continuations

I will start a thread for each.

[jhbertra]

Creation of Merkleized Contracts

The problems with creating Merkleized contracts are

1. The size of unmerkleized contracts means some form of streaming is necessary
2. The index of continuations needs to be persisted to disk, not kept in memory
3. The contracts need to be generated programmatically, not written by hand

There are existing solutions to this problem in the marlowe-cli codebase, as well as elsewhere where a WriterT is used to lazily generate the contracts in constant memory via list fusion.

There is probably a space here for a runtime (or runtime-adjacent) component, and this problem could be solved with a protocol. However, it may not be the highest priority to build for the time being if other existing tools are viable for end users. I'm curious to hear thoughts on the viability of the existing tools for solving this problem.

[jhbertra]

One factor which could influence this is integration with the REST API. I think there needs to be some kind of runtime service to manage streaming merkleization for the REST API to support building large contracts. The REST endpoints would probably also be somewhat complicated here, so a good front-end library is a must to support this (using async JavaScript is potentially a good approach here).

[jhbertra]

Storage of continuations

Some options here include:

1. Disk-based local index (could make use of existing marlowe-cli approach to this)
2. The linked continuation file approach describe in the Gist above
3. A combination of the two which uses the local index as a cache and falls back to fetching from the linked metadata file

Some problems to consider:

1. Garbage collection of unused continuations to free up disk space
2. Validation of continuation file
3. Handling missing resources (either in local index or broken links)

[jhbertra]

Distribution of Continuations

Some options here include:

1. A peer-to-peer service that uses a gossip protocol to fetch continuations
2. The approach described in the Gist above
3. Using a service like IPFS

The second option seems like the most practical and the least limiting (it could work with or without the Marlowe Runtime and requires no local software daemons to be running).

[jhbertra]

Here are the steps I propose we take to incrementally improve Merkleization support in the Runtime:

1. Via TxMetadata, add support for continuation files at arbitrary URIs as described in the Gist
2. Teach the Runtime how to handle continuation files to auto-assemble merkleized inputs. At this point, it is still up to the user to create their own continuation indexes (functional, not user-friendly)
3. Build a service that incrementally builds up merkleized contracts via a protocol, and saves the resulting continuation index to a file hosting service.
4. Add an API for incremental contract creation to the REST API which makes use of this service
5. Add an interactive command to the CLI that uses this protocol.

[jhbertra]

Here is a module that implements the necessary functionality to work with the proposed continuation map structure:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}

module Language.Marlowe.Runtime.Merkle.ContinuationMap
  ( BuildMerkleizedInputError(..)
  , ContinuationMap(ContinuationMap, contract, continuations)
  , LoadContinuationsError(..)
  , RecursivelyValidateContinuationMapError(..)
  , buildMerkleizedRedeemer
  , buildMerkleizedRedeemer'
  , buildV1MerkleizedInput
  , buildV1MerkleizedInput'
  , loadAndParseURI
  , loadContinuations
  , mkContinuationMap
  , recursivelyValidateContinuationMap
  ) where

import Cardano.Api (FromJSON, hashScriptData)
import Control.Concurrent.Async.Lifted (mapConcurrently, mapConcurrently_)
import Control.Error (MaybeT(..), hoistMaybe, noteT)
import Control.Error.Util (note)
import Control.Monad (mfilter, unless)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Except (ExceptT(..), except, throwE, withExceptT)
import Data.Aeson (ToJSON, defaultOptions, eitherDecode, genericParseJSON, parseJSON, toJSON, withText)
import Data.Aeson.Types (parseFail)
import Data.Bifunctor (first, second)
import qualified Data.ByteString.Lazy as LBS
import Data.Foldable (foldlM)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Semigroup (First(..))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import GHC.Generics (Generic)
import qualified Language.Marlowe.Core.V1.Semantics as V1
import qualified Language.Marlowe.Core.V1.Semantics.Types as V1
import Language.Marlowe.Runtime.Cardano.Api (fromCardanoDatumHash, toCardanoScriptData)
import Language.Marlowe.Runtime.ChainSync.Api (DatumHash(..), toDatum)
import Language.Marlowe.Runtime.Core.Api (Contract, Datum, MarloweVersion(..), MarloweVersionTag(..), Redeemer)
import Network.URI (URI, parseURIReference, uriToString)
import Plutus.V2.Ledger.Api (fromBuiltin, toBuiltin)

-- | A URI newtype wrapper for JSON serialization
newtype JsonURI = JsonURI { unJsonURI :: URI }
  deriving (Show, Eq, Ord, Generic)

instance ToJSON JsonURI where
  toJSON = toJSON . flip (uriToString id) "" . unJsonURI

instance FromJSON JsonURI where
  parseJSON = withText "URI"
    $ maybe (parseFail "invalid URI") (pure . JsonURI)
    . parseURIReference
    . T.unpack

-- | Holds a contract and a map of continuation hashes to URIs of JSON files
-- that hold the continuation map for that hash.
data ContinuationMap v = UnsafeContinuationMap
  { contract :: Contract v
  , continuations :: Map DatumHash JsonURI
  } deriving (Generic)

deriving instance Show (ContinuationMap 'V1)
deriving instance Eq (ContinuationMap 'V1)
deriving instance Ord (ContinuationMap 'V1)
instance FromJSON (ContinuationMap 'V1) where
  parseJSON json = do
    cmap <- genericParseJSON defaultOptions json
    unless (validateContinuationMap MarloweV1 cmap) $ parseFail "Invalid continuation map"
    pure cmap
instance ToJSON (ContinuationMap 'V1)

-- | Validate the structure of a ContinuationMap
validateContinuationMap :: MarloweVersion v -> ContinuationMap v -> Bool
validateContinuationMap version UnsafeContinuationMap{..} = hashesFrom version contract == Map.keysSet continuations

{-# COMPLETE ContinuationMap #-}

pattern ContinuationMap :: Contract v -> Map DatumHash JsonURI -> ContinuationMap v
pattern ContinuationMap contract continuations <- UnsafeContinuationMap contract continuations

mkContinuationMap :: MarloweVersion v -> Contract v -> Map DatumHash JsonURI -> Maybe (ContinuationMap v)
mkContinuationMap version contract continuations = mfilter (validateContinuationMap version) $ Just UnsafeContinuationMap{..}

-- | Extract the set of hashes referenced by a contract.
hashesFrom :: MarloweVersion v -> Contract v -> Set DatumHash
hashesFrom MarloweV1 = go
  where
  go = \case
    V1.Pay _ _ _ _ c -> go c
    V1.Close -> mempty
    V1.If _ c1 c2 -> go c1 <> go c2
    V1.When cases _ c -> foldMap hashesFromCase cases <> go c
    V1.Let _ _ c -> go c
    V1.Assert _ c -> go c
  hashesFromCase = \case
    V1.Case _ c -> go c
    V1.MerkleizedCase _ hash -> Set.singleton $ DatumHash $ fromBuiltin hash

data LoadContinuationsError v
  = BrokenLink URI
  | MalformedContents DatumHash String
  | ChecksumFailure DatumHash (Contract v)

-- | Load the continuations in a continuation map and collect the results in a
-- Map.
loadContinuations
  :: MonadBaseControl IO m
  => (URI -> m (Maybe LBS.ByteString))
  -> MarloweVersion v
  -> ContinuationMap v
  -> ExceptT (LoadContinuationsError v) m (Map DatumHash (ContinuationMap v))
loadContinuations fetchURI version = fmap Map.fromDistinctAscList
  . mapConcurrently (uncurry loadAndParseURI')
  . Map.toAscList
  . continuations
  where
    loadAndParseURI' datumHash uri = (datumHash,) <$> loadAndParseURI fetchURI version datumHash uri

-- | Load a continuation map at a URI
loadAndParseURI
  :: MonadBaseControl IO m
  => (URI -> m (Maybe LBS.ByteString))
  -> MarloweVersion v
  -> DatumHash
  -> JsonURI
  -> ExceptT (LoadContinuationsError v) m (ContinuationMap v)
loadAndParseURI fetchURI MarloweV1 datumHash (JsonURI uri) = do
  response <- noteT (BrokenLink uri) $ MaybeT $ fetchURI uri
  except do
    cm@UnsafeContinuationMap{..} <- first (MalformedContents datumHash) $ eitherDecode response
    let scriptData = toCardanoScriptData $ toDatum contract
    unless (datumHash == fromCardanoDatumHash (hashScriptData scriptData)) $ Left $ ChecksumFailure datumHash contract
    pure cm

data RecursivelyValidateContinuationMapError v
  = There DatumHash URI (RecursivelyValidateContinuationMapError v)
  | Here (LoadContinuationsError v)
  | Loop

-- | Recursively validates a continuation map and all linked continuation maps.
recursivelyValidateContinuationMap
  :: forall m v
   . MonadBaseControl IO m
  => (URI -> m (Maybe LBS.ByteString))
  -> MarloweVersion v
  -> ContinuationMap v
  -> ExceptT (RecursivelyValidateContinuationMapError v) m ()
recursivelyValidateContinuationMap fetchURI version = recursivelyValidateContinuationMapWithLoopDetection mempty
  where
  recursivelyValidateContinuationMapWithLoopDetection :: Set DatumHash -> ContinuationMap v -> ExceptT (RecursivelyValidateContinuationMapError v) m ()
  recursivelyValidateContinuationMapWithLoopDetection seenHashes = mapConcurrently_ (uncurry loadAndRecurse) . Map.toList . continuations
    where
    loadAndRecurse datumHash uri = withExceptT (There datumHash $ unJsonURI uri) do
      unless (Set.notMember datumHash seenHashes) $ throwE Loop
      nextMap <- withExceptT Here $ loadAndParseURI fetchURI version datumHash uri
      recursivelyValidateContinuationMapWithLoopDetection (Set.insert datumHash seenHashes) nextMap

data BuildMerkleizedInputError v
  = InvalidInput
  | InvalidContinuationMap
  | LoadContinuationsError (LoadContinuationsError v)

-- | Build a V1 merkleized input out of regular input content, given a
-- continuation map. Also returns the next State and ContinuationMap after
-- applying the input.
buildV1MerkleizedInput'
  :: MonadBaseControl IO m
  => (URI -> m (Maybe LBS.ByteString))
  -> ContinuationMap 'V1
  -> UTCTime
  -> UTCTime
  -> V1.State
  -> V1.InputContent
  -> ExceptT (BuildMerkleizedInputError 'V1) m (V1.Input, (V1.State, ContinuationMap 'V1))
buildV1MerkleizedInput' fetchURI continuationMap invalidBefore invalidHereafter state inputContent = do
  (mHash, state') <- except $ findHashForInput (contract continuationMap)
  case mHash of
    Left contract' -> pure (V1.NormalInput inputContent, (state', pruneContinuationMap contract' continuationMap))
    Right datumHash -> do
      uri <- noteT InvalidContinuationMap $ hoistMaybe $ Map.lookup datumHash $ continuations continuationMap
      let contractHash = toBuiltin $ unDatumHash datumHash
      continuationMap' <- withExceptT LoadContinuationsError $ loadAndParseURI fetchURI MarloweV1 datumHash uri
      pure (V1.MerkleizedInput inputContent contractHash (contract continuationMap'), (state', continuationMap'))
  where
    utcTimeToPOSIXTime = floor . (* 1000) . utcTimeToPOSIXSeconds
    env = V1.Environment (utcTimeToPOSIXTime invalidBefore, utcTimeToPOSIXTime invalidHereafter)
    findHashForInput :: V1.Contract -> Either (BuildMerkleizedInputError 'V1) (Either V1.Contract DatumHash, V1.State)
    findHashForInput = \case
      V1.When cases _ _ -> note InvalidInput $ getFirst <$> foldMap findHashForInputInCase cases
      _ -> Left InvalidInput

    findHashForInputInCase :: V1.Case V1.Contract -> Maybe (First (Either V1.Contract DatumHash, V1.State))
    findHashForInputInCase = \case
      V1.Case action contract -> returnIfApplies action $ Left contract
      V1.MerkleizedCase action hash -> returnIfApplies action $ Right $ DatumHash $ fromBuiltin hash
      where
        returnIfApplies action mHash = case V1.applyAction env state inputContent action of
          V1.AppliedAction _ state' -> Just $ First (mHash, state')
          V1.NotAppliedAction -> Nothing

    pruneContinuationMap :: Contract 'V1 -> ContinuationMap 'V1 -> ContinuationMap 'V1
    pruneContinuationMap contract cm = cm { contract, continuations = Map.restrictKeys (continuations cm) $ hashesFrom MarloweV1 contract }

-- | Build a V1 merkleized input out of regular input content, given a
-- continuation map.
buildV1MerkleizedInput
  :: MonadBaseControl IO m
  => (URI -> m (Maybe LBS.ByteString))
  -> ContinuationMap 'V1
  -> UTCTime
  -> UTCTime
  -> V1.State
  -> V1.InputContent
  -> ExceptT (BuildMerkleizedInputError 'V1) m V1.Input
buildV1MerkleizedInput fetchURI continuationMap invalidBefore invalidHereafter state inputContent =
  fst <$> buildV1MerkleizedInput' fetchURI continuationMap invalidBefore invalidHereafter state inputContent

-- | Build a merkleized redeemer out of a regular redeemer, given a
-- continuation map. Also returns the next State and ContinuationMap after
-- applying the redeemer.
buildMerkleizedRedeemer'
  :: forall m v
   . MonadBaseControl IO m
  => (URI -> m (Maybe LBS.ByteString))
  -> MarloweVersion v
  -> ContinuationMap v
  -> UTCTime
  -> UTCTime
  -> Datum v
  -> Redeemer v
  -> ExceptT (Int, BuildMerkleizedInputError v) m (Redeemer v, (Datum v, ContinuationMap v))
buildMerkleizedRedeemer' fetchURI MarloweV1 cmap invalidBefore invalidHereafter md =
  fmap (second \(marloweState, cmap') -> (md { V1.marloweState, V1.marloweContract = contract cmap'}, cmap'))
    . foldlM buildV1MerkleizedInput'' ([], (V1.marloweState md, cmap))
    . zip [0..]
  where
    buildV1MerkleizedInput''
      :: ([V1.Input], (V1.State, ContinuationMap 'V1))
      -> (Int, V1.Input)
      -> ExceptT (Int, BuildMerkleizedInputError 'V1) m ([V1.Input], (V1.State, ContinuationMap 'V1))
    buildV1MerkleizedInput'' (inputs, (state, continuationMap)) (i, input) = withExceptT (i,) do
      let
        inputContent = case input of
          V1.NormalInput c -> c
          V1.MerkleizedInput c _ _ -> c -- Ignore manually provided continuations. We need to recompute them to propagate the state properly.
      first (: inputs) <$> buildV1MerkleizedInput' fetchURI continuationMap invalidBefore invalidHereafter state inputContent

-- | Build a merkleized redeemer out of a regular redeemer, given a
-- continuation map.
buildMerkleizedRedeemer
  :: forall m v
   . MonadBaseControl IO m
  => (URI -> m (Maybe LBS.ByteString))
  -> MarloweVersion v
  -> ContinuationMap v
  -> UTCTime
  -> UTCTime
  -> Datum v
  -> Redeemer v
  -> ExceptT (Int, BuildMerkleizedInputError v) m (Redeemer v)
buildMerkleizedRedeemer fetchURI version cmap invalidBefore invalidHereafter md =
  fmap fst . buildMerkleizedRedeemer' fetchURI version cmap invalidBefore invalidHereafter md

[bwbush]

I think this is fine to start with. In particular, fetchURI is general enough for initial use cases. I suppose we could even use database URIs, not just file, HTTP/HTTPS and IPFS.

[bwbush]

In case it is useful, the marlowe-cli merkleization code is in Language.Marlowe.CLI.Merkle. I don't think we need deep and shallow versions of (de-)merkleization for Runtime.

Also, in principle the ContinuationMap could shrink after a continuation is used by a transaction and will never be needed again. Mathematically, the correct structure is a directed acyclic graph, not a map: as the graph is traversed, the "upstream" parts of it can be discarded.