From 00ab3f87d439771e0f9c2fc4a17f04e595c7699d Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Fri, 8 Dec 2023 13:37:36 -0500 Subject: [PATCH 1/4] Inline scripts via TH --- marlowe/marlowe-cardano.cabal | 2 + marlowe/src/Language/Marlowe/Scripts.hs | 16 +++++++ marlowe/src/Language/Marlowe/Scripts/Types.hs | 46 +++++++++++++++++++ 3 files changed, 64 insertions(+) create mode 100644 marlowe/src/Language/Marlowe/Scripts.hs diff --git a/marlowe/marlowe-cardano.cabal b/marlowe/marlowe-cardano.cabal index 4be974a0d7..6971844db4 100644 --- a/marlowe/marlowe-cardano.cabal +++ b/marlowe/marlowe-cardano.cabal @@ -78,6 +78,7 @@ library , range ==0.3.0.2 , sbv ^>=9.2 , scientific ^>=0.3.7 + , template-haskell , text ^>=1.2 , time >=1.9.3 && <2 , transformers ^>=0.5.6 @@ -109,6 +110,7 @@ library Language.Marlowe.FindInputs Language.Marlowe.ParserUtil Language.Marlowe.Pretty + Language.Marlowe.Scripts Language.Marlowe.Scripts.Types Language.Marlowe.Util Paths_marlowe_cardano diff --git a/marlowe/src/Language/Marlowe/Scripts.hs b/marlowe/src/Language/Marlowe/Scripts.hs new file mode 100644 index 0000000000..3b3f7bf283 --- /dev/null +++ b/marlowe/src/Language/Marlowe/Scripts.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Language.Marlowe.Scripts where + +import Cardano.Api (PlutusScript, PlutusScriptV2) +import Language.Marlowe.Scripts.Types (readPlutusScript) + +marloweValidator :: PlutusScript PlutusScriptV2 +marloweValidator = $(readPlutusScript "marlowe/scripts/marlowe-semantics.plutus") + +payoutValidator :: PlutusScript PlutusScriptV2 +payoutValidator = $(readPlutusScript "marlowe/scripts/marlowe-rolepayout.plutus") + +openRolesValidator :: PlutusScript PlutusScriptV2 +openRolesValidator = $(readPlutusScript "marlowe/scripts/open-role.plutus") diff --git a/marlowe/src/Language/Marlowe/Scripts/Types.hs b/marlowe/src/Language/Marlowe/Scripts/Types.hs index 012b78b851..3a739ba253 100644 --- a/marlowe/src/Language/Marlowe/Scripts/Types.hs +++ b/marlowe/src/Language/Marlowe/Scripts/Types.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} -- | Marlowe validators. @@ -20,13 +23,25 @@ module Language.Marlowe.Scripts.Types ( -- * Utilities marloweTxInputsFromInputs, + + -- * TH utilities + readPlutusScript, ) where +import Cardano.Api +import Cardano.Api.Shelley (PlutusScript (..)) +import Data.ByteString.Char8 qualified as B8 +import Data.ByteString.Internal qualified as B +import Data.ByteString.Short qualified as SBS +import Data.ByteString.Unsafe qualified as BS import GHC.Generics (Generic) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (qAddDependentFile) import Language.Marlowe.Core.V1.Semantics.Types as Semantics import Language.Marlowe.Pretty (Pretty (..)) import PlutusTx (makeIsDataIndexed, makeLift) import PlutusTx.Prelude as PlutusTxPrelude hiding (traceError, traceIfFalse) +import System.IO.Unsafe (unsafePerformIO) import Prelude qualified as Haskell -- | Input to a Marlowe transaction. @@ -51,3 +66,34 @@ marloweTxInputsFromInputs = fmap marloweTxInputFromInput -- Lifting data types to Plutus Core makeLift ''MarloweTxInput makeIsDataIndexed ''MarloweTxInput [('Input, 0), ('MerkleizedTxInput, 1)] + +readPlutusScript :: Haskell.FilePath -> Q Exp +readPlutusScript fp = do + qAddDependentFile fp + runIO + $ either (Haskell.error . Haskell.show) id + Haskell.<$> readFileTextEnvelopeAnyOf + [ FromSomeType (AsPlutusScript AsPlutusScriptV1) plutusScriptToExpr + , FromSomeType (AsPlutusScript AsPlutusScriptV2) plutusScriptToExpr + , FromSomeType (AsPlutusScript AsPlutusScriptV3) plutusScriptToExpr + ] + (File fp) + +plutusScriptToExpr :: forall lang. (IsPlutusScriptLanguage lang) => PlutusScript lang -> Exp +plutusScriptToExpr (PlutusScriptSerialised (SBS.fromShort -> script)) = + ConE 'PlutusScriptSerialised + `AppTypeE` ConT case plutusScriptVersion @lang of + PlutusScriptV1 -> ''PlutusScriptV1 + PlutusScriptV2 -> ''PlutusScriptV2 + PlutusScriptV3 -> Haskell.error "PlutusScriptV3 type constructor not exposed by cardano-api!" + `AppE` ( AppE (VarE 'SBS.toShort) + $ AppE (VarE 'unsafePerformIO) + $ VarE 'BS.unsafePackAddressLen + `AppE` LitE (IntegerL $ Haskell.fromIntegral $ B8.length script) + `AppE` LitE + ( bytesPrimL + ( let B.PS ptr off sz = script + in mkBytes ptr (Haskell.fromIntegral off) (Haskell.fromIntegral sz) + ) + ) + ) From 56bf7a02795db999a3b1a95a6524e80b6f42cbb8 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 3 Jan 2024 10:45:31 -0500 Subject: [PATCH 2/4] Embed plutus scripts with TH --- .../Marlowe/CLI/Test/CLI/Interpret.hs | 30 ++-- .../Language/Marlowe/CLI/Test/Interpret.hs | 7 +- .../Language/Marlowe/CLI/Test/Runner.hs | 46 +++--- .../Marlowe/CLI/Test/Wallet/Interpret.hs | 6 +- .../Language/Marlowe/CLI/Command/Contract.hs | 16 +-- .../Language/Marlowe/CLI/Command/Role.hs | 5 +- .../Marlowe/CLI/Command/Transaction.hs | 5 +- marlowe-cli/marlowe-cli.cabal | 1 - .../src/Language/Marlowe/CLI/Analyze.hs | 12 +- .../Marlowe/CLI/Cardano/Api/PlutusScript.hs | 26 +--- .../src/Language/Marlowe/CLI/Export.hs | 136 +++++++----------- marlowe-cli/src/Language/Marlowe/CLI/Run.hs | 23 ++- marlowe-cli/src/Language/Marlowe/CLI/Sync.hs | 11 +- .../src/Language/Marlowe/CLI/Transaction.hs | 90 +++++------- marlowe-cli/src/Language/Marlowe/CLI/Types.hs | 36 ++--- .../Runtime/Core/ScriptRegistrySpec.hs | 21 ++- marlowe/src/Language/Marlowe/Scripts.hs | 6 +- 17 files changed, 195 insertions(+), 282 deletions(-) diff --git a/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/CLI/Interpret.hs b/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/CLI/Interpret.hs index d19ecc190a..c490444e97 100644 --- a/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/CLI/Interpret.hs +++ b/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/CLI/Interpret.hs @@ -66,7 +66,6 @@ import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust, mapMaybe, maybeToList) import Data.Text qualified as Text import Data.Traversable (for) -import Language.Marlowe.CLI.Cardano.Api.PlutusScript (IsPlutusScriptLanguage) import Language.Marlowe.CLI.Run ( autoRunTransactionImpl, autoWithdrawFundsImpl, @@ -171,14 +170,13 @@ toOneLineJSON :: forall a. (A.ToJSON a) => a -> String toOneLineJSON = Text.unpack . A.renderValue . A.toJSON autoRunTransaction - :: forall era env lang m st + :: forall era env m st . (IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) - => (InterpretMonad env st m lang era) + => (InterpretMonad env st m C.PlutusScriptV2 era) => Maybe CurrencyNickname -> WalletNickname - -> Maybe (MarloweTransaction lang era, C.TxIn) - -> MarloweTransaction lang era + -> Maybe (MarloweTransaction C.PlutusScriptV2 era, C.TxIn) + -> MarloweTransaction C.PlutusScriptV2 era -> Bool -> m (C.TxBody era, Maybe C.TxIn) autoRunTransaction currency defaultSubmitter prev curr@MarloweTransaction{..} invalid = do @@ -242,7 +240,7 @@ autoRunTransaction currency defaultSubmitter prev curr@MarloweTransaction{..} in OutputQueryResult{oqrMatching = fromUTxO -> (AnUTxO (txIn, _) : _)} -> do let scriptOrReference = validatorInfoScriptOrReference openRoleValidatorInfo redeemer = P.Redeemer $ P.toBuiltinData P.emptyByteString - payFromOpenRole :: PayFromScript lang + payFromOpenRole :: PayFromScript C.PlutusScriptV2 payFromOpenRole = buildPayFromScript scriptOrReference Nothing redeemer txIn pure ([], [payFromOpenRole]) @@ -299,13 +297,12 @@ autoRunTransaction currency defaultSubmitter prev curr@MarloweTransaction{..} in throwError $ testExecutionFailed' "[AutoRun] Multiple Marlowe outputs detected - unable to handle them yet." publishCurrentValidators - :: forall env era lang st m + :: forall env era st m . (C.IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) - => (InterpretMonad env st m lang era) + => (InterpretMonad env st m C.PlutusScriptV2 era) => Maybe Bool -> Maybe WalletNickname - -> m (MarloweScriptsRefs lang era) + -> m (MarloweScriptsRefs C.PlutusScriptV2 era) publishCurrentValidators publishPermanently possiblePublisher = do let walletNickname = fromMaybe faucetNickname possiblePublisher @@ -321,7 +318,7 @@ publishCurrentValidators publishPermanently possiblePublisher = do fnName = "publishCurrentValidators" logTraceMsg' = logStoreLabeledMsg fnName queryCtx = toQueryContext txBuildupCtx - runCli era fnName (findMarloweScriptsRefs @_ @lang queryCtx publishingStrategy printStats) >>= \case + runCli era fnName (findMarloweScriptsRefs @_ queryCtx publishingStrategy printStats) >>= \case Just marloweScriptRefs@(MarloweScriptsRefs (AnUTxO (mTxIn, _), mv) (AnUTxO (pTxIn, _), pv) (AnUTxO (orTxIn, _), orv)) -> do let logValidatorInfo ValidatorInfo{..} = logTraceMsg' $ Text.unpack (C.serialiseAddress viAddress) @@ -353,10 +350,9 @@ publishCurrentValidators publishPermanently possiblePublisher = do pure refs interpret - :: forall env era lang st m + :: forall env era st m . (C.IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) - => (InterpretMonad env st m lang era) + => (InterpretMonad env st m C.PlutusScriptV2 era) => CLIOperation -> m () interpret co@Initialize{..} = do @@ -501,7 +497,7 @@ interpret AutoRun{..} = do drop l whole Nothing -> whole step mTh mt = do - let prev :: Maybe (MarloweTransaction lang era, C.TxIn) + let prev :: Maybe (MarloweTransaction C.PlutusScriptV2 era, C.TxIn) prev = do pmt <- overAnyMarloweThread getCLIMarloweThreadTransaction <$> mTh txIn <- overAnyMarloweThread marloweThreadTxIn =<< mTh @@ -547,7 +543,7 @@ interpret co@Withdraw{..} = do txBuildupCtx <- view txBuildupContextL txBodies <- foldMapMFlipped roles \role -> do let lastWithdrawalCheckPoint = Map.lookup role _ciWithdrawalsCheckPoints - threadTransactions :: [(MarloweTransaction lang era, C.TxId)] + threadTransactions :: [(MarloweTransaction C.PlutusScriptV2 era, C.TxId)] threadTransactions = do let step item acc = (getCLIMarloweThreadTransaction item, C.getTxId . getCLIMarloweThreadTxBody $ item) : acc overAnyMarloweThread (foldrMarloweThread step []) marloweThread diff --git a/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Interpret.hs b/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Interpret.hs index 7b67bb68ef..98d97ec59a 100644 --- a/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Interpret.hs +++ b/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Interpret.hs @@ -8,6 +8,7 @@ module Language.Marlowe.CLI.Test.Interpret where import Cardano.Api (IsShelleyBasedEra) +import Cardano.Api qualified as C import Contrib.Control.Concurrent (threadDelay) import Control.Monad.Except (MonadError (throwError), catchError) import Control.Monad.IO.Class (liftIO) @@ -15,7 +16,6 @@ import Control.Monad.State.Class (get) import Data.Aeson qualified as A import Data.Aeson.OneLine qualified as A import Data.Text qualified as T -import Language.Marlowe.CLI.Cardano.Api.PlutusScript (IsPlutusScriptLanguage) import Language.Marlowe.CLI.Test.CLI.Interpret qualified as CLI import Language.Marlowe.CLI.Test.InterpreterError (testExecutionFailed') import Language.Marlowe.CLI.Test.Log (Label (label), logLabeledMsg, logStoreLabeledMsg, throwLabeledError) @@ -28,10 +28,9 @@ import Language.Marlowe.CLI.Test.Types ( import Language.Marlowe.CLI.Test.Wallet.Interpret qualified as Wallet interpret - :: forall m lang era + :: forall m era . (IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) - => (InterpretMonad m lang era) + => (InterpretMonad m C.PlutusScriptV2 era) => TestOperation -> m () interpret (RuntimeOperation ro) = do diff --git a/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Runner.hs b/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Runner.hs index bd0f894f8e..59448a4751 100644 --- a/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Runner.hs +++ b/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Runner.hs @@ -80,7 +80,6 @@ import Language.Marlowe.CLI.Cardano.Api ( toPlutusProtocolVersion, txOutValueValue, ) -import Language.Marlowe.CLI.Cardano.Api.PlutusScript (IsPlutusScriptLanguage) import Language.Marlowe.CLI.Cardano.Api.Value ( lovelaceToPlutusValue, toPlutusValue, @@ -377,19 +376,18 @@ liftCliEither = liftIO . liftEitherIO . first fromCLIError -- Useful helper to use the interpreter as a part of the test runner. -- We don't run runtime monitor thread here because we don't need it. execWalletOperations - :: forall era lang m resource + :: forall era m resource . (IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) => (MonadIO m) - => (MonadReader (Env lang era resource) m) - => InterpretState lang era + => (MonadReader (Env C.PlutusScriptV2 era resource) m) + => InterpretState C.PlutusScriptV2 era -> [Wallet.WalletOperation] -> m ( Either ( TestRunnerError - , InterpretState lang era + , InterpretState C.PlutusScriptV2 era ) - (InterpretState lang era) + (InterpretState C.PlutusScriptV2 era) ) execWalletOperations interpretState operations = runExceptT @@ -482,12 +480,11 @@ type TestInterpreterM lang era a = -- * `Right` - close the loop imidiatelly. It is a definite result. -- * `Left` - possibly try again. the result is not definite and retry could change it. interpretTest - :: forall lang era + :: forall era . (IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) => [TestOperation] - -> PrevResult (TestResult lang era) (TestResult lang era) - -> TestInterpreterM lang era (Either (TestResult lang era) (TestResult lang era)) + -> PrevResult (TestResult C.PlutusScriptV2 era) (TestResult C.PlutusScriptV2 era) + -> TestInterpreterM C.PlutusScriptV2 era (Either (TestResult C.PlutusScriptV2 era) (TestResult C.PlutusScriptV2 era)) interpretTest testOperations (PrevResult possiblePrevResult) = do stateRef <- views envResource snd (testEnv, possibleRuntimeMonitor) <- setupTestInterpretEnv @@ -606,9 +603,8 @@ acquireTestInterpretContext = do releaseTestInterpretContext :: (MonadIO m) => (IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) - => (MonadReader (TestRunnerEnv lang era) m) - => TestInterpretContext lang era + => (MonadReader (TestRunnerEnv C.PlutusScriptV2 era) m) + => TestInterpretContext C.PlutusScriptV2 era -> m () releaseTestInterpretContext (stateRef, faucet) = -- In the last phase we execute two cleanup operations @@ -638,11 +634,10 @@ releaseTestInterpretContext (stateRef, faucet) = type TestRunnerM lang era a = ReaderT (TestRunnerEnv lang era) IO a runTest - :: forall era lang - . (IsPlutusScriptLanguage lang) - => (IsShelleyBasedEra era) + :: forall era + . (IsShelleyBasedEra era) => (FilePath, TestCase) - -> TestRunnerM lang era () + -> TestRunnerM C.PlutusScriptV2 era () runTest (testFile, testCase@TestCase{testName, operations = testOperations}) = do liftIO $ hPutStrLn stderr "" liftIO $ hPutStrLn stderr $ "***** Test " <> coerce testName <> " *****" @@ -700,11 +695,10 @@ type TestSuiteRunnerInternalEnv lang era = Env lang era (TVar (MasterFaucet era)) acquireFaucets - :: forall era lang m + :: forall era m . (IsShelleyBasedEra era) => (MonadIO m) - => (IsPlutusScriptLanguage lang) - => (MonadReader (TestSuiteRunnerInternalEnv lang era) m) + => (MonadReader (TestSuiteRunnerInternalEnv C.PlutusScriptV2 era) m) => TestFaucetBudget -> FaucetsNumber -> m (TVar [TestRunnerFaucet era]) @@ -759,11 +753,10 @@ acquireFaucets (TestFaucetBudget testFaucetBudget) (FaucetsNumber faucetNumber) liftIO $ newTVarIO subfaucets releaseFaucets - :: forall era lang m + :: forall era m . (IsShelleyBasedEra era) => (MonadIO m) - => (IsPlutusScriptLanguage lang) - => (MonadReader (TestSuiteRunnerInternalEnv lang era) m) + => (MonadReader (TestSuiteRunnerInternalEnv C.PlutusScriptV2 era) m) => TVar [TestRunnerFaucet era] -> m () releaseFaucets subfaucetsRef = do @@ -901,12 +894,11 @@ unmaskedReleaseBracket' before after thing = makeLenses ''TestSuiteResult runTests - :: forall era lang + :: forall era . (IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) => [(FilePath, TestCase)] -> MaxConcurrentRunners - -> TestSuiteRunnerM lang era (TestSuiteResult lang era) + -> TestSuiteRunnerM C.PlutusScriptV2 era (TestSuiteResult C.PlutusScriptV2 era) runTests tests (MaxConcurrentRunners maxConcurrentRunners) = do protocolParams <- view envProtocolParams let concurrentRunners = min maxConcurrentRunners (length tests) diff --git a/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Wallet/Interpret.hs b/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Wallet/Interpret.hs index 67e2cd3c35..e3d29b5275 100644 --- a/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Wallet/Interpret.hs +++ b/marlowe-cli/cli-test/Language/Marlowe/CLI/Test/Wallet/Interpret.hs @@ -10,7 +10,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Language.Marlowe.CLI.Test.Wallet.Interpret where @@ -60,7 +59,6 @@ import Data.Tuple.Extra (uncurry3) import Language.Marlowe.CLI.Cardano.Api (toReferenceTxInsScriptsInlineDatumsSupportedInEra, toTxOutDatumInline) import Language.Marlowe.CLI.Cardano.Api.Value (lovelaceToPlutusValue, toCurrencySymbol, toPlutusValue) import Language.Marlowe.CLI.Cardano.Api.Value qualified as CV -import Language.Marlowe.CLI.Export (readOpenRoleValidator) import Language.Marlowe.CLI.IO (readSigningKey, submitTxBody') import Language.Marlowe.CLI.Run (toCardanoPolicyId) import Language.Marlowe.CLI.Sync (toPlutusAddress) @@ -132,6 +130,7 @@ import Language.Marlowe.CLI.Types ( import Language.Marlowe.CLI.Types qualified as CT import Language.Marlowe.Cardano (marloweNetworkFromCaradnoNetworkId) import Language.Marlowe.Core.V1.Semantics.Types qualified as M +import Language.Marlowe.Scripts (openRolesValidator) import PlutusLedgerApi.V1 (CurrencySymbol, TokenName) import PlutusLedgerApi.V1.Value (valueOf) import PlutusLedgerApi.V1.Value qualified as P @@ -235,8 +234,7 @@ openRoleValidatorAddress openRoleValidatorAddress = do era <- view eraL networkId <- getNetworkId - openRoleScript <- readOpenRoleValidator @_ @C.PlutusScriptV2 - pure $ validatorAddress openRoleScript era networkId NoStakeAddress + pure $ validatorAddress openRolesValidator era networkId NoStakeAddress getNetworkId :: forall env st m era diff --git a/marlowe-cli/command/Language/Marlowe/CLI/Command/Contract.hs b/marlowe-cli/command/Language/Marlowe/CLI/Command/Contract.hs index 2c77221fdf..67d92cc81d 100644 --- a/marlowe-cli/command/Language/Marlowe/CLI/Command/Contract.hs +++ b/marlowe-cli/command/Language/Marlowe/CLI/Command/Contract.hs @@ -22,6 +22,8 @@ module Language.Marlowe.CLI.Command.Contract ( import Cardano.Api (NetworkId (..), StakeAddressReference (..)) import Control.Monad.Except (MonadError, MonadIO) +import Control.Monad.Reader.Class (MonadReader) +import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Language.Marlowe.CLI.Command.Parse ( parseCurrencySymbol, @@ -36,15 +38,11 @@ import Language.Marlowe.CLI.Export ( exportMarloweValidator, exportRedeemer, ) +import Language.Marlowe.CLI.IO (getDefaultCostModel) import Language.Marlowe.CLI.Types (CliEnv, CliError) import Language.Marlowe.Client (defaultMarloweParams, marloweParams) -import PlutusLedgerApi.V1 (CurrencySymbol, ProtocolVersion) - -import Cardano.Api qualified as C -import Control.Monad.Reader.Class (MonadReader) -import Data.Map qualified as Map -import Language.Marlowe.CLI.IO (getDefaultCostModel) import Options.Applicative qualified as O +import PlutusLedgerApi.V1 (CurrencySymbol, ProtocolVersion) -- | Marlowe CLI commands and options for exporting data. data ContractCommand @@ -131,7 +129,7 @@ runContractCommand command = stake' = fromMaybe NoStakeAddress $ stake command case command of Export{..} -> - exportMarlowe @_ @C.PlutusScriptV2 + exportMarlowe @_ marloweParams' protocolVersion (Map.elems costModel) @@ -142,9 +140,9 @@ runContractCommand command = inputFiles outputFile printStats - ExportAddress{} -> exportMarloweAddress @_ @C.PlutusScriptV2 network' stake' + ExportAddress{} -> exportMarloweAddress @_ network' stake' ExportValidator{..} -> - exportMarloweValidator @_ @C.PlutusScriptV2 + exportMarloweValidator @_ protocolVersion (Map.elems costModel) network' diff --git a/marlowe-cli/command/Language/Marlowe/CLI/Command/Role.hs b/marlowe-cli/command/Language/Marlowe/CLI/Command/Role.hs index 7c982287ef..4450e41c51 100644 --- a/marlowe-cli/command/Language/Marlowe/CLI/Command/Role.hs +++ b/marlowe-cli/command/Language/Marlowe/CLI/Command/Role.hs @@ -21,7 +21,6 @@ module Language.Marlowe.CLI.Command.Role ( ) where import Cardano.Api (NetworkId (..), StakeAddressReference (..)) -import Cardano.Api qualified as C import Control.Monad.Except (MonadError, MonadIO) import Control.Monad.Reader.Class (MonadReader) import Data.Map qualified as Map @@ -100,9 +99,9 @@ runRoleCommand command = let network' = network command stake' = fromMaybe NoStakeAddress $ stake command case command of - ExportAddress{} -> exportRoleAddress @_ @C.PlutusScriptV2 network' stake' + ExportAddress{} -> exportRoleAddress @_ network' stake' ExportValidator{..} -> do - exportRoleValidator @_ @C.PlutusScriptV2 + exportRoleValidator @_ protocolVersion (Map.elems costModel) network' diff --git a/marlowe-cli/command/Language/Marlowe/CLI/Command/Transaction.hs b/marlowe-cli/command/Language/Marlowe/CLI/Command/Transaction.hs index c238f95ce3..6c1372239c 100644 --- a/marlowe-cli/command/Language/Marlowe/CLI/Command/Transaction.hs +++ b/marlowe-cli/command/Language/Marlowe/CLI/Command/Transaction.hs @@ -70,7 +70,6 @@ import Language.Marlowe.CLI.Types ( ) import Cardano.Api qualified as Api (Value) -import Cardano.Api qualified as C import Control.Monad.Reader.Class (MonadReader) import Data.Time.Units (Second) import Options.Applicative qualified as O @@ -357,7 +356,7 @@ runTransactionCommand command = (fromMaybe 0 submitTimeout) >>= printTxId Publish{..} -> - buildPublishing @_ @C.PlutusScriptV2 + buildPublishing @_ connection signingKeyFile expires @@ -367,7 +366,7 @@ runTransactionCommand command = submitTimeout (PrintStats True) FindPublished{..} -> - findPublished @_ @C.PlutusScriptV2 + findPublished @_ (QueryNode connection) strategy diff --git a/marlowe-cli/marlowe-cli.cabal b/marlowe-cli/marlowe-cli.cabal index 0ae629466b..6e1fa1cb57 100644 --- a/marlowe-cli/marlowe-cli.cabal +++ b/marlowe-cli/marlowe-cli.cabal @@ -111,7 +111,6 @@ library , directory , errors , extra - , filepath , indexed-traversable , marlowe-cardano , megaparsec diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Analyze.hs b/marlowe-cli/src/Language/Marlowe/CLI/Analyze.hs index 2a73529582..387d3c2fe0 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Analyze.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Analyze.hs @@ -13,7 +13,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -50,7 +49,7 @@ import Language.Marlowe.Analysis.Safety.Transaction ( unitAnnotator, ) import Language.Marlowe.Analysis.Safety.Types (Transaction (..)) -import Language.Marlowe.CLI.Cardano.Api.PlutusScript (IsPlutusScriptLanguage (..), toScriptLanguageInEra) +import Language.Marlowe.CLI.Cardano.Api.PlutusScript (toScriptLanguageInEra) import Language.Marlowe.CLI.IO (decodeFileStrict, liftCli, liftCliIO, liftCliMaybe) import Language.Marlowe.CLI.Run (marloweAddressFromCardanoAddress, toCardanoAddressInEra, toCardanoValue) import Language.Marlowe.CLI.Types ( @@ -107,6 +106,7 @@ import Language.Marlowe.Scripts.Types (marloweTxInputsFromInputs) import Cardano.Api (bundleProtocolParams, unsafeHashableScriptData) import Cardano.Api qualified as Api +import Cardano.Api qualified as C import Cardano.Api.Shelley qualified as Api import Cardano.Ledger.Credential qualified as Shelley import Control.Monad.Writer (WriterT (..)) @@ -207,7 +207,7 @@ data ContractInstance lang era = ContractInstance analyzeImpl :: forall m lang era . (Api.IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => (MonadError CliError m) => (MonadIO m) => Api.ScriptDataSupportedInEra era @@ -558,7 +558,7 @@ calcMarloweTxExBudgets protocol ContractInstance{..} transactionsPath lockedRole checkTransactionSizes :: forall lang era m . (Api.IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => (MonadError CliError m) => (MonadIO m) => Api.ScriptDataSupportedInEra era @@ -591,7 +591,7 @@ checkTransactionSizes era protocol ci transactions verbose = checkTransactionSize :: forall lang era m . (Api.IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => (MonadError CliError m) => (MonadIO m) => Api.ScriptDataSupportedInEra era @@ -628,7 +628,7 @@ checkTransactionSize era protocol ContractInstance{..} (Transaction marloweState . Api.ScriptWitness Api.ScriptWitnessForSpending $ Api.PlutusScriptWitness scriptInEra - (plutusScriptVersion @lang) + C.plutusScriptVersion (validatorInfoScriptOrReference ciSemanticsValidator) (Api.ScriptDatumForTxIn . unsafeHashableScriptData . Api.fromPlutusData $ P.toData inDatum) (unsafeHashableScriptData . Api.fromPlutusData $ P.toData redeemer) diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Cardano/Api/PlutusScript.hs b/marlowe-cli/src/Language/Marlowe/CLI/Cardano/Api/PlutusScript.hs index 29fc11a43e..7db6088b9d 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Cardano/Api/PlutusScript.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Cardano/Api/PlutusScript.hs @@ -5,16 +5,14 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} --- | Additional conversion functions for `PlutusScript` plus a copy of not exposed `IsPlutusScriptLanguage` class. +-- | Additional conversion functions for `PlutusScript` module Language.Marlowe.CLI.Cardano.Api.PlutusScript ( - IsPlutusScriptLanguage (..), toScript, toScriptLanguageInEra, withPlutusScriptVersion, ) where import Cardano.Api ( - IsScriptLanguage, PlutusScriptV1, PlutusScriptV2, PlutusScriptVersion (..), @@ -24,30 +22,20 @@ import Cardano.Api qualified as C import Cardano.Api.Shelley (PlutusScript) import Language.Marlowe.CLI.Orphans () -withPlutusScriptVersion :: PlutusScriptVersion lang -> ((IsPlutusScriptLanguage lang) => a) -> a +withPlutusScriptVersion :: PlutusScriptVersion lang -> ((C.IsPlutusScriptLanguage lang) => a) -> a withPlutusScriptVersion PlutusScriptV1 = id withPlutusScriptVersion PlutusScriptV2 = id --- FIXME update with next cardano-api -withPlutusScriptVersion PlutusScriptV3 = const $ error "unsupported until cardano-api exposes PlutusScriptV3" +withPlutusScriptVersion PlutusScriptV3 = id -class (IsScriptLanguage lang) => IsPlutusScriptLanguage lang where - plutusScriptVersion :: PlutusScriptVersion lang - -instance IsPlutusScriptLanguage PlutusScriptV1 where - plutusScriptVersion = PlutusScriptV1 - -instance IsPlutusScriptLanguage PlutusScriptV2 where - plutusScriptVersion = PlutusScriptV2 - -toScript :: forall lang. (IsPlutusScriptLanguage lang) => PlutusScript lang -> Script lang -toScript = PlutusScript (plutusScriptVersion :: PlutusScriptVersion lang) +toScript :: forall lang. (C.IsPlutusScriptLanguage lang) => PlutusScript lang -> Script lang +toScript = PlutusScript (C.plutusScriptVersion @lang) toScriptLanguageInEra :: forall era lang - . (IsPlutusScriptLanguage lang) + . (C.IsPlutusScriptLanguage lang) => C.ScriptDataSupportedInEra era -> Maybe (C.ScriptLanguageInEra lang era) -toScriptLanguageInEra = case plutusScriptVersion @lang of +toScriptLanguageInEra = case C.plutusScriptVersion @lang of PlutusScriptV1 -> Just . toPlutusScriptV1LanguageInEra PlutusScriptV2 -> toPlutusScriptV2LanguageInEra PlutusScriptV3 -> const Nothing diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Export.hs b/marlowe-cli/src/Language/Marlowe/CLI/Export.hs index 5597976465..2dddea94c1 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Export.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Export.hs @@ -19,9 +19,6 @@ module Language.Marlowe.CLI.Export ( buildAddress, buildValidatorInfo, exportAddress, - readMarloweValidator, - readRolePayoutValidator, - readOpenRoleValidator, -- * Contract and Transaction buildMarlowe, @@ -64,11 +61,8 @@ module Language.Marlowe.CLI.Export ( import Cardano.Api ( AddressInEra, - AsType (..), - File (..), NetworkId, PaymentCredential (..), - PlutusScriptVersion (..), Script (PlutusScript), ScriptDataJsonSchema (..), ScriptDataSupportedInEra (..), @@ -77,12 +71,11 @@ import Cardano.Api ( hashScript, hashScriptDataBytes, makeShelleyAddressInEra, - readFileTextEnvelope, scriptDataToJson, serialiseAddress, unsafeHashableScriptData, ) -import Cardano.Api.Shelley (PlutusScript (..), fromPlutusData) +import Cardano.Api.Shelley (fromPlutusData) import Control.Monad (join, when) import Control.Monad.Except (MonadError, MonadIO, liftEither, liftIO) import Data.Aeson (encode) @@ -126,17 +119,15 @@ import Codec.Serialise (serialise) import Control.Monad.Reader (MonadReader) import Data.ByteString.Short qualified as SBS import Language.Marlowe.CLI.Cardano.Api qualified as C -import Language.Marlowe.CLI.Cardano.Api.PlutusScript (IsPlutusScriptLanguage (plutusScriptVersion)) -import Language.Marlowe.CLI.Cardano.Api.PlutusScript qualified as PlutusScript +import Language.Marlowe.CLI.Cardano.Api.PlutusScript (withPlutusScriptVersion) +import Language.Marlowe.Scripts (marloweValidator, openRolesValidator, payoutValidator) import Language.Marlowe.Scripts.Types (marloweTxInputsFromInputs) -import Paths_marlowe_cardano (getDataFileName) import PlutusLedgerApi.Common (ProtocolVersion) import PlutusLedgerApi.V1 (DatumHash (..), toBuiltin, toData) -import System.FilePath (()) -- | Build comprehensive information about a Marlowe contract and transaction. buildMarlowe - :: (MonadIO m, IsPlutusScriptLanguage lang) + :: (MonadIO m) => MarloweParams -> ScriptDataSupportedInEra era -> ProtocolVersion @@ -152,11 +143,10 @@ buildMarlowe -- ^ The contract's state. -> [Input] -- ^ The contract's input, - -> m (Either CliError (MarloweInfo lang era)) + -> m (Either CliError (MarloweInfo CS.PlutusScriptV2 era)) -- ^ The contract and transaction information, or an error message. buildMarlowe marloweParams era protocolVersion costModel network stake contract state inputs = do - marloweValidator <- readMarloweValidator pure do miValidatorInfo <- validatorInfo' marloweValidator Nothing era protocolVersion costModel network stake @@ -166,8 +156,8 @@ buildMarlowe marloweParams era protocolVersion costModel network stake contract -- | Export to a file the comprehensive information about a Marlowe contract and transaction. exportMarlowe - :: forall m lang era - . (MonadError CliError m, IsPlutusScriptLanguage lang, MonadIO m, MonadReader (CliEnv era) m) + :: forall m era + . (MonadError CliError m, MonadIO m, MonadReader (CliEnv era) m) => MarloweParams -- ^ The Marlowe contract parameters. -> ProtocolVersion @@ -197,7 +187,7 @@ exportMarlowe marloweParams protocolVersion costModel network stake contractFile marloweInfo@MarloweInfo{..} <- liftEither =<< join - (asksEra \era -> buildMarlowe @m @lang marloweParams era protocolVersion costModel network stake contract state inputs) + (asksEra \era -> buildMarlowe @m marloweParams era protocolVersion costModel network stake contract state inputs) let ValidatorInfo{..} = miValidatorInfo DatumInfo{..} = miDatumInfo RedeemerInfo{..} = miRedeemerInfo @@ -215,27 +205,10 @@ exportMarlowe marloweParams protocolVersion costModel network stake contractFile hPutStrLn stderr $ "Redeemer size: " <> show riSize hPutStrLn stderr $ "Total size: " <> show (viSize + diSize + riSize) -readMarloweValidator :: (MonadIO m, IsPlutusScriptLanguage lang) => m (PlutusScript lang) -readMarloweValidator = readValidator "marlowe-semantics.plutus" - -readRolePayoutValidator :: (MonadIO m, IsPlutusScriptLanguage lang) => m (PlutusScript lang) -readRolePayoutValidator = readValidator "marlowe-rolepayout.plutus" - -readOpenRoleValidator :: (MonadIO m, IsPlutusScriptLanguage lang) => m (PlutusScript lang) -readOpenRoleValidator = readValidator "open-role.plutus" - -readValidator :: forall lang m. (MonadIO m, IsPlutusScriptLanguage lang) => FilePath -> m (PlutusScript lang) -readValidator scriptFile = liftIO do - path <- getDataFileName $ "scripts" scriptFile - case plutusScriptVersion @lang of - PlutusScriptV1 -> either (fail . show) pure =<< readFileTextEnvelope (AsPlutusScript AsPlutusScriptV1) (File path) - PlutusScriptV2 -> either (fail . show) pure =<< readFileTextEnvelope (AsPlutusScript AsPlutusScriptV2) (File path) - PlutusScriptV3 -> either (fail . show) pure =<< readFileTextEnvelope (AsPlutusScript AsPlutusScriptV3) (File path) - -- | Print information about a Marlowe contract and transaction. printMarlowe :: forall m lang era - . (MonadError CliError m, MonadIO m, IsPlutusScriptLanguage lang) + . (MonadError CliError m, MonadIO m, CS.IsPlutusScriptLanguage lang) => MarloweParams -- ^ The Marlowe contract parameters. -> ScriptDataSupportedInEra era @@ -257,7 +230,7 @@ printMarlowe printMarlowe marloweParams era protocolVersion costModel network stake contract state inputs = do MarloweInfo{..} <- - liftEither =<< buildMarlowe @_ @lang marloweParams era protocolVersion costModel network stake contract state inputs + liftEither =<< buildMarlowe @_ marloweParams era protocolVersion costModel network stake contract state inputs let ValidatorInfo{..} = miValidatorInfo DatumInfo{..} = miDatumInfo RedeemerInfo{..} = miRedeemerInfo @@ -271,10 +244,9 @@ printMarlowe marloweParams era protocolVersion costModel network stake contract putStrLn $ "Inputs: " <> show inputs putStrLn "" putStrLn $ - "Validator: " <> LBS8.unpack case plutusScriptVersion @lang of - PlutusScriptV1 -> encode $ C.serialiseToTextEnvelope Nothing viScript - PlutusScriptV2 -> encode $ C.serialiseToTextEnvelope Nothing viScript - PlutusScriptV3 -> encode $ C.serialiseToTextEnvelope Nothing viScript + "Validator: " + <> LBS8.unpack + (withPlutusScriptVersion (CS.plutusScriptVersion @lang) $ encode $ C.serialiseToTextEnvelope Nothing viScript) putStrLn "" putStrLn $ "Validator address: " <> T.unpack (withCardanoEra era $ serialiseAddress viAddress) putStrLn "" @@ -303,8 +275,9 @@ printMarlowe marloweParams era protocolVersion costModel network stake contract -- | Compute the address of a validator. buildAddress - :: forall era - . SBS.ShortByteString + :: forall lang era + . (CS.IsPlutusScriptLanguage lang) + => CS.PlutusScript lang -- ^ The validator. -> ScriptDataSupportedInEra era -> NetworkId @@ -314,7 +287,7 @@ buildAddress -> AddressInEra era -- ^ The script address. buildAddress script era network stake = - let viScript = PlutusScript PlutusScriptV2 (PlutusScriptSerialised script) + let viScript = PlutusScript CS.plutusScriptVersion script in withShelleyBasedEra era $ makeShelleyAddressInEra network @@ -323,8 +296,8 @@ buildAddress script era network stake = -- | Compute the address of a Marlowe contract. buildMarloweAddress - :: forall m lang era - . (MonadIO m, IsPlutusScriptLanguage lang) + :: forall m era + . (MonadIO m) => ScriptDataSupportedInEra era -> NetworkId -- ^ The network ID. @@ -333,15 +306,13 @@ buildMarloweAddress -> m (AddressInEra era) -- ^ The script address. buildMarloweAddress era network stake = do - PlutusScriptSerialised marloweValidator <- readMarloweValidator @_ @lang pure $ buildAddress marloweValidator era network stake -- | Print the address of a validator. exportAddress - :: forall era m - . (MonadIO m) - => (MonadReader (CliEnv era) m) - => SBS.ShortByteString + :: forall era lang m + . (MonadIO m, MonadReader (CliEnv era) m, CS.IsPlutusScriptLanguage lang) + => CS.PlutusScript lang -- ^ The validator. -> NetworkId -- ^ The network ID. @@ -356,8 +327,8 @@ exportAddress validator network stake = do -- | Print the address of a Marlowe contract. exportMarloweAddress - :: forall m lang era - . (MonadIO m, MonadReader (CliEnv era) m, IsPlutusScriptLanguage lang) + :: forall m era + . (MonadIO m, MonadReader (CliEnv era) m) => NetworkId -- ^ The network ID. -> StakeAddressReference @@ -365,11 +336,10 @@ exportMarloweAddress -> m () -- ^ Action to print the script address. exportMarloweAddress network stake = do - PlutusScriptSerialised marloweValidator <- readMarloweValidator @_ @lang exportAddress marloweValidator network stake buildValidatorInfo - :: (MonadReader (CliEnv era) m, MonadIO m, MonadError CliError m, IsPlutusScriptLanguage lang) + :: (MonadReader (CliEnv era) m, MonadIO m, MonadError CliError m, CS.IsPlutusScriptLanguage lang) => QueryExecutionContext era -> CS.PlutusScript lang -> Maybe C.TxIn @@ -386,9 +356,9 @@ buildValidatorInfo queryCtx plutusScript txIn stake = do -- | Export to a file the validator information. exportValidatorImpl :: forall lang era m - . (MonadError CliError m, MonadReader (CliEnv era) m, IsPlutusScriptLanguage lang) + . (MonadError CliError m, MonadReader (CliEnv era) m, CS.IsPlutusScriptLanguage lang) => (MonadIO m) - => SBS.ShortByteString + => CS.PlutusScript lang -> ProtocolVersion -> [Integer] -- ^ The cost model parameters. @@ -404,12 +374,11 @@ exportValidatorImpl -- ^ Whether to print statistics about the validator. -> m () -- ^ Action to export the validator information to a file. -exportValidatorImpl validator protocolVersion costModel network stake outputFile printHash printStats = +exportValidatorImpl plutusScript protocolVersion costModel network stake outputFile printHash printStats = do era <- askEra - let plutusScript = PlutusScriptSerialised @lang validator ValidatorInfo{..} <- validatorInfo' plutusScript Nothing era protocolVersion costModel network stake - maybeWriteTextEnvelope outputFile $ PlutusScript.toScript plutusScript + maybeWriteTextEnvelope outputFile $ C.PlutusScript C.plutusScriptVersion plutusScript doWithCardanoEra $ liftIO $ do @@ -431,7 +400,7 @@ exportValidatorImpl validator protocolVersion costModel network stake outputFile -- | Current Marlowe validator information. marloweValidatorInfo - :: (MonadIO m, IsPlutusScriptLanguage lang) + :: (MonadIO m) => ScriptDataSupportedInEra era -- ^ The era to build he validator in. -> ProtocolVersion @@ -441,16 +410,15 @@ marloweValidatorInfo -- ^ The network ID. -> StakeAddressReference -- ^ The stake address. - -> m (Either CliError (ValidatorInfo lang era)) + -> m (Either CliError (ValidatorInfo CS.PlutusScriptV2 era)) -- ^ The validator information, or an error message. marloweValidatorInfo script prot costModel network stake = do - marloweValidator <- readMarloweValidator pure $ validatorInfo' marloweValidator Nothing script prot costModel network stake -- | Export to a file the validator information about a Marlowe contract. exportMarloweValidator - :: forall era lang m - . (MonadError CliError m, MonadReader (CliEnv era) m, IsPlutusScriptLanguage lang) + :: forall era m + . (MonadError CliError m, MonadReader (CliEnv era) m) => (MonadIO m) => ProtocolVersion -> [Integer] @@ -468,8 +436,7 @@ exportMarloweValidator -> m () -- ^ Action to export the validator information to a file. exportMarloweValidator prot costModel network stake out printHash printStats = do - PlutusScriptSerialised marloweValidatorBytes <- readMarloweValidator @_ @lang - exportValidatorImpl @lang marloweValidatorBytes prot costModel network stake out printHash printStats + exportValidatorImpl marloweValidator prot costModel network stake out printHash printStats -- | Build the datum information about a Marlowe transaction. buildDatumImpl @@ -619,8 +586,8 @@ exportRedeemer inputFiles outputFile printStats = -- -- | Compute the role address of a Marlowe contract. buildRoleAddress - :: forall era lang m - . (MonadIO m, IsPlutusScriptLanguage lang) + :: forall era m + . (MonadIO m) => ScriptDataSupportedInEra era -> NetworkId -- ^ The network ID. @@ -629,13 +596,12 @@ buildRoleAddress -> m (AddressInEra era) -- ^ The script address. buildRoleAddress script network stake = do - PlutusScriptSerialised rolePayoutValidatorBytes <- readRolePayoutValidator @_ @lang - pure $ buildAddress rolePayoutValidatorBytes script network stake + pure $ buildAddress payoutValidator script network stake -- | Print the role address of a Marlowe contract. exportRoleAddress - :: forall era lang m - . (MonadIO m, MonadReader (CliEnv era) m, IsPlutusScriptLanguage lang) + :: forall era m + . (MonadIO m, MonadReader (CliEnv era) m) => NetworkId -- ^ The network ID. -> StakeAddressReference @@ -643,12 +609,11 @@ exportRoleAddress -> m () -- ^ Action to print the script address. exportRoleAddress network stake = do - PlutusScriptSerialised rolePayoutValidatorBytes <- readRolePayoutValidator @_ @lang - exportAddress rolePayoutValidatorBytes network stake + exportAddress payoutValidator network stake -- | Current Marlowe validator information. payoutValidatorInfo - :: (MonadIO m, IsPlutusScriptLanguage lang) + :: (MonadIO m) => ScriptDataSupportedInEra era -- ^ The era to build he validator in. -> ProtocolVersion @@ -658,15 +623,14 @@ payoutValidatorInfo -- ^ The network ID. -> StakeAddressReference -- ^ The stake address. - -> m (Either CliError (ValidatorInfo lang era)) + -> m (Either CliError (ValidatorInfo CS.PlutusScriptV2 era)) -- ^ The validator information, or an error message. payoutValidatorInfo script prot cost network stake = do - roleValidator <- readRolePayoutValidator - pure $ validatorInfo' roleValidator Nothing script prot cost network stake + pure $ validatorInfo' payoutValidator Nothing script prot cost network stake -- | Open role validator openRoleValidatorInfo - :: (MonadIO m, IsPlutusScriptLanguage lang) + :: (MonadIO m) => ScriptDataSupportedInEra era -- ^ The era to build he validator in. -> ProtocolVersion @@ -676,16 +640,15 @@ openRoleValidatorInfo -- ^ The network ID. -> StakeAddressReference -- ^ The stake address. - -> m (Either CliError (ValidatorInfo lang era)) + -> m (Either CliError (ValidatorInfo CS.PlutusScriptV2 era)) -- ^ The validator information, or an error message. openRoleValidatorInfo script prot cost network stake = do - validator <- readOpenRoleValidator - pure $ validatorInfo' validator Nothing script prot cost network stake + pure $ validatorInfo' openRolesValidator Nothing script prot cost network stake -- | Export to a file the role validator information about a Marlowe contract. exportRoleValidator - :: forall era lang m - . (MonadError CliError m, MonadReader (CliEnv era) m, IsPlutusScriptLanguage lang) + :: forall era m + . (MonadError CliError m, MonadReader (CliEnv era) m) => (MonadIO m) => ProtocolVersion -- ^ The currency symbol for Marlowe contract roles. @@ -704,8 +667,7 @@ exportRoleValidator -> m () -- ^ Action to export the validator information to a file. exportRoleValidator prot cost network stake out printHash printStats = do - PlutusScriptSerialised roleValidator <- readRolePayoutValidator @_ @lang - exportValidatorImpl @lang roleValidator prot cost network stake out printHash printStats + exportValidatorImpl payoutValidator prot cost network stake out printHash printStats -- | Build the role datum information about a Marlowe transaction. buildRoleDatum diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Run.hs b/marlowe-cli/src/Language/Marlowe/CLI/Run.hs index 800e8cd894..60d45bdf18 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Run.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Run.hs @@ -104,7 +104,6 @@ import Data.Tuple.Extra (uncurry3) import Data.Type.Equality (type (:~:) (..)) import Language.Marlowe.CLI.Cardano.Api (adjustMinimumUTxO, toTxOutDatumInTx) import Language.Marlowe.CLI.Cardano.Api.Address (toShelleyStakeReference) -import Language.Marlowe.CLI.Cardano.Api.PlutusScript (IsPlutusScriptLanguage (plutusScriptVersion)) import Language.Marlowe.CLI.Export ( buildMarloweDatum, buildRedeemer, @@ -328,7 +327,7 @@ initializeTransaction connection marloweParams slotConfig protocolVersion costMo printStats maybeWriteJson outputFile $ SomeMarloweTransaction - (plutusScriptVersion :: PlutusScriptVersion MarlowePlutusVersion) + (C.plutusScriptVersion :: PlutusScriptVersion MarlowePlutusVersion) era marloweTransaction @@ -339,7 +338,7 @@ initializeTransactionImpl => (MonadIO m) => (C.IsShelleyBasedEra era) => (MonadReader (CliEnv era) m) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => MarloweParams -- ^ The Marlowe contract parameters. -> SlotConfig @@ -362,7 +361,7 @@ initializeTransactionImpl -- ^ Whether to print statistics about the validator. -> m (MarloweTransaction lang era) -- ^ Action to return a MarloweTransaction -initializeTransactionImpl marloweParams mtSlotConfig protocolVersion costModelParams network stake mtContract mtState refs merkleize printStats = case plutusScriptVersion @lang of +initializeTransactionImpl marloweParams mtSlotConfig protocolVersion costModelParams network stake mtContract mtState refs merkleize printStats = case C.plutusScriptVersion @lang of PlutusScriptV1 -> throwError "Plutus Script V1 not supported" PlutusScriptV3 -> throwError "Plutus Script V3 not supported" PlutusScriptV2 -> do @@ -639,12 +638,12 @@ runTransaction connection marloweInBundle marloweOutFile inputs outputs changeAd SomeMarloweTransaction _ era' marloweOut' <- decodeFileStrict marloweOutFile era <- askEra @era signingKeys <- mapM readSigningKey signingKeyFiles - let go :: forall lang. (IsPlutusScriptLanguage lang) => MarloweTransaction lang era -> m TxId + let go :: forall lang. (C.IsPlutusScriptLanguage lang) => MarloweTransaction lang era -> m TxId go marloweOut'' = do marloweInBundle' <- case marloweInBundle of Nothing -> pure Nothing Just (marloweInFile, marloweTxIn, collateralTxIn) -> do - marloweIn <- readMarloweTransactionFile (plutusScriptVersion :: PlutusScriptVersion lang) marloweInFile + marloweIn <- readMarloweTransactionFile (C.plutusScriptVersion :: PlutusScriptVersion lang) marloweInFile pure $ Just (marloweIn, marloweTxIn, collateralTxIn) (body :: TxBody era) <- @@ -682,7 +681,7 @@ testSameEra = \case runTransactionImpl :: forall era lang m . (MonadError CliError m, CS.IsCardanoEra era) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => (MonadIO m) => (MonadReader (CliEnv era) m) => TxBuildupContext era @@ -923,12 +922,12 @@ autoRunTransaction connection marloweInBundle marloweOutFile changeAddress signi SomeMarloweTransaction _ era' marloweOut' <- decodeFileStrict marloweOutFile era <- askEra @era signingKeys <- mapM readSigningKey signingKeyFiles - let go :: forall lang. (IsPlutusScriptLanguage lang) => MarloweTransaction lang era -> m TxId + let go :: forall lang. (C.IsPlutusScriptLanguage lang) => MarloweTransaction lang era -> m TxId go marloweOut'' = do marloweInBundle' <- case marloweInBundle of Nothing -> pure Nothing Just (marloweInFile, marloweTxIn) -> do - marloweIn <- readMarloweTransactionFile (plutusScriptVersion :: PlutusScriptVersion lang) marloweInFile + marloweIn <- readMarloweTransactionFile (C.plutusScriptVersion :: PlutusScriptVersion lang) marloweInFile pure $ Just (marloweIn, marloweTxIn) (body :: TxBody era) <- @@ -954,7 +953,7 @@ autoRunTransaction connection marloweInBundle marloweOutFile changeAddress signi autoRunTransactionImpl :: forall era lang m . (MonadError CliError m, CS.IsCardanoEra era) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => (MonadIO m) => (MonadReader (CliEnv era) m) => TxBuildupContext era @@ -1196,7 +1195,7 @@ autoWithdrawFunds connection marloweOutFile roleName changeAddress signingKeyFil era <- askEra -- Read the Marlowe transaction information that was used to populate the role-payout address. SomeMarloweTransaction _ era' marloweOut <- decodeFileStrict marloweOutFile - let go :: forall lang. (IsPlutusScriptLanguage lang) => MarloweTransaction lang era -> m TxId + let go :: forall lang. (C.IsPlutusScriptLanguage lang) => MarloweTransaction lang era -> m TxId go marloweOut' = do -- Read the signing keys. signingKeys <- mapM readSigningKey signingKeyFiles @@ -1235,7 +1234,7 @@ autoWithdrawFundsImpl . (MonadError CliError m, CS.IsCardanoEra era) => (MonadReader (CliEnv era) m) => (MonadIO m) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => TxBuildupContext era -- ^ The connection info for the local node. -> Token diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Sync.hs b/marlowe-cli/src/Language/Marlowe/CLI/Sync.hs index d8d950b3c8..27a51b6553 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Sync.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Sync.hs @@ -63,9 +63,7 @@ import Cardano.Api ( LocalNodeClientProtocols (..), LocalNodeConnectInfo (..), PaymentCredential (..), - PlutusScriptVersion (..), PolicyId, - Script (..), ScriptHash, SerialiseAsRawBytes (..), ShelleyBasedEra (..), @@ -131,7 +129,7 @@ import Data.List.Extra (mconcatMap) import Data.Map.Strict qualified as M (elems, filter, null, toList) import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Set qualified as S (singleton, toList) -import Language.Marlowe.CLI.Export (readMarloweValidator, readRolePayoutValidator) +import Language.Marlowe.CLI.Cardano.Api.PlutusScript (toScript) import Language.Marlowe.CLI.Sync.Types ( MarloweAddress (..), MarloweEvent (..), @@ -143,6 +141,7 @@ import Language.Marlowe.CLI.Transaction (querySlotConfig) import Language.Marlowe.CLI.Types (CliEnv, CliError (..)) import Language.Marlowe.Client (marloweParams) import Language.Marlowe.Core.V1.Semantics.Types (Contract (..), Input (..), TimeInterval) +import Language.Marlowe.Scripts (marloweValidator, payoutValidator) import Language.Marlowe.Scripts.Types (MarloweInput, MarloweTxInput (..)) import Language.Marlowe.Util (dataHash) import Plutus.V1.Ledger.Slot (Slot (..)) @@ -527,12 +526,10 @@ extractMarlowe -> IO () -- ^ Action to output potential Marlowe transactions. extractMarlowe _ printer slotConfig includeAll meBlock tx = do - marloweValidator <- readMarloweValidator - payoutValidator <- readRolePayoutValidator mapM_ printer $ classifyMarlowe - (hashScript $ PlutusScript PlutusScriptV2 marloweValidator) - (hashScript $ PlutusScript PlutusScriptV2 payoutValidator) + (hashScript $ toScript marloweValidator) + (hashScript $ toScript payoutValidator) slotConfig includeAll meBlock diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Transaction.hs b/marlowe-cli/src/Language/Marlowe/CLI/Transaction.hs index 938aa5baa4..0ff30eb311 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Transaction.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Transaction.hs @@ -221,13 +221,8 @@ import Language.Marlowe.CLI.Cardano.Api ( ) import Language.Marlowe.CLI.Cardano.Api qualified as MCA import Language.Marlowe.CLI.Cardano.Api.Address.ProofOfBurn (permanentPublisher) -import Language.Marlowe.CLI.Cardano.Api.PlutusScript as PS -import Language.Marlowe.CLI.Export ( - buildValidatorInfo, - readMarloweValidator, - readOpenRoleValidator, - readRolePayoutValidator, - ) +import Language.Marlowe.CLI.Cardano.Api.PlutusScript (toScript, toScriptLanguageInEra) +import Language.Marlowe.CLI.Export (buildValidatorInfo) import Language.Marlowe.CLI.IO ( decodeFileBuiltinData, decodeFileStrict, @@ -296,6 +291,7 @@ import Language.Marlowe.CLI.Types ( withShelleyBasedEra, ) import Language.Marlowe.CLI.Types qualified as PayToScript (PayToScript (value)) +import Language.Marlowe.Scripts import Ouroboros.Consensus.HardFork.History (interpreterToEpochInfo) import Plutus.V1.Ledger.SlotConfig (SlotConfig (..)) import PlutusLedgerApi.V1 (Datum (..), POSIXTime (..), Redeemer (..), TokenName (..), fromBuiltin, toData) @@ -891,7 +887,7 @@ buildIncoming connection scriptAddress signingKeyFiles outputDatumFile outputVal buildReferenceScript :: forall era lang m - . (IsPlutusScriptLanguage lang) + . (C.IsPlutusScriptLanguage lang) => (MonadError CliError m) => (MonadReader (CliEnv era) m) => PlutusScript lang @@ -903,7 +899,7 @@ buildReferenceScript plutusScript = do let refScript = ReferenceScript referenceTxInsScriptsInlineDatumsSupportedInEra . toScriptInAnyLang - . PS.toScript + . toScript $ plutusScript pure refScript @@ -933,7 +929,7 @@ buildScriptPublishingInfo => (MonadError CliError m) => (C.IsShelleyBasedEra era) => (MonadReader (CliEnv era) m) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => QueryExecutionContext era -> PlutusScript lang -> PublishingStrategy era @@ -944,7 +940,7 @@ buildScriptPublishingInfo queryCtx plutusScript publishingStrategy = do protocolVersion <- getProtocolVersion queryCtx costModel <- getPV2CostModelParams queryCtx let networkId = queryContextNetworkId queryCtx - scriptHash = hashScript . PS.toScript $ plutusScript + scriptHash = hashScript . toScript $ plutusScript publisher = publisherAddress scriptHash publishingStrategy era networkId -- Stake information in this context is probably meaningless. We assign real staking when we use a reference. @@ -955,8 +951,8 @@ buildScriptPublishingInfo queryCtx plutusScript publishingStrategy = do pure (minAda, publisher, referenceScriptInfo) buildPublishingImpl - :: forall era lang m - . (MonadError CliError m, IsPlutusScriptLanguage lang) + :: forall era m + . (MonadError CliError m) => (MonadIO m) => (MonadReader (CliEnv era) m) => (C.IsShelleyBasedEra era) @@ -971,15 +967,12 @@ buildPublishingImpl -> PublishingStrategy era -> CoinSelectionStrategy -> PrintStats - -> m ([TxBody era], MarloweScriptsRefs lang era) + -> m ([TxBody era], MarloweScriptsRefs C.PlutusScriptV2 era) buildPublishingImpl buildupCtx signingKey expires changeAddress publishingStrategy coinSelectionStrategy (PrintStats printStats) = do let queryCtx = toQueryContext buildupCtx - marloweValidator <- readMarloweValidator - payoutValidator <- readRolePayoutValidator - openRoleValidator <- readOpenRoleValidator - pm <- buildScriptPublishingInfo @lang queryCtx marloweValidator publishingStrategy - pp <- buildScriptPublishingInfo @lang queryCtx payoutValidator publishingStrategy - po <- buildScriptPublishingInfo @lang queryCtx openRoleValidator publishingStrategy + pm <- buildScriptPublishingInfo queryCtx marloweValidator publishingStrategy + pp <- buildScriptPublishingInfo queryCtx payoutValidator publishingStrategy + po <- buildScriptPublishingInfo queryCtx openRolesValidator publishingStrategy let buildPublishedScriptTxOut (minAda, publisher, referenceValidator) = do referenceScript <- buildReferenceScript $ viScript referenceValidator @@ -1002,7 +995,7 @@ buildPublishingImpl buildupCtx signingKey expires changeAddress publishingStrate (txBodyContent, txBody) <- buildBodyWithContent queryCtx - ([] :: [PayFromScript lang]) + ([] :: [PayFromScript C.PlutusScriptV2]) Nothing [] inputs @@ -1039,8 +1032,8 @@ buildPublishingImpl buildupCtx signingKey expires changeAddress publishingStrate C.TxBody C.TxBodyContent{txOuts} = txBody script = C.ScriptInAnyLang - (C.PlutusScriptLanguage $ plutusScriptVersion @lang) - (C.PlutusScript (plutusScriptVersion @lang) plutusV2Script) + (C.PlutusScriptLanguage C.plutusScriptVersion) + (toScript plutusV2Script) match (ix, txOut@(C.TxOut _ _ _ referenceScript)) = case referenceScript of C.ReferenceScript _ txOutScript -> @@ -1112,8 +1105,8 @@ buildPublishingImpl buildupCtx signingKey expires changeAddress publishingStrate -- CLI command handler. buildPublishing - :: forall era lang m - . (MonadError CliError m, IsPlutusScriptLanguage lang) + :: forall era m + . (MonadError CliError m) => (MonadIO m) => (MonadReader (CliEnv era) m) => (C.IsShelleyBasedEra era) @@ -1134,7 +1127,7 @@ buildPublishing connection signingKeyFile expires changeAddress strategy (TxBody let strategy' = fromMaybe (PublishAtAddress changeAddress) strategy signingKey <- readSigningKey signingKeyFile (txBodies, _) <- - buildPublishingImpl @era @lang + buildPublishingImpl @era (mkNodeTxBuildup connection timeout) signingKey expires @@ -1150,12 +1143,11 @@ buildPublishing connection signingKeyFile expires changeAddress strategy (TxBody void $ submitTxBody txBuildupCtx txBody [signingKey] publishImpl - :: forall lang era m + :: forall era m . (MonadError CliError m) => (MonadIO m) => (MonadReader (CliEnv era) m) => (C.IsShelleyBasedEra era) - => (IsPlutusScriptLanguage lang) => TxBuildupContext era -- ^ The connection info for the local node. -> SomePaymentSigningKey @@ -1167,10 +1159,10 @@ publishImpl -> PublishingStrategy era -> CoinSelectionStrategy -> PrintStats - -> m ([TxBody era], MarloweScriptsRefs lang era) + -> m ([TxBody era], MarloweScriptsRefs C.PlutusScriptV2 era) publishImpl txBuildupCtx signingKey expires changeAddress publishingStrategy coinSelectionStrategy printStats = do (txBodies, _) <- - buildPublishingImpl @era @lang + buildPublishingImpl @era txBuildupCtx signingKey expires @@ -1189,9 +1181,8 @@ publishImpl txBuildupCtx signingKey expires changeAddress publishingStrategy coi pure (txBodies, refs) findScriptRef - :: forall lang era m + :: forall era m . (MonadReader (CliEnv era) m) - => (IsPlutusScriptLanguage lang) => (C.IsShelleyBasedEra era) => (MonadIO m) => (MonadError CliError m) @@ -1200,7 +1191,7 @@ findScriptRef -> ScriptHash -> PublishingStrategy era -> PrintStats - -> m (Maybe (AnUTxO era, ValidatorInfo lang era)) + -> m (Maybe (AnUTxO era, ValidatorInfo C.PlutusScriptV2 era)) findScriptRef queryCtx scriptHash publishingStrategy (PrintStats printStats) = do era <- askEra let networkId = queryContextNetworkId queryCtx @@ -1216,14 +1207,14 @@ findScriptRef queryCtx scriptHash publishingStrategy (PrintStats printStats) = d <> show scriptHash runMaybeT do - let query = FindReferenceScript (plutusScriptVersion @lang) scriptHash + let query = FindReferenceScript C.plutusScriptVersion scriptHash (u@(AnUTxO (txIn, _)), script) <- MaybeT $ selectUtxosImpl queryCtx publisher query i <- lift $ buildValidatorInfo queryCtx script (Just txIn) NoStakeAddress pure (u, i) findMarloweScriptsRefs - :: forall era lang m - . (MonadReader (CliEnv era) m, IsPlutusScriptLanguage lang) + :: forall era m + . (MonadReader (CliEnv era) m) => (MonadIO m) => (MonadError CliError m) => (C.IsShelleyBasedEra era) @@ -1231,14 +1222,11 @@ findMarloweScriptsRefs -- ^ Either already selected UTxOs or connection info to select UTxOs. -> PublishingStrategy era -> PrintStats - -> m (Maybe (MarloweScriptsRefs lang era)) + -> m (Maybe (MarloweScriptsRefs C.PlutusScriptV2 era)) findMarloweScriptsRefs queryCtx publishingStrategy printStats = do - marloweValidator <- readMarloweValidator @_ @lang - payoutValidator <- readRolePayoutValidator @_ @lang - openRoleValidator <- readOpenRoleValidator @_ @lang - let marloweHash = hashScript $ PS.toScript marloweValidator - payoutHash = hashScript $ PS.toScript payoutValidator - openRoleHash = hashScript $ PS.toScript openRoleValidator + let marloweHash = hashScript $ toScript marloweValidator + payoutHash = hashScript $ toScript payoutValidator + openRoleHash = hashScript $ toScript openRolesValidator runMaybeT do m <- MaybeT $ findScriptRef queryCtx marloweHash publishingStrategy printStats @@ -1248,8 +1236,8 @@ findMarloweScriptsRefs queryCtx publishingStrategy printStats = do -- | CLI Command handler. findPublished - :: forall era lang m - . (C.IsShelleyBasedEra era, IsPlutusScriptLanguage lang) + :: forall era m + . (C.IsShelleyBasedEra era) => (MonadReader (CliEnv era) m) => (MonadIO m) => (MonadError CliError m) @@ -1258,7 +1246,7 @@ findPublished -> m () findPublished queryCtx publishingStrategy = do let publishingStrategy' = fromMaybe (PublishPermanently NoStakeAddress) publishingStrategy - findMarloweScriptsRefs @era @lang queryCtx publishingStrategy' (PrintStats True) >>= \case + findMarloweScriptsRefs @era queryCtx publishingStrategy' (PrintStats True) >>= \case Just (MarloweScriptsRefs (mu, mi) (ru, ri) (ou, oi)) -> do let refJSON (AnUTxO (i, _)) ValidatorInfo{viHash} = A.object @@ -1465,7 +1453,7 @@ hashSigningKey = buildBody :: forall era lang m . (MonadError CliError m) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => (MonadIO m) => (MonadReader (CliEnv era) m) => QueryExecutionContext era @@ -1521,7 +1509,7 @@ buildBody queryCtx payFromScript payToScript extraInputs inputs outputs collater buildBodyWithContent :: forall era lang m . (MonadError CliError m) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => (MonadIO m) => (MonadReader (CliEnv era) m) => QueryExecutionContext era @@ -1756,7 +1744,7 @@ type TxInEra era = (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) scriptWitness :: forall era lang m . (MonadError CliError m) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => ScriptDataSupportedInEra era -> PayFromScript lang -- ^ The payment information. @@ -1770,7 +1758,7 @@ scriptWitness era PayFromScript{..} = do BuildTxWith . ScriptWitness ScriptWitnessForSpending $ C.PlutusScriptWitness scriptInEra - (plutusScriptVersion @lang) + C.plutusScriptVersion script datum' (C.unsafeHashableScriptData $ fromPlutusData $ toData redeemer) @@ -1780,7 +1768,7 @@ scriptWitness era PayFromScript{..} = do redeemScript :: forall era lang m . (MonadError CliError m) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => ScriptDataSupportedInEra era -> PayFromScript lang -- ^ The payment information. diff --git a/marlowe-cli/src/Language/Marlowe/CLI/Types.hs b/marlowe-cli/src/Language/Marlowe/CLI/Types.hs index f8920e42c4..4901e07fe4 100644 --- a/marlowe-cli/src/Language/Marlowe/CLI/Types.hs +++ b/marlowe-cli/src/Language/Marlowe/CLI/Types.hs @@ -212,11 +212,6 @@ import Data.Time.Units (Second) import GHC.Exts (IsString (fromString)) import GHC.Natural (Natural) import Language.Marlowe.CLI.Cardano.Api (toMultiAssetSupportedInEra, withShelleyBasedEra) -import Language.Marlowe.CLI.Cardano.Api.PlutusScript ( - IsPlutusScriptLanguage, - plutusScriptVersion, - withPlutusScriptVersion, - ) import Language.Marlowe.Core.V1.Semantics.Types qualified as M import Language.Marlowe.Extended.V1 qualified as E @@ -268,7 +263,7 @@ somePaymentSigningKeyToTxWitness (SomePaymentSigningKeyGenesisUTxO skey) = -- | A marlowe transaction in an existentially quantified era data SomeMarloweTransaction = forall era lang. - (IsPlutusScriptLanguage lang) => + (C.IsPlutusScriptLanguage lang) => SomeMarloweTransaction (PlutusScriptVersion lang) (ScriptDataSupportedInEra era) @@ -278,7 +273,7 @@ data SomeMarloweTransaction type MarlowePlutusVersion = C.PlutusScriptV2 marlowePlutusVersion :: PlutusScriptVersion MarlowePlutusVersion -marlowePlutusVersion = plutusScriptVersion +marlowePlutusVersion = C.plutusScriptVersion doWithCardanoEra :: forall era m a. (MonadReader (CliEnv era) m) => ((IsCardanoEra era) => m a) -> m a doWithCardanoEra m = askEra >>= \era -> withCardanoEra era m @@ -403,7 +398,14 @@ instance ToJSON SomeMarloweTransaction where C.PlutusScriptV3 -> "PlutusScriptV3" in [ "era" .= eraStr , "plutusVersion" .= plutusVersionStr - , "tx" .= withPlutusScriptVersion plutusVersion (toJSON tx) + , "tx" + .= ( ( case plutusVersion of + C.PlutusScriptV1 -> toJSON tx + C.PlutusScriptV2 -> toJSON tx + C.PlutusScriptV3 -> toJSON tx + ) + :: Value + ) ] instance FromJSON SomeMarloweTransaction where @@ -446,7 +448,7 @@ data MarloweTransaction lang era = MarloweTransaction } deriving (Eq, Generic, Show) -instance (IsPlutusScriptLanguage lang, IsShelleyBasedEra era) => ToJSON (MarloweTransaction lang era) where +instance (C.IsPlutusScriptLanguage lang, IsShelleyBasedEra era) => ToJSON (MarloweTransaction lang era) where toJSON MarloweTransaction{..} = object [ "marloweValidator" .= toJSON mtValidator @@ -491,7 +493,7 @@ data MarloweInfo lang era = MarloweInfo } deriving (Eq, Generic, Show) -instance (IsPlutusScriptLanguage lang, IsShelleyBasedEra era) => ToJSON (MarloweInfo lang era) where +instance (C.IsPlutusScriptLanguage lang, IsShelleyBasedEra era) => ToJSON (MarloweInfo lang era) where toJSON MarloweInfo{..} = object [ "validator" .= toJSON miValidatorInfo @@ -533,20 +535,20 @@ data ValidatorInfo lang era = ValidatorInfo -- Let's extract validatorAddress build up from the above validatorAddress - :: (IsPlutusScriptLanguage lang) + :: (C.IsPlutusScriptLanguage lang) => PlutusScript lang -> ScriptDataSupportedInEra era -> CS.NetworkId -> CS.StakeAddressReference -> AddressInEra era validatorAddress viScript era network stake = do - let viHash = C.hashScript (C.PlutusScript plutusScriptVersion viScript) + let viHash = C.hashScript (C.PlutusScript C.plutusScriptVersion viScript) paymentCredential = C.PaymentCredentialByScript viHash withShelleyBasedEra era $ C.makeShelleyAddressInEra network paymentCredential stake -- | Build validator info. validatorInfo - :: (IsPlutusScriptLanguage lang) + :: (C.IsPlutusScriptLanguage lang) => C.PlutusScript lang -- ^ The validator. -> Maybe TxIn @@ -563,7 +565,7 @@ validatorInfo -- ^ The validator information, or an error message. validatorInfo viScript viTxIn era protocolVersion costModel network stake = do let C.PlutusScriptSerialised viBytes = viScript - viHash = C.hashScript (C.PlutusScript plutusScriptVersion viScript) + viHash = C.hashScript (C.PlutusScript C.plutusScriptVersion viScript) viAddress = validatorAddress viScript era network stake viSize = SBS.length viBytes @@ -574,7 +576,7 @@ validatorInfo viScript viTxIn era protocolVersion costModel network stake = do validatorInfo' :: (MonadError CliError m) - => (IsPlutusScriptLanguage lang) + => (C.IsPlutusScriptLanguage lang) => C.PlutusScript lang -> Maybe C.TxIn -> ScriptDataSupportedInEra era @@ -590,13 +592,13 @@ validatorInfoScriptOrReference ValidatorInfo{..} = case viTxIn of Just txIn -> C.PReferenceScript txIn Nothing Nothing -> C.PScript viScript -instance (IsPlutusScriptLanguage lang, IsShelleyBasedEra era) => ToJSON (ValidatorInfo lang era) where +instance (C.IsPlutusScriptLanguage lang, IsShelleyBasedEra era) => ToJSON (ValidatorInfo lang era) where toJSON ValidatorInfo{..} = do object [ "address" .= serialiseAddress viAddress , "hash" .= toJSON viHash , "script" - .= toJSON (serialiseToTextEnvelope Nothing (PlutusScript (plutusScriptVersion :: PlutusScriptVersion lang) viScript)) + .= toJSON (serialiseToTextEnvelope Nothing (PlutusScript (C.plutusScriptVersion :: PlutusScriptVersion lang) viScript)) , "size" .= toJSON viSize , "txIn" .= toJSON viTxIn , "cost" .= toJSON viCost diff --git a/marlowe-runtime/test/Language/Marlowe/Runtime/Core/ScriptRegistrySpec.hs b/marlowe-runtime/test/Language/Marlowe/Runtime/Core/ScriptRegistrySpec.hs index 02cefeefd2..ad802efe79 100644 --- a/marlowe-runtime/test/Language/Marlowe/Runtime/Core/ScriptRegistrySpec.hs +++ b/marlowe-runtime/test/Language/Marlowe/Runtime/Core/ScriptRegistrySpec.hs @@ -2,7 +2,8 @@ module Language.Marlowe.Runtime.Core.ScriptRegistrySpec ( spec, ) where -import Cardano.Api (AsType (..), File (..), hashScript, readFileTextEnvelope) +import Cardano.Api (hashScript) +import qualified Cardano.Api as C import Control.Monad (unless) import Data.Foldable (traverse_) import qualified Data.Map.Strict as Map @@ -10,8 +11,7 @@ import qualified Data.Set as Set import Language.Marlowe.Runtime.ChainSync.Api (fromCardanoScriptHash) import Language.Marlowe.Runtime.Core.Api (MarloweVersion, withSomeMarloweVersion) import Language.Marlowe.Runtime.Core.ScriptRegistry -import Paths_marlowe_cardano (getDataFileName) -import System.FilePath (()) +import Language.Marlowe.Scripts (marloweValidator, openRolesValidator, payoutValidator) import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe) spec :: Spec @@ -36,15 +36,12 @@ scriptSetSpec marloweVersion = do , "but it does not." ] it "Should specify the correct current scripts" do - payoutScriptPath <- getDataFileName $ "scripts" "marlowe-rolepayout.plutus" - marloweScriptPath <- getDataFileName $ "scripts" "marlowe-semantics.plutus" - openRoleScriptPath <- getDataFileName $ "scripts" "open-role.plutus" - Right payoutScriptBytes <- readFileTextEnvelope (AsScript AsPlutusScriptV2) $ File payoutScriptPath - Right marloweScriptBytes <- readFileTextEnvelope (AsScript AsPlutusScriptV2) $ File marloweScriptPath - Right openRoleScriptBytes <- readFileTextEnvelope (AsScript AsPlutusScriptV2) $ File openRoleScriptPath - let payoutScript = fromCardanoScriptHash $ hashScript payoutScriptBytes - let marloweScript = fromCardanoScriptHash $ hashScript marloweScriptBytes - let helperScripts = Map.singleton OpenRoleScript . fromCardanoScriptHash $ hashScript openRoleScriptBytes + let payoutScript = fromCardanoScriptHash $ hashScript $ C.PlutusScript C.plutusScriptVersion payoutValidator + let marloweScript = fromCardanoScriptHash $ hashScript $ C.PlutusScript C.plutusScriptVersion marloweValidator + let helperScripts = + Map.singleton OpenRoleScript . fromCardanoScriptHash $ + hashScript $ + C.PlutusScript C.plutusScriptVersion openRolesValidator let marloweScriptUTxOs = mempty let payoutScriptUTxOs = mempty let helperScriptUTxOs = mempty diff --git a/marlowe/src/Language/Marlowe/Scripts.hs b/marlowe/src/Language/Marlowe/Scripts.hs index 3b3f7bf283..1096aaf5e6 100644 --- a/marlowe/src/Language/Marlowe/Scripts.hs +++ b/marlowe/src/Language/Marlowe/Scripts.hs @@ -7,10 +7,10 @@ import Cardano.Api (PlutusScript, PlutusScriptV2) import Language.Marlowe.Scripts.Types (readPlutusScript) marloweValidator :: PlutusScript PlutusScriptV2 -marloweValidator = $(readPlutusScript "marlowe/scripts/marlowe-semantics.plutus") +marloweValidator = $(readPlutusScript "scripts/marlowe-semantics.plutus") payoutValidator :: PlutusScript PlutusScriptV2 -payoutValidator = $(readPlutusScript "marlowe/scripts/marlowe-rolepayout.plutus") +payoutValidator = $(readPlutusScript "scripts/marlowe-rolepayout.plutus") openRolesValidator :: PlutusScript PlutusScriptV2 -openRolesValidator = $(readPlutusScript "marlowe/scripts/open-role.plutus") +openRolesValidator = $(readPlutusScript "scripts/open-role.plutus") From 7483d4feca2c7ca0336690bc69bcb27148d38204 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 3 Jan 2024 10:59:11 -0500 Subject: [PATCH 3/4] Update changelog --- .../20240103_105823_jhbertra_plt_8805_embed_validators.md | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 marlowe/changelog.d/20240103_105823_jhbertra_plt_8805_embed_validators.md diff --git a/marlowe/changelog.d/20240103_105823_jhbertra_plt_8805_embed_validators.md b/marlowe/changelog.d/20240103_105823_jhbertra_plt_8805_embed_validators.md new file mode 100644 index 0000000000..2047115da5 --- /dev/null +++ b/marlowe/changelog.d/20240103_105823_jhbertra_plt_8805_embed_validators.md @@ -0,0 +1,3 @@ +### Added + +- Current validator bytes are now embedded in compiled library. From 03d1de4322d29c88d6473756a16b34db977ce27b Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Wed, 3 Jan 2024 13:23:31 -0500 Subject: [PATCH 4/4] Remove unused pacakge --- marlowe-runtime/marlowe-runtime.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/marlowe-runtime/marlowe-runtime.cabal b/marlowe-runtime/marlowe-runtime.cabal index 03fe9d8884..d65cb35fa6 100644 --- a/marlowe-runtime/marlowe-runtime.cabal +++ b/marlowe-runtime/marlowe-runtime.cabal @@ -862,7 +862,6 @@ test-suite marlowe-runtime-test , cardano-api-gen ^>=8.1 , containers ^>=0.6.5 , errors >=2.3 && <3 - , filepath ^>=1.4 , hasql >=1.6 && <2 , hedgehog-quickcheck ^>=0.1 , hspec