PLT-5854 create by hash

marlowe-apps/src/Language/Marlowe/Runtime/App/Build.hs

@@ -61,7 +61,7 @@ buildCreation version' contract roles minUtxo metadata' =
         else RoleTokensMint . mkMint . fmap (second (, Nothing)) . NE.fromList . M.toList $ roles
   in
     build show (\ContractCreated{..} -> (contractId, txBody))
-      $ \w -> Create Nothing version' w roles' metadata' minUtxo contract
+      $ \w -> Create Nothing version' w roles' metadata' minUtxo $ Left contract
 
 
 buildApplication

marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Runtime/Interpret.hs

@@ -421,7 +421,7 @@ interpret ro@RuntimeCreateContract {..} = do
           , collateralUtxos = mempty
           }
 
-      Marlowe.Class.createContract Nothing MarloweV1 walletAddresses roleTokensConfig emptyMarloweTransactionMetadata minLovelace contract
+      Marlowe.Class.createContract Nothing MarloweV1 walletAddresses roleTokensConfig emptyMarloweTransactionMetadata minLovelace $ Left contract
     era <- view eraL
     case result of
       Right Transaction.ContractCreated { txBody, contractId } -> do
@@ -537,4 +537,3 @@ interpret ro@RuntimeApplyInputs {..} = do
             throwLabeledError ro $ runtimeOperationFailed' $ "Failed to submit contract: " <> show err
       Left err ->
         throwLabeledError ro $ runtimeOperationFailed' $ "Failed to create contract: " <> show err
-

marlowe-client/src/Control/Monad/Trans/Marlowe/Class.hs

@@ -114,8 +114,8 @@ createContract
   -- ^ Optional metadata to attach to the transaction
   -> Lovelace
   -- ^ Min Lovelace which should be used for the contract output.
-  -> Contract v
-  -- ^ The contract to run
+  -> Either (Contract v) DatumHash
+  -- ^ The contract to run, or the hash of the contract to look up in the store.
   -> m (Either (CreateError v) (ContractCreated BabbageEra v))
 createContract mStakeCredential version wallet roleTokens metadata lovelace contract =
   runMarloweTxClient $ liftCommand $ Create

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

@@ -126,8 +126,8 @@ marloweRuntimeJobClient = \case
       Left err -> error ("Some JobClient withdraw error: " <> show err)
       Right txBody -> pure txBody
 
-expectSameResultFromCLIandJobClient :: String -> [String] -> MarloweTxCommand Void err result -> Integration ()
-expectSameResultFromCLIandJobClient outputFile extraCliArgs command = do
+expectSameResultFromCLIAndJobClient :: String -> [String] -> MarloweTxCommand Void err result -> Integration ()
+expectSameResultFromCLIAndJobClient outputFile extraCliArgs command = do
   workspace <- Reader.asks $ workspace . testnet
 
   let
@@ -225,9 +225,9 @@ createSpec = describe "create" $
           Runtime.Transaction.Api.RoleTokensNone
           md
           (ChainSync.Api.Lovelace 2_000_000)
-          contract
+          (Left contract)
 
-    expectSameResultFromCLIandJobClient "create-tx-body.json" extraCliArgs creationCommand
+    expectSameResultFromCLIAndJobClient "create-tx-body.json" extraCliArgs creationCommand
 
 depositSpec :: Hspec.SpecWith CLISpecTestData
 depositSpec = describe "deposit" $
@@ -257,7 +257,7 @@ depositSpec = describe "deposit" $
           Runtime.Transaction.Api.mkMint $ pure ("Party A", (changeAddress $ addresses partyAWallet, Nothing)))
         (standardMetadata tags)
         2_000_000
-        contract
+        (Left contract)
 
     _ <- Runtime.Integration.Common.submit partyAWallet txBody
 
@@ -279,7 +279,7 @@ depositSpec = describe "deposit" $
           Nothing
           [V1.NormalInput $ V1.IDeposit partyA partyA ada 100_000_000]
 
-    expectSameResultFromCLIandJobClient "deposit-tx-body.json" extraCliArgs command
+    expectSameResultFromCLIAndJobClient "deposit-tx-body.json" extraCliArgs command
 
 chooseSpec :: Hspec.SpecWith CLISpecTestData
 chooseSpec = describe "choose" $
@@ -309,7 +309,7 @@ chooseSpec = describe "choose" $
           Runtime.Transaction.Api.mkMint $ pure ("Party A", (changeAddress $ addresses partyAWallet, Nothing)))
         (standardMetadata tags)
         2_000_000
-        contract
+        (Left contract)
 
     _ <- Runtime.Integration.Common.submit partyAWallet txBody
 
@@ -331,7 +331,7 @@ chooseSpec = describe "choose" $
           Nothing
           [V1.NormalInput $ V1.IChoice (V1.ChoiceId "my choice" partyA) 0]
 
-    expectSameResultFromCLIandJobClient "choose-tx-body.json" extraCliArgs command
+    expectSameResultFromCLIAndJobClient "choose-tx-body.json" extraCliArgs command
 
 notifySpec :: Hspec.SpecWith CLISpecTestData
 notifySpec = describe "notify" $
@@ -358,7 +358,7 @@ notifySpec = describe "notify" $
           Runtime.Transaction.Api.mkMint $ pure ("Party A", (changeAddress $ addresses partyAWallet, Nothing)))
         (standardMetadata tags)
         2_000_000
-        contract
+        (Left contract)
 
     _ <- Runtime.Integration.Common.submit partyAWallet txBody
 
@@ -380,7 +380,7 @@ notifySpec = describe "notify" $
           Nothing
           [V1.NormalInput V1.INotify]
 
-    expectSameResultFromCLIandJobClient "notify-tx-body.json" extraCliArgs command
+    expectSameResultFromCLIAndJobClient "notify-tx-body.json" extraCliArgs command
 
 applySpec :: Hspec.SpecWith CLISpecTestData
 applySpec = describe "apply" $
@@ -429,7 +429,7 @@ applySpec = describe "apply" $
           Runtime.Transaction.Api.mkMint $ pure ("Party A", (changeAddress $ addresses partyAWallet, Nothing)))
         (standardMetadata tags)
         2_000_000
-        contract
+        (Left contract)
 
     _ <- Runtime.Integration.Common.submit partyAWallet txBody
 
@@ -455,7 +455,7 @@ applySpec = describe "apply" $
           Nothing
           inputs
 
-    expectSameResultFromCLIandJobClient "deposit-choose-notify-tx-body.json" extraCliArgs command
+    expectSameResultFromCLIAndJobClient "deposit-choose-notify-tx-body.json" extraCliArgs command
 
 withdrawSpec :: Hspec.SpecWith CLISpecTestData
 withdrawSpec = describe "withdraw" $
@@ -485,7 +485,7 @@ withdrawSpec = describe "withdraw" $
           Runtime.Transaction.Api.mkMint $ pure ("Party A", (changeAddress $ addresses partyAWallet, Nothing)))
         (standardMetadata tags)
         2_000_000
-        contract
+        (Left contract)
 
     _ <- Runtime.Integration.Common.submit partyAWallet txBody
 
@@ -520,4 +520,4 @@ withdrawSpec = describe "withdraw" $
           contractId
           "Party A"
 
-    expectSameResultFromCLIandJobClient "withdraw-tx-body.json" extraCliArgs command
+    expectSameResultFromCLIAndJobClient "withdraw-tx-body.json" extraCliArgs command

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

@@ -74,7 +74,7 @@ closedSpec = parallel $ describe "Closed contract" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          Close
+          (Left Close)
       _ <- submit wallet createBody
       InputsApplied { txBody = applyBody } <-
         expectRight "Failed to close contract" =<< applyInputs
@@ -127,7 +127,7 @@ closeSpec = parallel $ describe "Close contract" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          Close
+          (Left Close)
       _ <- submit wallet createBody
       inputsApplied <- expectRight "Failed to close contract" =<< applyInputs
         MarloweV1
@@ -271,7 +271,7 @@ paySpec = parallel $ describe "Pay contracts" $ aroundAll setup do
           (mkRoleTokens [("Role", wallet2)])
           emptyMarloweTransactionMetadata
           2_000_000
-          (mkPay (Account $ Role "Role") ada (Constant 2_000_000) Close)
+          (Left $ mkPay (Account $ Role "Role") ada (Constant 2_000_000) Close)
       submitCreate wallet1 payRoleAccountCreated
       payAddressAccountCreated <-
         expectRight "Failed to create pay address account contract" =<< createContract
@@ -281,7 +281,7 @@ paySpec = parallel $ describe "Pay contracts" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          (mkPay (Account $ walletParty wallet2) ada (Constant 2_000_000) Close)
+          (Left $ mkPay (Account $ walletParty wallet2) ada (Constant 2_000_000) Close)
       submitCreate wallet1 payAddressAccountCreated
       payRolePartyCreated <-
         expectRight "Failed to create pay role party contract" =<< createContract
@@ -291,7 +291,7 @@ paySpec = parallel $ describe "Pay contracts" $ aroundAll setup do
           (mkRoleTokens [("Role", wallet2)])
           emptyMarloweTransactionMetadata
           2_000_000
-          (mkPay (Party $ Role "Role") ada (Constant 2_000_000) Close)
+          (Left $ mkPay (Party $ Role "Role") ada (Constant 2_000_000) Close)
       submitCreate wallet1 payRolePartyCreated
       payAddressPartyCreated <-
         expectRight "Failed to create pay address party contract" =<< createContract
@@ -301,7 +301,7 @@ paySpec = parallel $ describe "Pay contracts" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          (mkPay (Party $ walletParty wallet2) ada (Constant 2_000_000) Close)
+          (Left $ mkPay (Party $ walletParty wallet2) ada (Constant 2_000_000) Close)
       submitCreate wallet1 payAddressPartyCreated
       payDepth1Created <-
         expectRight "Failed to create pay depth 1 contract" =<< createContract
@@ -311,7 +311,7 @@ paySpec = parallel $ describe "Pay contracts" $ aroundAll setup do
           (mkRoleTokens [("Role", wallet2)])
           emptyMarloweTransactionMetadata
           2_000_000
-          (mkPay (Account $ Role "Role") ada (Constant 2_000_000) $
+          (Left $ mkPay (Account $ Role "Role") ada (Constant 2_000_000) $
             When
               [ Case (Notify TrueObs) Close
               ]
@@ -327,7 +327,7 @@ paySpec = parallel $ describe "Pay contracts" $ aroundAll setup do
           (mkRoleTokens [("Role", wallet2)])
           emptyMarloweTransactionMetadata
           10_000_000
-          (mkPay (Account $ Role "Role") ada (Constant 2_000_000) $
+          (Left $ mkPay (Account $ Role "Role") ada (Constant 2_000_000) $
             When
               [ Case (Notify TrueObs) $
                   When
@@ -348,7 +348,7 @@ paySpec = parallel $ describe "Pay contracts" $ aroundAll setup do
           (mkRoleTokens [("Role", wallet2)])
           emptyMarloweTransactionMetadata
           10_000_000
-          (mkPay (Party $ Role "Role") ada (Constant 2_000_000) $
+          (Left $ mkPay (Party $ Role "Role") ada (Constant 2_000_000) $
             When
               [ Case (Notify TrueObs) $
                   When
@@ -467,7 +467,7 @@ whenTimeoutSpec = parallel $ describe "Timed out contracts" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          (When [Case (Notify TrueObs) Close] (utcTimeToPOSIXTime startTime) Close)
+          (Left $ When [Case (Notify TrueObs) Close] (utcTimeToPOSIXTime startTime) Close)
       submitCreate wallet depth1Created
       depth2InnerTimeoutCreated <-
         expectRight "Failed to create depth 2 contract" =<< createContract
@@ -477,7 +477,7 @@ whenTimeoutSpec = parallel $ describe "Timed out contracts" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          (When [Case (Notify TrueObs) Close] (utcTimeToPOSIXTime startTime) $
+          (Left $ When [Case (Notify TrueObs) Close] (utcTimeToPOSIXTime startTime) $
              When [] (utcTimeToPOSIXTime startTime) Close
           )
       submitCreate wallet depth2InnerTimeoutCreated
@@ -489,7 +489,7 @@ whenTimeoutSpec = parallel $ describe "Timed out contracts" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          (When [Case (Notify TrueObs) Close] (utcTimeToPOSIXTime startTime) $
+          (Left $ When [Case (Notify TrueObs) Close] (utcTimeToPOSIXTime startTime) $
              When [] (utcTimeToPOSIXTime $ addUTCTime (secondsToNominalDiffTime 200) startTime) Close
           )
       submitCreate wallet depth2Created
@@ -566,7 +566,7 @@ whenEmptySpec = parallel $ describe "Empty When contracts" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          (When [] (utcTimeToPOSIXTime $ addUTCTime (secondsToNominalDiffTime 200) startTime) Close)
+          (Left $ When [] (utcTimeToPOSIXTime $ addUTCTime (secondsToNominalDiffTime 200) startTime) Close)
       submitCreate wallet ContractCreated{..}
       runtime <- ask
       liftIO $ runTests (runtime, contractId)
@@ -802,7 +802,7 @@ whenNonEmptySpec = parallel $ describe "Non-Empty When contracts" $ aroundAll se
           (mkRoleTokens [("Role1", wallet1), ("Role2", wallet2)])
           emptyMarloweTransactionMetadata
           2_000_000
-          (When cases (utcTimeToPOSIXTime $ addUTCTime (secondsToNominalDiffTime 100) startTime) Close)
+          (Left $ When cases (utcTimeToPOSIXTime $ addUTCTime (secondsToNominalDiffTime 100) startTime) Close)
       submitCreate wallet1 contract
       runtime <- ask
       liftIO $ runTests (runtime, contract)
@@ -852,7 +852,7 @@ merkleizedSpec = parallel $ describe "Merkleized contracts" $ aroundAll setup do
           RoleTokensNone
           emptyMarloweTransactionMetadata
           2_000_000
-          (When [MerkleizedCase (Notify TrueObs) hash] (utcTimeToPOSIXTime $ addUTCTime (secondsToNominalDiffTime 100) startTime) Close)
+          (Left $ When [MerkleizedCase (Notify TrueObs) hash] (utcTimeToPOSIXTime $ addUTCTime (secondsToNominalDiffTime 100) startTime) Close)
       submitCreate wallet contract
       runtime <- ask
       liftIO $ runTests (runtime, let ContractCreated{..} = contract in contractId)
@@ -902,7 +902,7 @@ multiInputsSpec = parallel $ describe "Multi inputs" $ aroundAll setup do
           (mkRoleTokens [("role", wallet)])
           emptyMarloweTransactionMetadata
           2_000_000
-          (When [Case action1 $ When [Case action2 Close] timeout Close, Case action2 $ When [Case action1 Close] timeout Close] timeout Close)
+          (Left $ When [Case action1 $ When [Case action2 Close] timeout Close, Case action2 $ When [Case action1 Close] timeout Close] timeout Close)
       submitCreate wallet contract
       runtime <- ask
       liftIO $ runTests (runtime, let ContractCreated{..} = contract in (startTime, contractId))

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

@@ -291,7 +291,7 @@ mkCreateCommand testData (CreateCase stakeCredential wallet (roleTokens, metadat
   (mkRoleTokensConfig testData roleTokens)
   (mkMarloweTxMetadata metadata)
   (mkMinLovelace minLovelace)
-  (mkContract roleTokens)
+  (Left $ mkContract roleTokens)
 
 mkStakeCredential :: TestData -> StakeCredentialCase -> Maybe StakeCredential
 mkStakeCredential TestData{..} = \case

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

@@ -15,8 +15,7 @@ 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, runContractQueryClient, runMarloweLoadClient)
-import qualified Language.Marlowe.Runtime.Contract.Api as Contract
+import Language.Marlowe.Runtime.Client (createContract, runMarloweLoadClient)
 import Language.Marlowe.Runtime.Core.Api
   ( ContractId
   , MarloweMetadata(..)
@@ -89,8 +88,6 @@ createStandardContractWithTags tags partyAWallet partyBWallet = do
   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
@@ -106,7 +103,7 @@ createStandardContractWithTags tags partyAWallet partyBWallet = do
           }
     )
     2_000_000
-    contract'
+    (Right contractHash)
   contractCreated@ContractCreated{contractId, txBody = createTxBody} <- expectRight "failed to create standard contract" result
   createdBlock <- submit partyAWallet createTxBody
 

marlowe-runtime-cli/app/Language/Marlowe/Runtime/CLI/Command/Create.hs

@@ -10,7 +10,7 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except (ExceptT(ExceptT), throwE)
 import Data.Aeson (FromJSON, toJSON)
 import qualified Data.Aeson as A
-import Data.Bifunctor (first)
+import Data.Bifunctor (bimap, first)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -24,6 +24,7 @@ import Language.Marlowe.Runtime.CLI.Monad (CLI, runCLIExceptT)
 import Language.Marlowe.Runtime.CLI.Option (keyValueOption, marloweVersionParser, parseAddress)
 import Language.Marlowe.Runtime.ChainSync.Api
   ( Address
+  , DatumHash
   , Lovelace(Lovelace)
   , PolicyId
   , TokenName(..)
@@ -69,6 +70,7 @@ data RolesConfig
 data ContractFiles
   = CoreFile FilePath
   | ExtendedFiles FilePath ContractArgs
+  | ContractHash DatumHash
 
 data ContractArgs
   = ContractArgsByFile FilePath
@@ -121,12 +123,17 @@ createCommandParser = info (txCommandParser True parser) $ progDesc "Create a ne
       , help "The name of a role in the contract with the address to send the token to"
       , metavar "ROLE=ADDRESS"
       ]
-    contractFilesParser = CoreFile <$> coreParser <|> extendedParser
+    contractFilesParser = CoreFile <$> coreParser <|> extendedParser <|> ContractHash <$> contractHashParser
     coreParser = strOption $ mconcat
       [ long "core-file"
       , help "A file containing the Core Marlowe JSON definition of the contract to create."
       , metavar "FILE_PATH"
       ]
+    contractHashParser = strOption $ mconcat
+      [ long "contract-hash"
+      , help "The hash of a contract in the contract store to create."
+      , metavar "BASE_16"
+      ]
     extendedParser = ExtendedFiles <$> extendedFileParser <*> contractArgsParser
     extendedFileParser = strOption $ mconcat
       [ long "contract-file"
@@ -179,13 +186,14 @@ runCreateCommand TxCommand { walletAddresses, signingMethod, tagsFile, metadataF
     ContractId contractId <- run MarloweV1 minting'
     liftIO . print $ A.encode (A.object [("contractId", toJSON . renderTxOutRef $ contractId)])
   where
-    readContract :: MarloweVersion v -> ExceptT (CreateCommandError v) CLI (Contract v)
+    readContract :: MarloweVersion v -> ExceptT (CreateCommandError v) CLI (Either (Contract v) DatumHash)
     readContract = \case
       MarloweV1 -> case contractFiles of
-        CoreFile filePath -> ExceptT $ liftIO $ first ContractFileDecodingError <$> decodeFileEither filePath
+        CoreFile filePath -> ExceptT $ liftIO $ bimap ContractFileDecodingError Left <$> decodeFileEither filePath
         ExtendedFiles _ _ -> do
           -- extendedContract <- ExceptT $ liftIO $ first (ContractFileDecodingError . Just) <$> decodeFileEither filePath
           throwE ExtendedContractsAreNotSupportedYet
+        ContractHash hash -> pure $ Right hash
 
     readMetadata :: ExceptT (CreateCommandError v) CLI TransactionMetadata
     readMetadata = case metadataFile of

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

@@ -152,6 +152,7 @@ instance ToDTO (CreateError 'V1) where
     CreateBuildupFailed (MintingScriptDecodingFailed _) -> ApiError "Internal error" "MintingScriptDecodingFailed" Null 500
     CreateToCardanoError -> ApiError "Internal error" "CreateToCardanoError" Null 400
     CreateSafetyAnalysisError _ -> ApiError "Safety analysis failed" "InternalError" Null 400
+    CreateContractNotFound -> ApiError "Contract not found" "Not found" Null 404
 
 instance HasDTO (ApplyInputsError 'V1) where
   type DTO (ApplyInputsError 'V1) = ApiError