SCP-4327 implement inline contract type, including parsing json

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

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,13 +66,16 @@ 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
 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
     }

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"