Merge pull request #622 from input-output-hk/PLT-5817

PLT-3564 PLT-6070 PLT-6071 PLT-6072 PLT-6073 PLT-5817 Safety checks for REST and CLI

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

@@ -11,6 +11,7 @@ import Control.Monad.Trans.Except (ExceptT (ExceptT), throwE)
 import Data.Aeson (FromJSON, toJSON)
 import qualified Data.Aeson as A
 import Data.Bifunctor (bimap, first)
+import qualified Data.ByteString.Char8 as BS8
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -19,6 +20,7 @@ import qualified Data.Yaml as Yaml
 import Data.Yaml.Aeson (decodeFileEither)
 import GHC.Generics (Generic)
 import Language.Marlowe (POSIXTime (POSIXTime))
+import Language.Marlowe.Analysis.Safety.Types (SafetyError)
 import Language.Marlowe.Runtime.CLI.Command.Tx (SigningMethod (Manual), TxCommand (..), txCommandParser)
 import Language.Marlowe.Runtime.CLI.Monad (CLI, runCLIExceptT)
 import Language.Marlowe.Runtime.CLI.Option (keyValueOption, marloweVersionParser, parseAddress)
@@ -52,6 +54,7 @@ import Language.Marlowe.Runtime.Transaction.Api (
  )
 import Options.Applicative
 import Options.Applicative.NonEmpty (some1)
+import System.IO (hPutStrLn, stderr)
 import Text.Read (readMaybe)
 
 data CreateCommand = CreateCommand
@@ -215,7 +218,13 @@ runCreateCommand TxCommand{walletAddresses, signingMethod, tagsFile, metadataFil
         case Map.toList configMap of
           [] -> throwE $ RolesConfigFileDecodingError "Empty role token config"
           (x : xs) -> pure $ RoleTokensMint $ mkMint $ fmap (\RoleConfig{..} -> (address, Just metadata)) <$> x :| xs
-    ContractId contractId <- run MarloweV1 minting'
+    (ContractId contractId, safetyErrors) <- run MarloweV1 minting'
+    liftIO $
+      if null safetyErrors
+        then hPutStrLn stderr "Safety analysis found no errors in the contract."
+        else do
+          hPutStrLn stderr "Safety analysis found the following errors in the contract:"
+          BS8.hPutStrLn stderr $ Yaml.encode safetyErrors
     liftIO . print $ A.encode (A.object [("contractId", toJSON . renderTxOutRef $ contractId)])
   where
     readContract :: MarloweVersion v -> ExceptT (CreateCommandError v) CLI (Either (Contract v) DatumHash)
@@ -243,14 +252,14 @@ runCreateCommand TxCommand{walletAddresses, signingMethod, tagsFile, metadataFil
           pure $ MarloweMetadata tags Nothing
       Nothing -> pure Nothing
 
-    run :: MarloweVersion v -> RoleTokensConfig -> ExceptT (CreateCommandError v) CLI ContractId
+    run :: MarloweVersion v -> RoleTokensConfig -> ExceptT (CreateCommandError v) CLI (ContractId, [SafetyError])
     run version rolesDistribution = do
       contract <- readContract version
       metadata <- MarloweTransactionMetadata <$> readTags <*> readMetadata
-      ContractCreated{contractId, txBody} <-
+      ContractCreated{contractId, txBody, safetyErrors} <-
         ExceptT $
           first CreateFailed <$> createContract Nothing version walletAddresses rolesDistribution metadata minUTxO contract
       case signingMethod of
         Manual outputFile -> do
           ExceptT $ liftIO $ first TransactionFileWriteFailed <$> C.writeFileTextEnvelope outputFile Nothing txBody
-          pure contractId
+          pure (contractId, safetyErrors)

marlowe-runtime-web/changelog.d/20230620_075747_brian.bush_PLT_5817.md

@@ -0,0 +1,3 @@
+### Added
+
+- Results of contract's safety analysis reported in create response.

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

@@ -74,6 +74,7 @@ library
     , network-uri >=2.6 && <3
     , openapi3 >=3.2 && <4
     , parsec ^>=3.1.14
+    , plutus-ledger-api
     , servant ^>=0.19
     , servant-client ^>=0.19
     , servant-client-core ^>=0.19

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

@@ -12,6 +12,7 @@ import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import qualified Data.Set as Set
 import Data.Text (Text)
+import Language.Marlowe.Analysis.Safety.Types (SafetyError)
 import Language.Marlowe.Protocol.Query.Types (ContractFilter (..), Page (..))
 import Language.Marlowe.Runtime.ChainSync.Api (Lovelace (..))
 import Language.Marlowe.Runtime.Core.Api (
@@ -58,7 +59,7 @@ postCreateTxBody
   -> Address
   -> Maybe (CommaList Address)
   -> Maybe (CommaList TxOutRef)
-  -> ServerM (ContractId, TxBody BabbageEra)
+  -> ServerM (ContractId, TxBody BabbageEra, [SafetyError])
 postCreateTxBody PostContractsRequest{..} changeAddressDTO mAddresses mCollateralUtxos = do
   SomeMarloweVersion v@MarloweV1 <- fromDTOThrow (badRequest' "Unsupported Marlowe version") version
   changeAddress <- fromDTOThrow (badRequest' "Invalid change address value") changeAddressDTO
@@ -75,7 +76,7 @@ postCreateTxBody PostContractsRequest{..} changeAddressDTO mAddresses mCollatera
       if Map.null tags then Nothing else Just (tags, Nothing)
   createContract Nothing v WalletAddresses{..} roles' MarloweTransactionMetadata{..} (Lovelace minUTxODeposit) contract >>= \case
     Left err -> throwDTOError err
-    Right ContractCreated{contractId, txBody} -> pure (contractId, txBody)
+    Right ContractCreated{contractId, txBody, safetyErrors} -> pure (contractId, txBody, safetyErrors)
 
 postCreateTxBodyResponse
   :: PostContractsRequest
@@ -84,9 +85,9 @@ postCreateTxBodyResponse
   -> Maybe (CommaList TxOutRef)
   -> ServerM (PostContractsResponse CardanoTxBody)
 postCreateTxBodyResponse req changeAddressDTO mAddresses mCollateralUtxos = do
-  res <- postCreateTxBody req changeAddressDTO mAddresses mCollateralUtxos
-  let (contractId', txBody') = toDTO res
-  let body = CreateTxEnvelope contractId' txBody'
+  (contractId, txBody, safetyErrors) <- postCreateTxBody req changeAddressDTO mAddresses mCollateralUtxos
+  let (contractId', txBody') = toDTO (contractId, txBody)
+  let body = CreateTxEnvelope contractId' txBody' safetyErrors
   pure $ IncludeLink (Proxy @"contract") body
 
 postCreateTxResponse
@@ -96,10 +97,10 @@ postCreateTxResponse
   -> Maybe (CommaList TxOutRef)
   -> ServerM (PostContractsResponse CardanoTx)
 postCreateTxResponse req changeAddressDTO mAddresses mCollateralUtxos = do
-  (contractId, txBody) <- postCreateTxBody req changeAddressDTO mAddresses mCollateralUtxos
+  (contractId, txBody, safetyErrors) <- postCreateTxBody req changeAddressDTO mAddresses mCollateralUtxos
   let tx = makeSignedTransaction [] txBody
   let (contractId', tx') = toDTO (contractId, tx)
-  let body = CreateTxEnvelope contractId' tx'
+  let body = CreateTxEnvelope contractId' tx' safetyErrors
   pure $ IncludeLink (Proxy @"contract") body
 
 get