diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Test/Script.hs b/marlowe-cli/src/Language/Marlowe/CLI/Test/Script.hs index 3d3c9ea706..d2b0f40150 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Test/Script.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Test/Script.hs @@ -32,7 +32,8 @@ import Cardano.Api (AlonzoEra, CardanoMode, LocalNodeConnectInfo (..), NetworkId import Control.Monad (void) import Control.Monad.Except (MonadError, MonadIO, catchError, liftIO, throwError) import Control.Monad.State.Strict (MonadState, execStateT, get) -import Language.Marlowe.CLI.Test.Types (ScriptOperation (..), ScriptTest (..), TransactionNickname) +import Language.Marlowe.CLI.Test.Types (ScriptContract (InlineContract, TemplateContract), ScriptOperation (..), + ScriptTest (..), TransactionNickname) import Language.Marlowe.CLI.Types (CliError (..), MarloweTransaction (MarloweTransaction)) import Plutus.V1.Ledger.Api (CostModelParams) @@ -86,13 +87,17 @@ interpret Initialize {..} = do marloweParams = Client.marloweParams parsedRoleCurrency marloweState = initialMarloweState soOwner soMinAda + testContract <- case soContract of + InlineContract contract -> pure contract + TemplateContract _ -> throwError $ CliError "Not implemented yet" + transaction <- initializeTransactionImpl marloweParams seSlotConfig seConstModelParams seNetworkId NoStakeAddress - soContract + testContract marloweState True True diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Test/Types.hs b/marlowe-cli/src/Language/Marlowe/CLI/Test/Types.hs index 583e048c20..a957deeec8 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Test/Types.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Test/Types.hs @@ -21,6 +21,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module Language.Marlowe.CLI.Test.Types ( @@ -29,6 +30,20 @@ module Language.Marlowe.CLI.Test.Types ( , ScriptTest(..) , ScriptOperation(..) , TransactionNickname +, ScriptContract(..) + +-- * Lenses +, psFaucetKey +, psFaucetAddress +, psBurnAddress +, psPassphrase +, psWallets +, psAppInstances +, psFollowerInstances +, psCompanionInstances +, prComparison +, prRetry +, comparisonJSON ) where @@ -51,6 +66,8 @@ import Control.Lens.Combinators (Lens') import Control.Lens.Lens (lens) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import qualified Data.Aeson as A (Value (..)) +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict import qualified Data.Map.Strict as M (Map) import Data.Maybe (fromMaybe) import Data.Text @@ -58,6 +75,7 @@ import GHC.Generics (Generic) import Language.Marlowe.Core.V1.Semantics.Types (Contract, State) import Ledger (CurrencySymbol) import Options.Applicative (optional) +import qualified Test.QuickCheck.Property as Aeson -- | Configuration for a set of Marlowe tests. @@ -91,6 +109,37 @@ data ScriptTest = deriving anyclass (FromJSON, ToJSON) +-- | An on- and off-chain test of the Marlowe contracts, via the Marlowe PAB. +data PabTest = + PabTest + { + ptTestName :: String -- ^ The name of the test. + , ptPabOperations :: [PabOperation] -- ^ The sequence of test operations. + } + deriving stock (Eq, Generic, Show) + deriving anyclass (FromJSON, ToJSON) + + +type TransactionNickname = String + +data ScriptContract = InlineContract Contract | TemplateContract String + deriving stock (Eq, Generic, Show) + +instance ToJSON ScriptContract where + toJSON (InlineContract c) = Aeson.object [("inline", toJSON c)] + toJSON (TemplateContract templateName) = Aeson.object [("template", toJSON templateName)] + +instance FromJSON ScriptContract where + parseJSON json = case json of + Aeson.Object (Data.HashMap.Strict.toList -> [("inline", contractJson)]) -> do + parsedContract <- parseJSON contractJson + pure $ InlineContract parsedContract + Aeson.Object (Data.HashMap.Strict.toList -> [("template", templateNameJson)]) -> do + parsedTemplateName <- parseJSON templateNameJson + pure $ TemplateContract parsedTemplateName + _ -> fail "Expected object with a single field of either `inline` or `template`" + + -- | On-chain test operations for the Marlowe contract and payout validators. data ScriptOperation = Initialize @@ -99,7 +148,7 @@ data ScriptOperation = , soMinAda :: Integer , soTransaction :: TransactionNickname -- ^ The name of the wallet's owner. , soRoleCurrency :: Text -- ^ We derive - , soContract :: Contract -- ^ The Marlowe contract to be created. + , soContract :: ScriptContract -- ^ The Marlowe contract to be created. -- | FIXME: No *JSON instances for this -- , soStake :: Maybe StakeAddressReference } diff --git a/marlowe-cli/test/test-nonpab-script.yaml b/marlowe-cli/test/test-nonpab-script.yaml index 3ff59e5aff..22caa6815b 100644 --- a/marlowe-cli/test/test-nonpab-script.yaml +++ b/marlowe-cli/test/test-nonpab-script.yaml @@ -9,25 +9,26 @@ stScriptOperations: soRoleCurrency: "1c964b2b89b6c9d2a8e2d564a3541b3b355d0451825ad0481a63f86c" soMinAda: 1000000 soContract: - when: - - case: - party: - role_token: PAB - deposits: 15000000 - into_account: - role_token: PAB - of_token: - currency_symbol: '' - token_name: '' - then: - when: - - case: - notify_if: true - then: close - timeout: 1961123625000 - timeout_continuation: close - timeout: 1929587625000 - timeout_continuation: close + inline: + when: + - case: + party: + role_token: PAB + deposits: 15000000 + into_account: + role_token: PAB + of_token: + currency_symbol: '' + token_name: '' + then: + when: + - case: + notify_if: true + then: close + timeout: 1961123625000 + timeout_continuation: close + timeout: 1929587625000 + timeout_continuation: close - tag: Prepare soTransaction: "TestTransaction-1"