Merge pull request #658 from input-output-hk/plt-6343-get-contract-so…

…urces

PLT-6343 GET APIs for Contract Sources

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

@@ -9,6 +9,12 @@ import qualified Data.Set as Set
 import Data.Text (Text)
 import Data.Time (getCurrentTime, secondsToNominalDiffTime)
 import Language.Marlowe.Extended.V1 (ada)
+import Language.Marlowe.Object.Types (
+  LabelledObject (LabelledObject),
+  ObjectBundle (ObjectBundle),
+  ObjectType (..),
+  fromCoreContract,
+ )
 import Language.Marlowe.Runtime.Integration.Common (Wallet (..), expectJust)
 import Language.Marlowe.Runtime.Integration.StandardContract (standardContract)
 import Language.Marlowe.Runtime.Plutus.V2.Api (toPlutusAddress)
@@ -22,7 +28,7 @@ import Language.Marlowe.Runtime.Web (
   WithdrawTxEnvelope,
  )
 import qualified Language.Marlowe.Runtime.Web as Web
-import Language.Marlowe.Runtime.Web.Client (postContract)
+import Language.Marlowe.Runtime.Web.Client (getContractSource, postContract, postContractSource)
 import Language.Marlowe.Runtime.Web.Common (
   choose,
   deposit,
@@ -33,6 +39,8 @@ import Language.Marlowe.Runtime.Web.Common (
   withdraw,
  )
 import Language.Marlowe.Runtime.Web.Server.DTO (ToDTO (toDTO))
+import Language.Marlowe.Runtime.Web.Types (PostContractSourceResponse (..))
+import Pipes (yield)
 import Servant.Client.Streaming (ClientM)
 
 data StandardContractInit = StandardContractInit
@@ -82,6 +90,11 @@ createStandardContractWithTags tags partyAWallet partyBWallet = do
   now <- liftIO getCurrentTime
   let (contract, partyA, partyB) = standardContract partyBAddress now $ secondsToNominalDiffTime 100
 
+  PostContractSourceResponse{contractSourceId} <-
+    postContractSource "main" $ yield $ ObjectBundle $ pure $ LabelledObject "main" ContractType $ fromCoreContract contract
+
+  contract' <- getContractSource contractSourceId False
+
   contractCreated@Web.CreateTxEnvelope{contractId} <-
     postContract
       Nothing
@@ -92,7 +105,7 @@ createStandardContractWithTags tags partyAWallet partyBWallet = do
         { metadata = mempty
         , version = Web.V1
         , roles = Just $ Web.Mint $ Map.singleton "Party A" $ RoleTokenSimple partyAWebChangeAddress
-        , contract = contract
+        , contract = contract'
         , minUTxODeposit = 2_000_000
         , tags = tags
         }

marlowe-integration-tests/test/Language/Marlowe/Runtime/WebSpec.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -Wno-unused-imports #-}
-
 module Language.Marlowe.Runtime.WebSpec where
 
 import qualified Language.Marlowe.Runtime.Web.Contracts.Get as Contracts.Get

marlowe-runtime-web/marlowe-runtime-web.cabal

@@ -76,7 +76,7 @@ library
     , openapi3 >=3.2 && <4
     , parsec ^>=3.1.14
     , pipes ^>=4.3.16
-    , plutus-ledger-api
+    , plutus-ledger-api ==1.0.0.1
     , servant ^>=0.19
     , servant-client ^>=0.19
     , servant-client-core ^>=0.19
@@ -141,6 +141,7 @@ library server
     , mtl >=2.2 && <3
     , openapi3 >=3.2 && <4
     , pipes ^>=4.3.16
+    , plutus-ledger-api ==1.0.0.1
     , servant ^>=0.19
     , servant-openapi3 ^>=2.0
     , servant-pagination >=2.5 && <3

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server.hs

@@ -38,6 +38,7 @@ import qualified Language.Marlowe.Runtime.Web as Web
 import Language.Marlowe.Runtime.Web.Server.ContractClient (
   ContractClient (..),
   ContractClientDependencies (..),
+  GetContract,
   ImportBundle,
   contractClient,
  )
@@ -176,6 +177,7 @@ server = proc deps@ServerDependencies{connector} -> do
           , _loadWithdrawals = loadWithdrawals
           , _loadWithdrawal = loadWithdrawal
           , _createContract = createContract
+          , _getContract = getContract
           , _applyInputs = applyInputs
           , _withdraw = withdraw
           , _submitContract = submitContract
@@ -196,6 +198,7 @@ data WebServerDependencies r s = WebServerDependencies
   , _loadTransactions :: LoadTransactions (AppM r s)
   , _loadTransaction :: LoadTransaction (AppM r s)
   , _createContract :: CreateContract (AppM r s)
+  , _getContract :: GetContract (AppM r s)
   , _withdraw :: Withdraw (AppM r s)
   , _applyInputs :: ApplyInputs (AppM r s)
   , _submitContract :: ContractId -> Submit r (AppM r s)

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/ContractClient.hs

@@ -24,6 +24,8 @@ import Language.Marlowe.Protocol.Client (MarloweRuntimeClient (..), hoistMarlowe
 import Language.Marlowe.Protocol.Transfer.Types (ImportError (..))
 import Language.Marlowe.Runtime.ChainSync.Api (DatumHash)
 import Language.Marlowe.Runtime.Client (importIncremental)
+import Language.Marlowe.Runtime.Contract.Api (ContractWithAdjacency)
+import qualified Language.Marlowe.Runtime.Contract.Api as Contract
 import Network.Protocol.Connection (Connector, runConnector)
 import Pipes (MFunctor (..), Pipe, await, yield, (>->))
 import Unsafe.Coerce (unsafeCoerce)
@@ -35,9 +37,13 @@ newtype ContractClientDependencies m = ContractClientDependencies
 -- | Signature for a delegate that imports a bundle into the runtime.
 type ImportBundle m = Label -> Pipe ObjectBundle (Map Label DatumHash) (ExceptT ImportError m) ()
 
+-- | Signature for a delegate that gets a contract from the runtime.
+type GetContract m = DatumHash -> m (Maybe ContractWithAdjacency)
+
 -- | Public API of the ContractClient
-newtype ContractClient m = ContractClient
+data ContractClient m = ContractClient
   { importBundle :: ImportBundle m
+  , getContract :: GetContract m
   }
 
 contractClient :: (MonadUnliftIO m) => Component m (ContractClientDependencies m) (ContractClient m)
@@ -54,6 +60,7 @@ contractClient = arr \ContractClientDependencies{..} ->
           case result of
             Nothing -> pure ()
             Just err -> throwError err
+    , getContract = runConnector connector . RunContractQueryClient . Contract.getContract
     }
 
 watchForMain :: (Monad m) => Label -> Pipe ObjectBundle ObjectBundle (ExceptT ImportError m) ()

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/Monad.hs

@@ -21,7 +21,7 @@ import Control.Monad.Trans.Control (MonadBaseControl)
 import Control.Monad.Trans.Except (mapExceptT)
 import Language.Marlowe.Runtime.ChainSync.Api (TxId)
 import Language.Marlowe.Runtime.Core.Api (ContractId)
-import Language.Marlowe.Runtime.Web.Server.ContractClient (ImportBundle)
+import Language.Marlowe.Runtime.Web.Server.ContractClient (GetContract, ImportBundle)
 import Language.Marlowe.Runtime.Web.Server.SyncClient (
   LoadContract,
   LoadContractHeaders,
@@ -61,6 +61,7 @@ data AppEnv = forall r s.
   , _loadTransaction :: LoadTransaction (AppM r s)
   , _importBundle :: ImportBundle (AppM r s)
   , _createContract :: CreateContract (AppM r s)
+  , _getContract :: GetContract (AppM r s)
   , _withdraw :: Withdraw (AppM r s)
   , _applyInputs :: ApplyInputs (AppM r s)
   , _submitContract :: ContractId -> Submit r (AppM r s)
@@ -95,6 +96,12 @@ loadWithdrawals wFilter range = do
   AppEnv{_eventBackend = backend, _loadWithdrawals = load} <- ask
   liftBackendM backend $ load wFilter range
 
+-- | Get a contract by its hash.
+getContract :: GetContract ServerM
+getContract hash = do
+  AppEnv{_eventBackend = backend, _getContract = get} <- ask
+  liftBackendM backend $ get hash
+
 -- | Load a list of withdrawal headers.
 loadWithdrawal :: LoadWithdrawal ServerM
 loadWithdrawal withdrawalId = do

marlowe-runtime-web/server/Language/Marlowe/Runtime/Web/Server/REST/ContractSources.hs

@@ -3,21 +3,63 @@ module Language.Marlowe.Runtime.Web.Server.REST.ContractSources where
 import Control.Monad.Except (runExceptT)
 import Data.Aeson (object)
 import Data.Aeson.Types ((.=))
+import Data.Coerce (coerce)
 import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Traversable (for)
+import Language.Marlowe.Core.V1.Merkle (Continuations, deepDemerkleize, demerkleizeContract)
+import Language.Marlowe.Core.V1.Semantics.Types (Contract)
 import Language.Marlowe.Object.Link (LinkError (DuplicateLabel, TypeMismatch, UnknownSymbol))
 import Language.Marlowe.Object.Types (Label, ObjectBundle)
 import Language.Marlowe.Protocol.Transfer.Types (ImportError (..))
 import Language.Marlowe.Runtime.ChainSync.Api (DatumHash (..))
-import Language.Marlowe.Runtime.Web (ContractSourcesAPI)
+import Language.Marlowe.Runtime.Contract.Api (ContractWithAdjacency (..))
+import Language.Marlowe.Runtime.Web (ContractSourceAPI, ContractSourcesAPI, ListObject (..))
 import Language.Marlowe.Runtime.Web.Server.Monad
 import Language.Marlowe.Runtime.Web.Server.REST.ApiError (badRequest', badRequest'')
 import Language.Marlowe.Runtime.Web.Types (ContractSourceId (..), PostContractSourceResponse (..))
 import Pipes (MFunctor (..), Producer, liftIO, (>->))
 import qualified Pipes.Prelude as Pipes
+import qualified Plutus.V2.Ledger.Api as PV2
 import Servant
 
 server :: ServerT ContractSourcesAPI ServerM
-server = post
+server =
+  post
+    :<|> contractServer
+
+contractServer :: ContractSourceId -> ServerT ContractSourceAPI ServerM
+contractServer sourceId =
+  getOne sourceId
+    :<|> getAdjacency sourceId
+    :<|> getClosure sourceId
+
+getOne :: ContractSourceId -> Bool -> ServerM Contract
+getOne sourceId expand = do
+  ContractWithAdjacency{..} <- getContractOrThrow sourceId
+  if expand
+    then do
+      continuations <- loadContinuations closure
+      case demerkleizeContract continuations $ deepDemerkleize contract of
+        Left err -> fail err
+        Right expanded -> pure expanded
+    else pure contract
+
+getAdjacency :: ContractSourceId -> ServerM (ListObject ContractSourceId)
+getAdjacency = fmap (coerce . Set.toList . adjacency) . getContractOrThrow
+
+getClosure :: ContractSourceId -> ServerM (ListObject ContractSourceId)
+getClosure = fmap (coerce . Set.toList . closure) . getContractOrThrow
+
+loadContinuations :: Set DatumHash -> ServerM Continuations
+loadContinuations closure =
+  Map.fromDistinctAscList <$> for (Set.toAscList closure) \hash -> do
+    ContractWithAdjacency{contract} <- maybe (fail $ "Failed to load continuation: " <> show hash) pure =<< getContract hash
+    pure (PV2.DatumHash $ PV2.toBuiltin $ unDatumHash hash, contract)
+
+getContractOrThrow :: ContractSourceId -> ServerM ContractWithAdjacency
+getContractOrThrow sourceId = maybe (throwError err404) pure =<< getContract (coerce sourceId)
 
 post :: Label -> Producer ObjectBundle IO () -> ServerM PostContractSourceResponse
 post main bundles = do

marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/API.hs

@@ -56,6 +56,7 @@ import Language.Marlowe.Core.V1.Next
 import Language.Marlowe.Runtime.Web.Next.Schema ()
 
 import Data.Text.Encoding (encodeUtf8)
+import Language.Marlowe.Core.V1.Semantics.Types (Contract)
 import Language.Marlowe.Object.Types (Label, ObjectBundle)
 import Language.Marlowe.Runtime.Web.Types
 import Network.HTTP.Media ((//))
@@ -231,12 +232,25 @@ type GETNextContinuationAPI =
 -- | /contracts/sources sub-API
 type ContractSourcesAPI =
   PostContractSourcesAPI
+    :<|> Capture "contractSourceId" ContractSourceId :> ContractSourceAPI
+
+-- | /contracts/sources/:contractSourceId sub-API
+type ContractSourceAPI =
+  GetContractSourceAPI
+    :<|> "adjacency" :> GetContractSourceIdsAPI
+    :<|> "closure" :> GetContractSourceIdsAPI
 
 type PostContractSourcesAPI =
   QueryParam' '[Required] "main" Label
     :> StreamBody NewlineFraming JSON (Producer ObjectBundle IO ())
     :> Post '[JSON] PostContractSourceResponse
 
+type GetContractSourceAPI =
+  QueryFlag "expand"
+    :> Get '[JSON] Contract
+
+type GetContractSourceIdsAPI = Get '[JSON] (ListObject ContractSourceId)
+
 -- | /contracts/:contractId/transactions sup-API
 type TransactionsAPI =
   GetTransactionsAPI

marlowe-runtime-web/src/Language/Marlowe/Runtime/Web/Client.hs

@@ -7,6 +7,12 @@ module Language.Marlowe.Runtime.Web.Client (
   Page (..),
   getContract,
   getContractNext,
+  getContractSource,
+  getContractSourceAdjacency,
+  getContractSourceAdjacencyStatus,
+  getContractSourceClosure,
+  getContractSourceClosureStatus,
+  getContractSourceStatus,
   getContractStatus,
   getContracts,
   getContractsStatus,
@@ -53,6 +59,7 @@ import Data.Time (UTCTime)
 import Data.Version (Version)
 import GHC.TypeLits (KnownSymbol, symbolVal)
 import Language.Marlowe.Core.V1.Next
+import Language.Marlowe.Core.V1.Semantics.Types (Contract)
 import Language.Marlowe.Object.Types (Label, ObjectBundle)
 import Language.Marlowe.Runtime.Web.API (
   API,
@@ -199,7 +206,7 @@ postContractSourceStatus
 postContractSourceStatus main bundles = do
   let contractsClient :<|> _ = client
   let _ :<|> _ :<|> _ :<|> contractSourcesClient = contractsClient
-  let postContractSource' = contractSourcesClient
+  let postContractSource' :<|> _ = contractSourcesClient
   response <- postContractSource' main bundles
   status <- extractStatus response
   pure (status, getResponse response)
@@ -210,6 +217,45 @@ postContractSource
   -> ClientM PostContractSourceResponse
 postContractSource = (fmap . fmap) snd . postContractSourceStatus
 
+getContractSourceStatus :: ContractSourceId -> Bool -> ClientM (RuntimeStatus, Contract)
+getContractSourceStatus contractSourceId expand = do
+  let contractsClient :<|> _ = client
+  let _ :<|> _ :<|> _ :<|> contractSourcesClient = contractsClient
+  let _ :<|> contractSourceClient = contractSourcesClient
+  let getContractSource' :<|> _ = contractSourceClient contractSourceId
+  response <- getContractSource' expand
+  status <- extractStatus response
+  pure (status, getResponse response)
+
+getContractSource :: ContractSourceId -> Bool -> ClientM Contract
+getContractSource = (fmap . fmap) snd . getContractSourceStatus
+
+getContractSourceAdjacencyStatus :: ContractSourceId -> ClientM (RuntimeStatus, Set ContractSourceId)
+getContractSourceAdjacencyStatus contractSourceId = do
+  let contractsClient :<|> _ = client
+  let _ :<|> _ :<|> _ :<|> contractSourcesClient = contractsClient
+  let _ :<|> contractSourceClient = contractSourcesClient
+  let _ :<|> getContractSourceAdjacency' :<|> _ = contractSourceClient contractSourceId
+  response <- getContractSourceAdjacency'
+  status <- extractStatus response
+  pure (status, Set.fromList $ results $ getResponse response)
+
+getContractSourceAdjacency :: ContractSourceId -> ClientM (Set ContractSourceId)
+getContractSourceAdjacency = fmap snd . getContractSourceAdjacencyStatus
+
+getContractSourceClosureStatus :: ContractSourceId -> ClientM (RuntimeStatus, Set ContractSourceId)
+getContractSourceClosureStatus contractSourceId = do
+  let contractsClient :<|> _ = client
+  let _ :<|> _ :<|> _ :<|> contractSourcesClient = contractsClient
+  let _ :<|> contractSourceClient = contractSourcesClient
+  let _ :<|> _ :<|> getContractSourceClosure' = contractSourceClient contractSourceId
+  response <- getContractSourceClosure'
+  status <- extractStatus response
+  pure (status, Set.fromList $ results $ getResponse response)
+
+getContractSourceClosure :: ContractSourceId -> ClientM (Set ContractSourceId)
+getContractSourceClosure = fmap snd . getContractSourceClosureStatus
+
 getContractStatus :: TxOutRef -> ClientM (RuntimeStatus, ContractState)
 getContractStatus contractId = do
   let contractsClient :<|> _ = client

marlowe-runtime/changelog.d/20230713_102217_jhbertra_plt_6343_get_contract_sources.md

@@ -0,0 +1,3 @@
+### Added
+
+- `/contracts/sources/:contractSourceId` endpoint with `GET` method and two sub-resources for `adjacency` and `closure`.