diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,47 @@ +0.3.1 +===== +* [!1339](https://gitlab.com/morley-framework/morley/-/merge_requests/1339) + Export AddressWithAlias &c from Cleveland +* [!1331](https://gitlab.com/morley-framework/morley/-/merge_requests/1331) + Support implicit account tickets + + New Cleveland action, `transferTicket`, and its unchecked counterpart + `unsafeTransferTicket`. +* [!1330](https://gitlab.com/morley-framework/morley/-/merge_requests/1330) + Support ticket balance queries +* [!1328](https://gitlab.com/morley-framework/morley/-/merge_requests/1328) + Kill support for TORUs, minimal sr1 address support, tz4 address support + + BLS crypto generators added in `Hedgehog.Gen.Tezos.Crypto.BLS`; + + New crypto hedgehog generators which allow choosing key type added to + `Hedgehog.Gen.Tezos.Crypto`; + + `importSecretKey` Cleveland action added to allow for getting addresses with + specific key type. +* [!1313](https://gitlab.com/morley-framework/morley/-/merge_requests/1313) + Add `getOnlyRpcEnv` utility function +* [!1315](https://gitlab.com/morley-framework/morley/-/merge_requests/1315) + Avoid redundant calls to octez-client address store + + Use `ImplicitAddressWithAlias` for sender, moneybag and new implicit address + generators + + Introduce `ToImplicitAddress` class to use `ImplicitAddressWithAlias` where + `ImplicitAddress` is required +* [!1297](https://gitlab.com/morley-framework/morley/-/merge_requests/1297) + Add a failure predicate to expect custom error with a specific tag, but + arbitrary argument (including none), `expectCustomErrorAnyArg` +* [!1304](https://gitlab.com/morley-framework/morley/-/merge_requests/1304) + Avoid unnecessary contract conversions +* [!1306](https://gitlab.com/morley-framework/morley/-/merge_requests/1306) + Add `refillables` which marks multiple addresses as refillable +* [!1290](https://gitlab.com/morley-framework/morley/-/merge_requests/1290) + Implement negation for `TransferFailurePredicate` + + Also refactor `TransferFailurePredicate` to use `Maybe Builder` instead of + `Validation Builder ()`. +* [!1280](https://gitlab.com/morley-framework/morley/-/merge_requests/1280) + Apply internal modules pattern consistently + + Export everything from internal modules + + Move some internal modules around to avoid mixing definitions and reexports. + 0.3.0 ===== * [!1281](https://gitlab.com/morley-framework/morley/-/merge_requests/1281) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ MIT License -Copyright (c) 2021-2022 Oxhead Alpha +Copyright (c) 2021-2023 Oxhead Alpha Copyright (c) 2019-2021 Tocqueville Group Permission is hereby granted, free of charge, to any person obtaining a copy diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,7 @@ +> :warning: **Note: this project is being deprecated.** +> +> It will no longer be maintained after the activation of protocol "N" on the Tezos mainnet. + # Cleveland: A testing framework for Morley This package provides an eDSL for testing contracts written in Michelson, Morley or Lorentz. diff --git a/cleveland.cabal b/cleveland.cabal --- a/cleveland.cabal +++ b/cleveland.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: cleveland -version: 0.3.0 +version: 0.3.1 synopsis: Testing framework for Morley. description: This package provides an eDSL for testing contracts written in Michelson, Morley or Lorentz. These tests can be run on an emulated environment or on a real network. category: Blockchain @@ -13,7 +13,7 @@ bug-reports: https://gitlab.com/morley-framework/morley/-/issues author: Serokell, Tocqueville Group maintainer: Serokell -copyright: 2019-2021 Tocqueville Group, 2021-2022 Oxhead Alpha +copyright: 2019-2021 Tocqueville Group, 2021-2023 Oxhead Alpha license: MIT license-file: LICENSE build-type: Simple @@ -40,6 +40,7 @@ Hedgehog.Gen.Tezos.Address Hedgehog.Gen.Tezos.Core Hedgehog.Gen.Tezos.Crypto + Hedgehog.Gen.Tezos.Crypto.BLS Hedgehog.Gen.Tezos.Crypto.BLS12381 Hedgehog.Gen.Tezos.Crypto.Ed25519 Hedgehog.Gen.Tezos.Crypto.P256 @@ -63,11 +64,14 @@ Test.Cleveland.Internal.Actions.Helpers Test.Cleveland.Internal.Actions.Misc Test.Cleveland.Internal.Actions.MonadOps + Test.Cleveland.Internal.Actions.MonadOpsInternal Test.Cleveland.Internal.Actions.Originate Test.Cleveland.Internal.Actions.Transfer Test.Cleveland.Internal.Actions.TransferFailurePredicate + Test.Cleveland.Internal.Actions.TransferTicket Test.Cleveland.Internal.Actions.View Test.Cleveland.Internal.Client + Test.Cleveland.Internal.Common Test.Cleveland.Internal.Exceptions Test.Cleveland.Internal.Exceptions.Annotated Test.Cleveland.Internal.Exceptions.CallStack @@ -163,7 +167,6 @@ , data-default , dependent-map , directory - , either , exceptions , file-embed , fmt @@ -219,6 +222,7 @@ TestSuite.Cleveland.ErrorMessages TestSuite.Cleveland.ExpectFailure TestSuite.Cleveland.FailureLogs + TestSuite.Cleveland.ImplicitTickets TestSuite.Cleveland.Import TestSuite.Cleveland.InitialState TestSuite.Cleveland.Level @@ -239,6 +243,7 @@ TestSuite.Cleveland.Tasty TestSuite.Cleveland.Tasty.Report TestSuite.Cleveland.Tasty.Report.Examples + TestSuite.Cleveland.TicketBalance TestSuite.Cleveland.Time TestSuite.Cleveland.TransferCheck TestSuite.Cleveland.UsedFramework @@ -310,7 +315,6 @@ build-depends: base-noprelude >=4.7 && <5 , cleveland - , either , filepath , fmt , hedgehog >=1.0.3 diff --git a/src/Hedgehog/Gen/Michelson/Typed.hs b/src/Hedgehog/Gen/Michelson/Typed.hs --- a/src/Hedgehog/Gen/Michelson/Typed.hs +++ b/src/Hedgehog/Gen/Michelson/Typed.hs @@ -45,9 +45,8 @@ import Morley.Michelson.Typed.Haskell.Value (BigMap(..), BigMapId(..), ToT, WellTypedToT) import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.Value (RemFail(..)) -import Morley.Tezos.Address (Constrained(..), TxRollupL2Address(..)) +import Morley.Tezos.Address (Constrained(..)) import Morley.Tezos.Core (Mutez, Timestamp) -import Morley.Tezos.Crypto (parseHash) import Morley.Tezos.Crypto.BLS12381 qualified as BLS import Hedgehog.Gen.Tezos.Crypto.Timelock (genChestAndKey) @@ -192,23 +191,6 @@ STBytes -> genValueBytes def STMutez -> genValueMutez def STKeyHash -> genValueKeyHash - STTxRollupL2Address -> - VTxRollupL2Address . TxRollupL2Address - . unsafe . parseHash <$> Gen.element - -- TODO [#839]: implement BLS public key generation - [ "tz4UJqedFMBS7FjAqvZojJMPNd59MLm2hkuc" - , "tz4Y7kRVfDH2XGQtjc19ppJqejL4CBVmxHED" - , "tz4LVHYD4P4T5NHCuwJbxQvwVURF62seE3Qa" - , "tz4MwL5iRbyHvVxH9N69GCeDmYCqbQtewr7R" - , "tz4AZhg8GuahEs2Uo7dFZxVZwEgNKirtYMhY" - , "tz4D77UuwdqbmDd7Xh9VNbFRjDiqWbBeWqud" - , "tz4SYR9zvak9GohAEENUjPk7zAQo46wo6vNE" - , "tz4UWDSphLswG5xtBwGnodCGL7FBzN21EKSQ" - , "tz49e42Nbrc15PuT7RgkGqC6Xi3w5jEzEzH1" - , "tz4F1Nd91Fc3BUCxTCnFaccjnn2hH4W3Bd8X" - , "tz4MVuy2j5GCjPZQg7cxadPiNWq2nsRA392Y" - , "tz4StvWhTeDnVpGspXKbfuhuVXhZ1jkAp7Yq" - ] STBls12381Fr -> VBls12381Fr <$> genBls12381Fr STBls12381G1 -> VBls12381G1 <$> genBls12381G1 STBls12381G2 -> VBls12381G2 <$> genBls12381G2 diff --git a/src/Hedgehog/Gen/Michelson/Untyped.hs b/src/Hedgehog/Gen/Michelson/Untyped.hs --- a/src/Hedgehog/Gen/Michelson/Untyped.hs +++ b/src/Hedgehog/Gen/Michelson/Untyped.hs @@ -27,6 +27,7 @@ import Prelude hiding (EQ, GT, LT) +import Data.Map qualified as Map import Data.Text qualified as T import Hedgehog (MonadGen(GenBase), Range) import Hedgehog.Gen qualified as Gen @@ -198,10 +199,15 @@ <*> genType <*> genSmallList genOp <*> genEntriesOrder - <*> Gen.list (Range.exponential 0 2) (genSomeView genOp) + <*> fmap UnsafeViewsSet (Gen.map (Range.exponential 0 2) genSomeViewWithName) + where + genSomeViewWithName = do + v <- genSomeView genOp + pure (viewName v, v) genEntriesOrder :: (MonadGen m) => m EntriesOrder -genEntriesOrder = Gen.enumBounded +genEntriesOrder = + mkEntriesOrder <$> Gen.shuffle (Map.keys $ unEntriesOrder canonicalEntriesOrder) genViewName :: (MonadGen m, GenBase m ~ Identity) => m ViewName genViewName = unsafe . mkViewName <$> Gen.text diff --git a/src/Hedgehog/Gen/Tezos/Crypto.hs b/src/Hedgehog/Gen/Tezos/Crypto.hs --- a/src/Hedgehog/Gen/Tezos/Crypto.hs +++ b/src/Hedgehog/Gen/Tezos/Crypto.hs @@ -7,6 +7,10 @@ , genSignature , genKeyHashTag , genKeyHash + , genPublicKey' + , genSecretKey' + , genKeyHash' + , genKeyType ) where import Hedgehog (MonadGen) @@ -14,28 +18,33 @@ import Hedgehog.Range qualified as Range import Morley.Tezos.Crypto - (KeyHash, KeyHashTag, PublicKey, SecretKey(..), Signature(..), allHashTags, hashKey, - signatureLengthBytes, toPublic) +import Hedgehog.Gen.Tezos.Crypto.BLS qualified as BLS import Hedgehog.Gen.Tezos.Crypto.Ed25519 qualified as Ed25519 import Hedgehog.Gen.Tezos.Crypto.P256 qualified as P256 import Hedgehog.Gen.Tezos.Crypto.Secp256k1 qualified as Secp256k1 +genKeyType :: MonadGen m => m KeyType +genKeyType = Gen.choice $ pure <$> [minBound..] + genPublicKey :: MonadGen m => m PublicKey -genPublicKey = toPublic <$> genSecretKey +genPublicKey = genPublicKey' genKeyType +genPublicKey' :: MonadGen m => m KeyType -> m PublicKey +genPublicKey' keyType = toPublic <$> genSecretKey' keyType + genSecretKey :: MonadGen m => m SecretKey -genSecretKey = Gen.choice - [ SecretKeyEd25519 <$> Ed25519.genSecretKey - , SecretKeySecp256k1 <$> Secp256k1.genSecretKey - , SecretKeyP256 <$> P256.genSecretKey - ] +genSecretKey = genSecretKey' genKeyType +genSecretKey' :: MonadGen m => m KeyType -> m SecretKey +genSecretKey' keyType = detSecretKey' <$> keyType <*> Gen.bytes (Range.singleton 32) + genSignature :: MonadGen m => m Signature genSignature = Gen.choice [ SignatureEd25519 <$> Ed25519.genSignature , SignatureSecp256k1 <$> Secp256k1.genSignature , SignatureP256 <$> P256.genSignature + , SignatureBLS <$> BLS.genSignature , SignatureGeneric <$> Gen.bytes (Range.singleton signatureLengthBytes) ] @@ -43,4 +52,7 @@ genKeyHashTag = Gen.element $ toList allHashTags genKeyHash :: MonadGen m => m KeyHash -genKeyHash = hashKey <$> genPublicKey +genKeyHash = genKeyHash' genKeyType + +genKeyHash' :: MonadGen m => m KeyType -> m KeyHash +genKeyHash' keyType = hashKey <$> genPublicKey' keyType diff --git a/src/Hedgehog/Gen/Tezos/Crypto/BLS.hs b/src/Hedgehog/Gen/Tezos/Crypto/BLS.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Gen/Tezos/Crypto/BLS.hs @@ -0,0 +1,23 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module Hedgehog.Gen.Tezos.Crypto.BLS + ( genPublicKey + , genSecretKey + , genSignature + ) where + +import Hedgehog (MonadGen) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +import Morley.Tezos.Crypto.BLS (PublicKey, SecretKey, Signature, detSecretKey, sign, toPublic) + +genPublicKey :: MonadGen m => m PublicKey +genPublicKey = toPublic <$> genSecretKey + +genSecretKey :: MonadGen m => m SecretKey +genSecretKey = detSecretKey <$> Gen.bytes (Range.singleton 32) + +genSignature :: MonadGen m => m Signature +genSignature = sign <$> genSecretKey <*> Gen.utf8 (Range.linear 0 100) Gen.unicode diff --git a/src/Test/Cleveland.hs b/src/Test/Cleveland.hs --- a/src/Test/Cleveland.hs +++ b/src/Test/Cleveland.hs @@ -12,6 +12,9 @@ , KindedAddress , ContractAddress , ImplicitAddress + , AddressWithAlias (..) + , ImplicitAddressWithAlias + , ContractAddressWithAlias , ContractHandle (..) , TransferData (..) , TypedContract (..) @@ -28,6 +31,7 @@ , scenarioNetwork , MonadScenario(..) , getMorleyClientEnv + , getOnlyRpcEnv -- * Emulation tests , testScenarioOnEmulator @@ -50,15 +54,19 @@ , runIO , resolveAddress , refillable + , refillables , newAddress , newAddresses , newFreshAddress + , importSecretKey , enumAliases , signBytes , signBinary , originate , Large (..) , transfer + , transferTicket + , unsafeTransferTicket , WithContractEvents (..) , ContractEvent (..) , calling @@ -101,11 +109,16 @@ , whenNetwork , ifEmulation , inBatch + , getTicketBalance + , getAllTicketBalances + , SomeTicket(..) -- * Address conversions , ToAddress(..) , ToL1Address(..) , ToL1TAddress(..) + , ToContractAddress(..) + , ToImplicitAddress(..) -- * Primitives re-exports , EntrypointRef (..) @@ -142,6 +155,7 @@ , expectCustomError , expectCustomError_ , expectCustomErrorNoArg + , expectCustomErrorAnyArg , expectNumericError , clarifyErrors @@ -184,9 +198,6 @@ -- * AsRPC , AsRPC.HasRPCRepr(AsRPC) , AsRPC.deriveRPC - , AsRPC.deriveRPCWithStrategy - , AsRPC.deriveManyRPC - , AsRPC.deriveManyRPCWithStrategy -- * Utilities , mapEach @@ -195,20 +206,24 @@ import Data.Default (Default(def)) -import Lorentz (EntrypointRef(..), Mutez, ToAddress(..), pattern DefEpName, tz) +import Lorentz (EntrypointRef(..), Mutez, noViews, pattern DefEpName, tz) import Morley.AsRPC qualified as AsRPC import Morley.Client (MorleyClientEnv(..)) import Morley.Client.TezosClient.Types (TezosClientEnv(..)) +import Morley.Client.Types + (AddressWithAlias(..), ContractAddressWithAlias, ImplicitAddressWithAlias) import Morley.Michelson.Interpret (MorleyLogs) import Morley.Michelson.Runtime (VotingPowers, mkVotingPowers, mkVotingPowersFromMap) +import Morley.Tezos.Address +import Morley.Tezos.Address.Alias import Morley.Util.Named import Test.Cleveland.Instances () import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions -import Test.Cleveland.Internal.Client +import Test.Cleveland.Internal.Client (ClientM, mkMorleyOnlyRpcEnvNetwork) import Test.Cleveland.Internal.Hedgehog -import Test.Cleveland.Internal.Pure +import Test.Cleveland.Internal.Pure (PureM) import Test.Cleveland.Internal.Scenario -import Test.Cleveland.Lorentz (ToL1Address(..), ToL1TAddress(..)) +import Test.Cleveland.Lorentz.Types import Test.Cleveland.Tasty.Internal import Test.Cleveland.Util diff --git a/src/Test/Cleveland/Instances.hs b/src/Test/Cleveland/Instances.hs --- a/src/Test/Cleveland/Instances.hs +++ b/src/Test/Cleveland/Instances.hs @@ -126,8 +126,7 @@ U.LAMBDA_REC va ty1 ty2 ops -> U.LAMBDA_REC va ty1 ty2 (withoutEsp' ops) U.DIP ops -> U.DIP $ withoutEsp' ops U.DIPN n ops -> U.DIPN n (withoutEsp' ops) - U.CREATE_CONTRACT va1 va2 c -> - U.CREATE_CONTRACT va1 va2 (U.mapContractCode withoutEsp c) + U.CREATE_CONTRACT va1 va2 c -> U.CREATE_CONTRACT va1 va2 (withoutEsp <$> c) i -> i instance HasErrorSrcPos U.Value where diff --git a/src/Test/Cleveland/Internal/Abstract.hs b/src/Test/Cleveland/Internal/Abstract.hs --- a/src/Test/Cleveland/Internal/Abstract.hs +++ b/src/Test/Cleveland/Internal/Abstract.hs @@ -31,95 +31,7 @@ -- Invalid contract notation "KT1VrFpBPwBTm3hsK7DB7SPmY8fTHJ3vY6sJ%mint" -- @ module Test.Cleveland.Internal.Abstract - ( ContractHandle (..) - , OriginateData (..) - , TransferData (..) - , Sender (..) - , Moneybag (..) - , UntypedOriginateData (..) - , TypedOriginateData (..) - , LargeOrigination (..) - , TypedContract (..) - , RunCode (..) - , ClevelandInput - , ClevelandResult - , ContractEvent (..) - - , DefaultAliasCounter (..) - , SpecificOrDefaultAlias (..) - - -- * Actions - , ClevelandOpsImpl (..) - , ClevelandMiscImpl (..) - , EmulatedImpl(..) - - , mapClevelandOpsImplExceptions - , mapClevelandMiscImplExceptions - - -- * Batching - , BatchResultMismatch(..) - , ClevelandOpsBatch - , runBatched - , batchedOpsImpl - , runOperationBatchM - , runSingleOperation - - -- * Validation - , AddressAndAlias(..) - , TransferFailure (..) - , TransferFailureReason (..) - , GenericTestError (..) - , ExpressionOrTypedValue (..) - - -- * Helpers - , auto - , ep - , mkDefaultAlias - - -- * Morley client re-exports - , Alias - , ImplicitAlias - , ContractAlias - , KindedAddress - , ContractAddress - , ImplicitAddress - - -- * Capability records - , ClevelandCaps(..) - , EmulatedCaps(..) - , NetworkCaps(..) - , HasClevelandCaps(..) - , senderL - , moneybagL - , getMiscCap - , getOpsCap - , HasEmulatedCaps(..) - , HasNetworkCaps(..) - - , MonadCleveland - , MonadEmulated - , MonadNetwork - , ClevelandT - , EmulatedT - , NetworkT - - -- * Log utilities - , LogsInfo - , ScenarioLogs(..) - , slAddr - , slLog - , logsL - , filterLogsByAddrL - , logsForAddress - , collectLogs - - -- * Network environment - , NetworkEnv(..) - , neMorleyClientEnvL - , neSecretKeyL - , neMoneybagAliasL - , neExplicitDataDirL - , neVerbosityL + ( module Test.Cleveland.Internal.Abstract ) where import Control.Lens (Each, each, filtered, makeLenses, makeLensesFor, makeLensesWith) @@ -163,54 +75,53 @@ -- the origination size limit, in multiple operations. data LargeOrigination = IsLarge | NotLarge -data OriginateData param st vd (large :: LargeOrigination) = - OriginateData +data OriginationType where + OTTypedLorentz :: Type -> Type -> Type -> OriginationType + OTTypedMorley :: Type -> Type -> Type -> OriginationType + OTUntyped :: OriginationType + +-- | Data common for all origination types. +type OriginateData :: OriginationType -> LargeOrigination -> Type +data OriginateData oty large = OriginateData { odName :: ContractAlias -- ^ Alias for the originated contract. , odBalance :: Mutez -- ^ Initial balance. - , odStorage :: st - -- ^ Initial storage. - , odContract :: Contract param st vd - -- ^ The contract itself. - -- - -- We are using Lorentz version here which is convenient. However, keep in - -- mind that if someone wants to test a contract from @.tz@ file, they should use - -- 'UntypedOriginateData'. , odDelegate :: Maybe KeyHash -- ^ Contract delegate. + , odContractAndStorage :: ODContractAndStorage oty } --- | Untyped version of OriginateData. It can be used for interaction with raw --- Michelson contracts -data UntypedOriginateData (large :: LargeOrigination) = UntypedOriginateData - { uodName :: ContractAlias - -- ^ Alias for the originated contract. - , uodBalance :: Mutez - -- ^ Initial balance. - , uodStorage :: U.Value - -- ^ Initial storage. - , uodContract :: U.Contract - -- ^ The contract itself. - , uodDelegate :: Maybe KeyHash - -- ^ Contract delegate. - } +type ODContractAndStorage :: OriginationType -> Type +data ODContractAndStorage oty where + -- | Lorentz contract and storage. + ODContractAndStorageLorentz :: + { odStorage :: st + -- ^ Initial storage. + , odContract :: Contract param st vd + -- ^ The contract itself. + -- + -- We are using Lorentz version here which is convenient. However, keep in + -- mind that if someone wants to test a contract from @.tz@ file, they should use + -- 'OTUntyped' origination type. + } -> ODContractAndStorage ('OTTypedLorentz param st vd) --- | Untyped version of OriginateData. It can be used for interaction with raw --- Michelson contracts -data TypedOriginateData cp st vd (large :: LargeOrigination) = TypedOriginateData - { todName :: ContractAlias - -- ^ Alias for the originated contract. - , todBalance :: Mutez - -- ^ Initial balance. - , todStorage :: st - -- ^ Initial storage. - , todContract :: T.Contract (T.ToT cp) (T.ToT st) - -- ^ The contract itself. - , todDelegate :: Maybe KeyHash - -- ^ Contract delegate. - } + -- | Untyped contract and storage. + ODContractAndStorageUntyped :: + { uodStorage :: U.Value + -- ^ Initial storage. + , uodContract :: U.Contract + -- ^ The contract itself. + } -> ODContractAndStorage 'OTUntyped + -- | Typed Morley contract and storage. + ODContractAndStorageTyped :: (NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp) => + { todStorage :: st + -- ^ Initial storage. + , todContract :: T.Contract (T.ToT cp) (T.ToT st) + -- ^ The contract itself. + } -> ODContractAndStorage ('OTTypedMorley cp st vd) + -- | Information about transfer operation. data TransferData = forall v addr. (NiceParameter v, ToL1Address addr) => TransferData @@ -226,15 +137,31 @@ -- for transfers to key addresses. } +-- | Information about transfer operation. +data TransferTicketData = + forall t addr. (T.WellTyped t, ToL1Address addr) => TransferTicketData + { ttdTo :: addr + -- ^ Receiver address for this transaction. + , ttdEntrypoint :: EpName + -- ^ An entrypoint to be called. + , ttdParameter :: T.Value ('T.TTicket t) + -- ^ Ticket and amount to transfer. + } + -- | A wrapper around t'T.Contract' to reduce awkwardness -data TypedContract cp st vd where - TypedContract :: T.Contract (T.ToT cp) (T.ToT st) -> TypedContract cp st vd +type TypedContract :: Type -> Type -> Type -> Type +newtype TypedContract cp st vd = TypedContract (T.Contract (T.ToT cp) (T.ToT st)) +-- | 'OriginateData' existential over 'OriginationType'. +data SomeOriginateData large where + SomeOriginateData :: OriginateData oty large -> SomeOriginateData large + -- | Designates an operation input. data ClevelandInput instance OperationInfoDescriptor ClevelandInput where type TransferInfo ClevelandInput = TransferData - type OriginationInfo ClevelandInput = UntypedOriginateData 'NotLarge + type TransferTicketInfo ClevelandInput = TransferTicketData + type OriginationInfo ClevelandInput = SomeOriginateData 'NotLarge type RevealInfo ClevelandInput = PublicKey type DelegationInfo ClevelandInput = Maybe KeyHash @@ -249,6 +176,7 @@ data ClevelandResult instance OperationInfoDescriptor ClevelandResult where type TransferInfo ClevelandResult = [ContractEvent] + type TransferTicketInfo ClevelandResult = [ContractEvent] type OriginationInfo ClevelandResult = OriginationInfo Result type RevealInfo ClevelandResult = RevealInfo Result type DelegationInfo ClevelandResult = DelegationInfo Result @@ -269,7 +197,7 @@ -- This is initialized to @moneybag@ address and then can be locally modified. -- -- Operations in `ClevelandOpsImpl` are affected by this address. -newtype Sender = Sender { unSender :: ImplicitAddress } +newtype Sender = Sender { unSender :: ImplicitAddressWithAlias } -- | Designates the address that gifts money to new addresses. -- @@ -281,7 +209,7 @@ -- moneybag is not necessary. If a user wraps a large piece of their script with -- 'Test.Cleveland.withSender' call and that changes the moneybag - this behaviour may be -- undesired and unexpected to the user. -newtype Moneybag = Moneybag { unMoneybag :: ImplicitAddress } +newtype Moneybag = Moneybag { unMoneybag :: ImplicitAddressWithAlias } -- | An alias with default value that can be used to define unique alias -- automatically. @@ -319,19 +247,25 @@ data ClevelandMiscImpl m = ClevelandMiscImpl { cmiRunIO :: forall res. HasCallStack => IO res -> m res -- ^ Runs an 'IO' action. - , cmiResolveAddress :: forall kind. HasCallStack => Alias kind -> m (KindedAddress kind) + , cmiResolveAddress :: forall kind. HasCallStack => AddressOrAlias kind -> m (AddressWithAlias kind) -- ^ Get the address of the implicit account / contract associated with the given alias. - , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddress + , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddressWithAlias -- ^ Generate a secret key and store it with given alias. -- If a key with this alias already exists, the corresponding address -- will be returned and no state will be changed. - , cmiGenFreshKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddress + , cmiImportKey :: HasCallStack => SecretKey -> SpecificOrDefaultAlias -> m ImplicitAddressWithAlias + -- ^ Import a given secret key. + , cmiGenFreshKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddressWithAlias -- ^ Generate a secret key and store it with given alias. -- Unlike 'cmiGenKey' this function overwrites the existing key when -- given alias is already stored. - , cmiSignBytes :: HasCallStack => ByteString -> ImplicitAddress -> m Crypto.Signature + , cmiSignBytes :: HasCallStack => ByteString -> ImplicitAddressWithAlias -> m Crypto.Signature -- ^ Get the signature of the preapplied operation. - , cmiOriginateLargeUntyped :: HasCallStack => Sender -> UntypedOriginateData 'IsLarge -> m ContractAddress + , cmiOriginateLargeUntyped + :: forall oty. HasCallStack + => Sender + -> OriginateData oty 'IsLarge + -> m ContractAddress -- ^ Originate a new raw Michelson contract that doesn't fit into the -- origination size limit, by executing multiple operation steps. -- @@ -356,7 +290,7 @@ => BigMapId k v -> m (Maybe [v]) -- ^ Retrieve all big_map values, given a big_map ID. -- Returns 'Nothing' when the big_map ID does not exist. - , cmiGetPublicKey :: HasCallStack => ImplicitAddress -> m Crypto.PublicKey + , cmiGetPublicKey :: HasCallStack => ImplicitAddressWithAlias -> m Crypto.PublicKey -- ^ Get the public key associated with the given address. -- Fail if the given address is not an implicit account. , cmiGetDelegate :: HasCallStack => L1Address -> m (Maybe Crypto.KeyHash) @@ -396,8 +330,29 @@ => Sender -> RunCode cp st vd -> m (AsRPC st) -- ^ Execute a contract's code without originating it. -- The chain's state will not be modified. + , cmiTicketBalance + :: forall t. (T.HasNoOp t, T.Comparable t) + => L1Address -> ContractAddress -> T.Value t -> m Natural + -- ^ Get balance for a praticular ticket. + , cmiAllTicketBalances :: ContractAddress -> m [SomeTicket] + -- ^ Get balance for all tickets by scanning the contract's storage. } +data SomeTicket where + SomeTicket :: T.SingI t => T.Ticket (T.Value t) -> SomeTicket + +instance Buildable SomeTicket where + build (SomeTicket T.Ticket{..}) = + "Ticket with ticketer " +| tTicketer + |+ ", value " +| tData + |+ ", amount " +| tAmount + |+ "" + +instance Eq SomeTicket where + (SomeTicket (val1 :: T.Ticket (T.Value t1))) == (SomeTicket (val2 :: T.Ticket (T.Value t2))) + | Just Refl <- eqI @t1 @t2 = val1 == val2 + | otherwise = False + -- | The data needed to call the @/run_code@ RPC endpoint. data RunCode cp st vd = RunCode { rcContract :: Contract cp st vd @@ -740,6 +695,7 @@ , cmiResolveAddress = \address -> f $ cmiResolveAddress address , cmiSignBytes = \bs alias -> f $ cmiSignBytes bs alias , cmiGenKey = \alias -> f $ cmiGenKey alias + , cmiImportKey = f ... cmiImportKey , cmiGenFreshKey = \alias -> f $ cmiGenFreshKey alias , cmiOriginateLargeUntyped = \sender uodata -> f $ cmiOriginateLargeUntyped sender uodata , cmiComment = \t -> f $ cmiComment t @@ -761,6 +717,8 @@ , cmiThrow = cmiThrow , cmiUnderlyingImpl = f $ cmiUnderlyingImpl , cmiRunCode = f ... cmiRunCode + , cmiTicketBalance = f ... cmiTicketBalance + , cmiAllTicketBalances = f ... cmiAllTicketBalances } -- | A record with all the capabilities available to any cleveland test. diff --git a/src/Test/Cleveland/Internal/Actions.hs b/src/Test/Cleveland/Internal/Actions.hs --- a/src/Test/Cleveland/Internal/Actions.hs +++ b/src/Test/Cleveland/Internal/Actions.hs @@ -5,129 +5,15 @@ -- | Cleveland actions. module Test.Cleveland.Internal.Actions - ( MonadOps - , MonadTransfer - , MonadOriginate - , withSender - , withMoneybag - , runIO - , resolveAddress - , refillable - , newAddress - , newAddresses - , newFreshAddress - , enumAliases - , signBytes - , signBinary - , originate - , Large (..) - , transfer - , WithContractEvents (..) - , calling - , unsafeCalling - , inBatch - , importUntypedContract - , importContract - , noViews - , comment - , getBalance - , getStorage - , getFullStorage - , getSomeStorage - , getAllBigMapValues - , getAllBigMapValuesMaybe - , getBigMapSize - , getBigMapSizeMaybe - , getBigMapValueMaybe - , getBigMapValue - , getMorleyLogs - , getMorleyLogs_ - , getPublicKey - , getChainId - , advanceTime - , advanceLevel - , advanceToLevel - , getNow - , getLevel - , getApproximateBlockInterval - , getMinBlockTime - , runCode - , branchout - , offshoot - , getDelegate - , registerDelegate - , setDelegate - , setVotingPowers - , whenEmulation - , whenNetwork - , ifEmulation - , getMorleyClientEnv - - -- * Assertions - , failure - , assert - , (@==) - , (@/=) - , (@@==) - , (@@/=) - , checkCompares - , checkComparesWith - , evalJust - , evalRight - - -- * Calling views - , callView - , unsafeCallView - - -- * Exception handling - , attempt - , catchTransferFailure - , checkTransferFailure - , expectTransferFailure - , expectFailedWith - , expectError - , expectCustomError - , expectCustomError_ - , expectCustomErrorNoArg - , expectNumericError - , clarifyErrors - -- ** TransferFailure predicates - , TransferFailurePredicate(..) - , shiftOverflow - , emptyTransaction - , badParameter - , gasExhaustion - , failedWith - , addressIs - -- ** @FAILWITH@ errors - , constant - , lerror - , customError - , customError_ - , customErrorNoArg - , numericError + ( module Exports ) where -import Test.Cleveland.Internal.Actions.Assertions -import Test.Cleveland.Internal.Actions.ExceptionHandling -import Test.Cleveland.Internal.Actions.Misc -import Test.Cleveland.Internal.Actions.Originate hiding (setDelegate) -import Test.Cleveland.Internal.Actions.Transfer -import Test.Cleveland.Internal.Actions.TransferFailurePredicate -import Test.Cleveland.Internal.Actions.View - --- | Synonym typeclass for monads where network operations can occur. --- --- This has instances for @MonadCleveland@ and @ClevelandOpsBatch@ contexts. --- --- Practically, if you want to use 'transfer' or 'originate' in a monad, add a --- 'MonadOps' constraint on it, f. ex.: --- --- > callEp1 :: MonadOps m => ContractHandle MyParam () () -> Integer -> m () --- > callEp1 ch = transfer ch . calling (ep @"Entrypoint1") -class (MonadTransfer m, MonadOriginate m) => MonadOps m -instance (MonadTransfer m, MonadOriginate m) => MonadOps m - --- Note: 'MonadOps' is a typeclass and not a constraint synonym because GHC (as --- of 9.0) is being silly and complaining about impredicative polymorphism when --- defining a constraint synonym with quantified constraints. +import Test.Cleveland.Internal.Actions.Assertions as Exports +import Test.Cleveland.Internal.Actions.ExceptionHandling as Exports +import Test.Cleveland.Internal.Actions.Misc as Exports +import Test.Cleveland.Internal.Actions.MonadOps as Exports +import Test.Cleveland.Internal.Actions.Originate as Exports hiding (initialData) +import Test.Cleveland.Internal.Actions.Transfer as Exports hiding (initialData) +import Test.Cleveland.Internal.Actions.TransferFailurePredicate as Exports +import Test.Cleveland.Internal.Actions.TransferTicket as Exports +import Test.Cleveland.Internal.Actions.View as Exports diff --git a/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs b/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs --- a/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs +++ b/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs @@ -8,12 +8,14 @@ ( module Test.Cleveland.Internal.Actions.ExceptionHandling ) where -import Data.Either.Validation (Validation(..)) import Data.List.NonEmpty qualified as NE import Fmt (Builder, build, indentF, unlinesF) -import Lorentz (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg) +import Lorentz + (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText) import Lorentz.Constraints +import Morley.Micheline.Class (fromExpression) +import Morley.Michelson.Untyped qualified as U import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions.Assertions import Test.Cleveland.Internal.Actions.Helpers @@ -56,37 +58,34 @@ checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m () checkTransferFailure err predicate = case go predicate of - Success () -> pass - Failure expectedOutcome -> failure $ unlinesF + Nothing -> pass + Just expectedOutcome -> failure $ unlinesF [ "Expected transfer to fail with an error such that:" , "" - , indentF 2 $ unlinesF expectedOutcome + , indentF 2 expectedOutcome , "" , "But these conditions were not met." , "Actual transfer error:" , indentF 2 $ build err ] where - go :: TransferFailurePredicate -> Validation (NonEmpty Builder) () + -- Collect descriptions of all failed predicates + -- Note that 'Nothing' signifies success here, and Just is a failure description. + go :: TransferFailurePredicate -> Maybe Builder go = \case - AndPredicate ps -> - first (fmtExpectedOutcomes "AND") (traverse_ go ps) - OrPredicate ps -> - case traverse_ go ps of - Success () -> Success () - Failure expectedOutcomes -> - if length expectedOutcomes == length ps - -- If all sub-predicates failed, then this predicate failed. - then Failure $ fmtExpectedOutcomes "OR" expectedOutcomes - -- If at least 1 sub-predicate succeeded, then this predicate succeeded. - else Success () - TransferFailurePredicate p -> first one $ p err + AndPredicate ps -> fmap (fmtExpectedOutcomes "AND") . nonEmpty . mapMaybe go $ toList ps + -- if all results are successful, i.e. 'Nothing', the result is 'Nothing' + OrPredicate ps -> fmtExpectedOutcomes "OR" <$> traverse go ps + -- if there is at least one success, i.e. 'Nothing', the result is 'Nothing' + TransferFailurePredicate desc p + | p err -> Nothing + | otherwise -> Just $ build desc - fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder + fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> Builder fmtExpectedOutcomes delimiter = \case - expectedOutcome :| [] -> one expectedOutcome + expectedOutcome :| [] -> expectedOutcome expectedOutcomes -> - one $ unlinesF + unlinesF [ "(" , indentF 2 $ unlinesF $ NE.intersperse delimiter expectedOutcomes , ")" @@ -136,6 +135,28 @@ ) => Label tag -> m a -> m () expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag) + +-- | Version of 'expectCustomError' that ignores the argument (or whether it +-- even exists) and only checks the tag. +expectCustomErrorAnyArg + :: ( HasCallStack, MonadCleveland caps m ) + => Label tag -> m a -> m () +expectCustomErrorAnyArg tag = expectTransferFailure $ failedWithPredicate + ("Contract failed with any custom error tagged with \"" <> build expectedTag <> "\"") + \expr -> + -- the more "proper" way to handle this would be to go over all possible cases + -- of 'CustomErrorArgRep', but it's polymorphic, and we don't have a wildcard + -- in the typed representation, so we'd have to try to run 'fromExpression's + -- for all possible argument types, and that's just not worth it. So we use + -- our knowledge of the untyped representation instead. -- @lierdakil + (Just expectedTag ==) $ fromExpression @U.Value expr & rightToMaybe >>= \case + U.ValueString text -> Just text + U.ValuePair (U.ValueString text) _ -> Just text + -- right combs can be represented as sequences of at least two elements + U.ValueSeq (U.ValueString text :| _ : _) -> Just text + _ -> Nothing + where + expectedTag = errorTagToMText tag -- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz -- numeric error. diff --git a/src/Test/Cleveland/Internal/Actions/Misc.hs b/src/Test/Cleveland/Internal/Actions/Misc.hs --- a/src/Test/Cleveland/Internal/Actions/Misc.hs +++ b/src/Test/Cleveland/Internal/Actions/Misc.hs @@ -6,7 +6,6 @@ -- | The bulk of Cleveland actions. module Test.Cleveland.Internal.Actions.Misc ( module Test.Cleveland.Internal.Actions.Misc - , noViews ) where import Data.Singletons (demote) @@ -14,11 +13,13 @@ import Time (KnownDivRat, Second, Time, toNum) import Unsafe qualified (fromIntegral) -import Lorentz (BigMapId, Contract(..), DemoteViewsDescriptor, IsoValue, noViews) +import Lorentz (BigMapId, Contract(..), DemoteViewsDescriptor, IsoValue) import Lorentz.Bytes import Lorentz.Constraints import Morley.AsRPC (HasRPCRepr(..)) -import Morley.Client (MorleyClientEnv, OperationInfo(..), RunError(..), UnexpectedErrors(..)) +import Morley.Client + (MorleyClientEnv, MorleyOnlyRpcEnv, OperationInfo(..), RunError(..), UnexpectedErrors(..)) +import Morley.Client.Types (ImplicitAddressWithAlias, awaAddress) import Morley.Michelson.Runtime (ExecutorError'(..), VotingPowers) import Morley.Michelson.Runtime.GState (GStateUpdateError(..)) import Morley.Michelson.Runtime.Import qualified as Runtime @@ -26,18 +27,19 @@ import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.AnnotatedValue (castTo, getT, value) import Morley.Michelson.Untyped qualified as U -import Morley.Tezos.Address (unImplicitAddress) -import Morley.Tezos.Address.Alias (Alias(..)) +import Morley.Tezos.Address +import Morley.Tezos.Address.Alias import Morley.Tezos.Core (ChainId, Mutez, Timestamp) -import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature) +import Morley.Tezos.Crypto (KeyHash, PublicKey, SecretKey, Signature) import Morley.Util.SizedList qualified as SL import Morley.Util.SizedList.Types import Test.Cleveland.Instances () import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions.Assertions import Test.Cleveland.Internal.Actions.Helpers -import Test.Cleveland.Internal.Actions.MonadOps +import Test.Cleveland.Internal.Actions.MonadOpsInternal import Test.Cleveland.Internal.Actions.Transfer +import Test.Cleveland.Internal.Client (mkMorleyOnlyRpcEnvNetwork) import Test.Cleveland.Internal.Exceptions (fromPossiblyAnnotatedException) import Test.Cleveland.Lorentz.Import qualified as LorentzImport import Test.Cleveland.Lorentz.Types @@ -54,13 +56,13 @@ -- | Update the current sender on whose behalf transfers and originations are -- invoked. -withSender :: MonadCleveland caps m => ImplicitAddress -> m a -> m a +withSender :: (MonadCleveland caps m) => ImplicitAddressWithAlias -> m a -> m a withSender addr = local (set senderL (Sender addr)) -- | Update the current moneybag that transfers money on the newly created -- addresses. For the rare occasions when this is necessary. -withMoneybag :: MonadCleveland caps m => ImplicitAddress -> m a -> m a +withMoneybag :: (MonadCleveland caps m) => ImplicitAddressWithAlias -> m a -> m a withMoneybag addr = local (set moneybagL (Moneybag addr)) @@ -74,18 +76,24 @@ :: (HasCallStack, MonadCleveland caps m) => Alias kind -> m (KindedAddress kind) resolveAddress alias = do - withCap getMiscCap \cap -> cmiResolveAddress cap alias + withCap getMiscCap \cap -> awaAddress <$> cmiResolveAddress cap (AddressAlias alias) -- | Simple combinator that marks address as "refillable". -- -- If a refillable address lacks funds for the next operation, -- some funds will automatically be transferred to it. -refillable :: MonadCleveland caps m => m ImplicitAddress -> m ImplicitAddress -refillable action = do - addr <- action - withCap getMiscCap \cap -> cmiMarkAddressRefillable cap addr - pure addr +refillable :: (ToImplicitAddress addr, MonadCleveland caps m) => m addr -> m addr +refillable = fmap runIdentity . refillables . fmap pure +-- | Mark multiple addresses as 'refillable', useful with 'newAddresses' &c. +refillables + :: (ToImplicitAddress addr, Traversable f, MonadCleveland caps m) + => m (f addr) -> m (f addr) +refillables mkAddrs = do + addrs <- mkAddrs + withCap getMiscCap \cap -> traverse (cmiMarkAddressRefillable cap . toImplicitAddress) addrs + pure addrs + -- | If the given alias is already associated with an existing address, -- that address will be reused and returned. -- Otherwise, generate a new secret key and record it with given alias. @@ -98,7 +106,7 @@ -- * By default, the XTZ is transferred from the account associated with the @moneybag@ alias. -- This can be overridden with the @--cleveland-moneybag-alias@ command line option, the -- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withMoneybag'. -newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m ImplicitAddress +newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m ImplicitAddressWithAlias newAddress alias = do addrs <- newAddresses $ alias :< Nil case addrs of @@ -109,7 +117,7 @@ :: forall n n' caps m. (HasCallStack, MonadCleveland caps m, IsoNatPeano n n') => SizedList n SpecificOrDefaultAlias - -> m (SizedList n ImplicitAddress) + -> m (SizedList n ImplicitAddressWithAlias) newAddresses aliases = do addrs <- withCap getMiscCap \cap -> traverse (cmiGenKey cap) aliases Moneybag moneybag <- view moneybagL @@ -133,12 +141,14 @@ -- guaranteed to be fresh, i. e. no operations on it have been made. newFreshAddress :: (HasCallStack, MonadCleveland caps m) - => SpecificOrDefaultAlias -> m ImplicitAddress + => SpecificOrDefaultAlias -> m ImplicitAddressWithAlias newFreshAddress alias = do withCap getMiscCap \cap -> cmiGenFreshKey cap alias -- | Get the signature of the preapplied operation. -signBytes :: (HasCallStack, MonadCleveland caps m) => ByteString -> ImplicitAddress -> m Signature +signBytes + :: (HasCallStack, MonadCleveland caps m) + => ByteString -> ImplicitAddressWithAlias -> m Signature signBytes bytes signer = do withCap getMiscCap \cap -> cmiSignBytes cap bytes signer @@ -158,7 +168,7 @@ -- | Type-safer version of 'signBytes'. signBinary :: (HasCallStack, BytesLike bs, MonadCleveland caps m) - => bs -> ImplicitAddress -> m (TSignature bs) + => bs -> ImplicitAddressWithAlias -> m (TSignature bs) signBinary bs addr = TSignature <$> signBytes (toBytes bs) addr -- | Import an untyped contract from file. @@ -168,7 +178,7 @@ -- | Import a contract from file. -- -- The compiler must be able to infer the types of parameter, storage and views. --- In case there are no views or you don't care, you can use 'noViews'. +-- In case there are no views or you don't care, you can use 'Lorentz.noViews'. importContract :: ( HasCallStack, NiceParameter param, NiceStorage st , NiceViewsDescriptor vd, DemoteViewsDescriptor vd @@ -231,11 +241,11 @@ -- | Register the given implicit address as a delegate. registerDelegate :: (HasCallStack, MonadCleveland caps m) - => ImplicitAddress -> m () + => ImplicitAddressWithAlias -> m () registerDelegate addr = do caps <- ask r <- lift $ cmiAttempt (getMiscCap caps) $ - runReaderT (setDelegate addr $ Just $ unImplicitAddress addr) caps + runReaderT (setDelegate addr $ Just $ unImplicitAddress $ awaAddress addr) caps -- NB: we do some exception wrangling such that registerDelegate doesn't error -- out if an address is already a delegate. The primary reason for this is the -- disconnect between network, which remembers delegation state between @@ -251,7 +261,9 @@ | otherwise -> lift $ cmiThrow (getMiscCap caps) e -- | Set/unset delegate -setDelegate :: (HasCallStack, MonadCleveland caps m) => ImplicitAddress -> Maybe KeyHash -> m () +setDelegate + :: (HasCallStack, MonadCleveland caps m) + => ImplicitAddressWithAlias -> Maybe KeyHash -> m () setDelegate addr kh = void $ withSender addr $ withOpsCap \cap -> coiRunOperationBatch cap [OpDelegation kh] @@ -381,7 +393,7 @@ -- | Get the public key associated with given address. -- Fail if given address is not an implicit account. -getPublicKey :: (HasCallStack, MonadCleveland caps m) => ImplicitAddress -> m PublicKey +getPublicKey :: (HasCallStack, MonadCleveland caps m) => ImplicitAddressWithAlias -> m PublicKey getPublicKey addr = do withCap getMiscCap \cap -> cmiGetPublicKey cap addr @@ -577,4 +589,36 @@ -- This is considered a pretty low-level function, so it's better to avoid it in -- most cases. getMorleyClientEnv :: MonadNetwork caps m => m MorleyClientEnv -getMorleyClientEnv = asks (neMorleyClientEnv . getNetworkEnvCap) +getMorleyClientEnv = asks $ neMorleyClientEnv . getNetworkEnvCap + +-- | Get a 'MorleyOnlyRpcEnv' when running a test on network. Useful to run raw +-- network actions inside a network test. +-- +-- This is considered a pretty low-level function, so it's better to avoid it in +-- most cases. +getOnlyRpcEnv :: MonadNetwork caps m => [SecretKey] -> m MorleyOnlyRpcEnv +getOnlyRpcEnv sks = asks $ flip mkMorleyOnlyRpcEnvNetwork sks . getNetworkEnvCap + +-- | Import an (unencrypted) secret key as an alias. Can be used to get an +-- implicit address/alias with a specific key or key type. If you don't care +-- about the key or key type, consider using 'newAddress' or 'newAddresses' +-- instead. +importSecretKey + :: MonadCleveland caps m + => SecretKey -> SpecificOrDefaultAlias -> m ImplicitAddressWithAlias +importSecretKey sk alias = withCap getMiscCap \cap -> cmiImportKey cap sk alias + +-- | Get balance for a particular ticket. +getTicketBalance + :: ( MonadCleveland caps m, T.HasNoOpToT a, NiceComparable a + , ToL1Address addr, ToContractAddress contractAddr + ) + => addr -> contractAddr -> a -> m Natural +getTicketBalance addr tcktr val = + withCap getMiscCap \cap -> + cmiTicketBalance cap (toL1Address addr) (toContractAddress tcktr) (T.toVal val) + +-- | Get balance for all contract's tickets. +getAllTicketBalances :: (MonadCleveland caps m, ToContractAddress addr) => addr -> m [SomeTicket] +getAllTicketBalances addr = + withCap getMiscCap \cap -> cmiAllTicketBalances cap (toContractAddress addr) diff --git a/src/Test/Cleveland/Internal/Actions/MonadOps.hs b/src/Test/Cleveland/Internal/Actions/MonadOps.hs --- a/src/Test/Cleveland/Internal/Actions/MonadOps.hs +++ b/src/Test/Cleveland/Internal/Actions/MonadOps.hs @@ -8,33 +8,21 @@ ( module Test.Cleveland.Internal.Actions.MonadOps ) where -import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Internal.Actions.Originate +import Test.Cleveland.Internal.Actions.Transfer --- | Typeclass for monads where operations-related actions can occur. +-- | Synonym typeclass for monads where network operations can occur. -- --- This is implemented for 'MonadCleveland' and batch context. +-- This has instances for @MonadCleveland@ and @ClevelandOpsBatch@ contexts. -- --- Has 'Functor' as a superclass constraint for convenience, all the related methods --- require it. +-- Practically, if you want to use 'transfer' or 'originate' in a monad, add a +-- 'MonadOps' constraint on it, f. ex.: -- --- This is used internally to implement @originate@ and @transfer@. There is a --- more specific, more user-friendly @MonadOps@ class defined in --- "Test.Cleveland.Internal.Actions". -class Functor m => MonadOpsInternal m where - -- | Obtain 'ClevelandOpsImpl' suitable for the current \"monad\". - -- - -- In CPS style, because the \"monad\" can be actually not a monad, so - -- it can't work like 'ask' for 'ReaderT'. - withOpsCap :: (ClevelandOpsImpl m -> m a) -> m a - -instance MonadOpsInternal ClevelandOpsBatch where - withOpsCap mkAction = mkAction batchedOpsImpl +-- > callEp1 :: MonadOps m => ContractHandle MyParam () () -> Integer -> m () +-- > callEp1 ch = transfer ch . calling (ep @"Entrypoint1") +class (MonadTransfer m, MonadOriginate m) => MonadOps m +instance (MonadTransfer m, MonadOriginate m) => MonadOps m -instance (HasClevelandCaps caps, ClevelandBaseMonad caps ~ m) => MonadOpsInternal (ReaderT caps m) where - withOpsCap mkAction = do - opsCap :: ClevelandOpsImpl m <- asks getOpsCap - let opsCap' :: ClevelandOpsImpl (ReaderT caps m) = - ClevelandOpsImpl - { coiRunOperationBatch = lift ... coiRunOperationBatch opsCap - } - mkAction opsCap' +-- Note: 'MonadOps' is a typeclass and not a constraint synonym because GHC (as +-- of 9.0) is being silly and complaining about impredicative polymorphism when +-- defining a constraint synonym with quantified constraints. diff --git a/src/Test/Cleveland/Internal/Actions/MonadOpsInternal.hs b/src/Test/Cleveland/Internal/Actions/MonadOpsInternal.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/MonadOpsInternal.hs @@ -0,0 +1,40 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# OPTIONS_HADDOCK not-home #-} + +-- | Internally used typeclass for operations-related actions +module Test.Cleveland.Internal.Actions.MonadOpsInternal + ( module Test.Cleveland.Internal.Actions.MonadOpsInternal + ) where + +import Test.Cleveland.Internal.Abstract + +-- | Typeclass for monads where operations-related actions can occur. +-- +-- This is implemented for 'MonadCleveland' and batch context. +-- +-- Has 'Functor' as a superclass constraint for convenience, all the related methods +-- require it. +-- +-- This is used internally to implement @originate@ and @transfer@. There is a +-- more specific, more user-friendly @MonadOps@ class defined in +-- "Test.Cleveland.Internal.Actions". +class Functor m => MonadOpsInternal m where + -- | Obtain 'ClevelandOpsImpl' suitable for the current \"monad\". + -- + -- In CPS style, because the \"monad\" can be actually not a monad, so + -- it can't work like 'ask' for 'ReaderT'. + withOpsCap :: (ClevelandOpsImpl m -> m a) -> m a + +instance MonadOpsInternal ClevelandOpsBatch where + withOpsCap mkAction = mkAction batchedOpsImpl + +instance (HasClevelandCaps caps, ClevelandBaseMonad caps ~ m) => MonadOpsInternal (ReaderT caps m) where + withOpsCap mkAction = do + opsCap :: ClevelandOpsImpl m <- asks getOpsCap + let opsCap' :: ClevelandOpsImpl (ReaderT caps m) = + ClevelandOpsImpl + { coiRunOperationBatch = lift ... coiRunOperationBatch opsCap + } + mkAction opsCap' diff --git a/src/Test/Cleveland/Internal/Actions/Originate.hs b/src/Test/Cleveland/Internal/Actions/Originate.hs --- a/src/Test/Cleveland/Internal/Actions/Originate.hs +++ b/src/Test/Cleveland/Internal/Actions/Originate.hs @@ -8,21 +8,23 @@ ( module Test.Cleveland.Internal.Actions.Originate ) where -import Lorentz (Contract(..), NiceParameter, NiceStorage, NiceViewsDescriptor, toMichelsonContract) +import Lorentz (Contract(..), NiceViewsDescriptor) +import Data.Coerce (coerce) import Data.Constraint (Bottom(..)) import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError) import Morley.Client.Types -import Morley.Michelson.Typed (convertContract, toVal, untypeValue) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address +import Morley.Tezos.Address.Alias import Morley.Tezos.Core import Morley.Tezos.Crypto (KeyHash) import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions.Helpers -import Test.Cleveland.Internal.Actions.MonadOps +import Test.Cleveland.Internal.Actions.MonadOpsInternal +import Test.Cleveland.Lorentz.Types -- | Originate a new contract with given data. -- @@ -42,95 +44,89 @@ -- > originate "contract" initialStorage contract [tz|123micro|] Large -- -- The order is arbitrary, but each can be specified at most once. -originate :: forall contract r. ( HasCallStack, ContractClass contract - , OriginateFunc contract '[] r) - => ContractAlias -> ContractStorage contract -> contract -> r +originate + :: forall contract r. + ( HasCallStack, ContractClass contract, OriginateFunc contract '[] r) + => ContractAlias -> ContractStorage contract -> contract -> r originate = originate'r @contract @'[] ... initialData @contract ---------------------------------------------------------------------------- -- Main origination implementations ---------------------------------------------------------------------------- --- | Class implementing actual origination. -class Originator od res where - -- | Low-level polymorphic origination function. - -- It takes 'UntypedOriginateData', 'TypedOriginateData' or 'OriginateData', - -- and returns correspondingly an 'Address', or a 'ContractHandle', in a - -- suitable monad. - originateFn :: HasCallStack => od -> res +type OriginationResult :: OriginationType -> Type +type family OriginationResult a where + OriginationResult 'OTUntyped = ContractAddress + OriginationResult ('OTTypedMorley cp st vd) = ContractHandle cp st vd + OriginationResult ('OTTypedLorentz cp st vd) = ContractHandle cp st vd -instance (a ~ ContractHandle cp st vd, MonadOpsInternal m - , Originator (UntypedOriginateData large) (m ContractAddress)) - => Originator (OriginateData cp st vd large) (m a) where - originateFn od@OriginateData{ odContract=Contract{}, ..} = do - let uod = UntypedOriginateData @large - odName - odBalance - (untypeValue (toVal odStorage)) - (convertContract $ toMichelsonContract (odContract od)) - odDelegate - ContractHandle odName <$> originateFn uod +-- | Low-level polymorphic origination function. It takes arbitrary +-- 'OriginateData', and, depending on whether the data is typed or not, returns +-- respectively a 'ContractHandle', or a t'ContractAddress', in a suitable +-- monad (or an applicative functor in case of batched originations). +originateFn + :: (HasCallStack, Originator large m) + => OriginateData ot large -> m (OriginationResult ot) +originateFn od@OriginateData{..} = case odContractAndStorage of + ODContractAndStorageUntyped{} -> doOriginate od + ODContractAndStorageTyped _ T.Contract{} -> ContractHandle odName <$> doOriginate od + ODContractAndStorageLorentz _ Contract{} -> ContractHandle odName <$> doOriginate od -instance (a ~ ContractHandle cp st vd, MonadOpsInternal m - , Originator (UntypedOriginateData large) (m ContractAddress) - , NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp) - => Originator (TypedOriginateData cp st vd large) (m a) where - originateFn tod@TypedOriginateData{todContract = T.Contract{}, ..} = do - let uod = UntypedOriginateData @large - todName - todBalance - (untypeValue (toVal todStorage)) - (convertContract (todContract tod)) - todDelegate - ContractHandle todName <$> originateFn uod +-- | Class doing actual origination. +class MonadOpsInternal m => Originator large m where + doOriginate :: HasCallStack => OriginateData oty large -> m ContractAddress -instance (a ~ ContractAddress, MonadOpsInternal m) - => Originator (UntypedOriginateData 'NotLarge) (m a) where - originateFn uod = withOpsCap \opsCap -> - runSingleOperation opsCap "origination" (OpOriginate uod) \case +instance MonadOpsInternal m => Originator 'NotLarge m where + doOriginate od = withOpsCap \opsCap -> + runSingleOperation opsCap "origination" (OpOriginate $ SomeOriginateData od) \case OpOriginate addr -> Just addr _ -> Nothing -instance (HasClevelandCaps caps, base ~ ClevelandBaseMonad caps, a ~ ContractAddress) => - Originator (UntypedOriginateData 'IsLarge) (ReaderT caps base a) where - originateFn uod = do +instance MonadCleveland caps m => Originator 'IsLarge m where + doOriginate od = do sender <- view senderL - withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender uod + withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender od ---------------------------------------------------------------------------- -- ContractClass ---------------------------------------------------------------------------- +type ContractStorage contract = ContractStorage' (ContractOriginateType contract) + +type ContractStorage' :: OriginationType -> Type +type family ContractStorage' contract where + ContractStorage' 'OTUntyped = U.Value + ContractStorage' ('OTTypedMorley _ st _) = st + ContractStorage' ('OTTypedLorentz _ st _) = st + +initialData + :: ContractClass contract + => ContractAlias + -> ContractStorage contract + -> contract + -> OriginateData (ContractOriginateType contract) 'NotLarge +initialData name = OriginateData name zeroMutez Nothing ... initialStorageAndContract + -- | Type class that abstracts different contract types for the purpose of -- origination. class ContractClass contract where - type ContractStorage contract - type ContractOriginateData contract :: LargeOrigination -> Type - initialData - :: ContractAlias -> ContractStorage contract -> contract - -> ContractOriginateData contract 'NotLarge + type ContractOriginateType contract :: OriginationType + initialStorageAndContract + :: ContractStorage contract -> contract -> ODContractAndStorage (ContractOriginateType contract) instance ContractClass (Contract cp st vd) where - type ContractStorage (Contract cp st vd) = st - type ContractOriginateData (Contract cp st vd) = OriginateData cp st vd - initialData name store contract = OriginateData name zeroMutez store contract Nothing + type ContractOriginateType (Contract cp st vd) = 'OTTypedLorentz cp st vd + initialStorageAndContract = ODContractAndStorageLorentz instance ContractClass U.Contract where - type ContractStorage U.Contract = U.Value - type ContractOriginateData U.Contract = UntypedOriginateData - initialData name store contract = UntypedOriginateData name zeroMutez store contract Nothing + type ContractOriginateType U.Contract = 'OTUntyped + initialStorageAndContract = ODContractAndStorageUntyped -instance ContractClass (TypedContract cp st vd) where - type ContractStorage (TypedContract cp st vd) = st - type ContractOriginateData (TypedContract cp st vd) = TypedOriginateData cp st vd - initialData name store (TypedContract contract) = - TypedOriginateData - { todName = name - , todBalance = zeroMutez - , todStorage = store - , todContract = contract - , todDelegate = Nothing - } +instance (NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp) + => ContractClass (TypedContract cp st vd) where + type ContractOriginateType (TypedContract cp st vd) = 'OTTypedMorley cp st vd + initialStorageAndContract store (TypedContract contract) = + ODContractAndStorageTyped store contract ---------------------------------------------------------------------------- -- "The printf trick" @@ -141,11 +137,9 @@ -- If you see GHC asking for this constraint, you most likely need to add -- 'MonadOriginate' constraint on the return monad instead. class OriginateFunc contract (props :: [Prop]) r where - originate'r :: HasCallStack => ContractOriginateData contract (GetLarge props) -> r - default originate'r - :: (HasCallStack, Originator (ContractOriginateData contract (GetLarge props)) r) - => ContractOriginateData contract (GetLarge props) -> r - originate'r = originateFn + originate'r + :: HasCallStack + => OriginateData (ContractOriginateType contract) (GetLarge props) -> r -- | Enum for props we track duplicates of. data Prop = PropBalance | PropDelegate | PropLarge @@ -175,41 +169,44 @@ -- | Convenience synonym for constraints used in OriginateFunc instances. type OFConstraints ct prop props r = - ( ModifyOriginationData (ContractOriginateData ct) - , OriginateFunc ct (prop ': props) r + ( OriginateFunc ct (prop ': props) r , CheckDupProp prop props) -- | Set balance. instance OFConstraints ct 'PropBalance props r => OriginateFunc ct props (Mutez -> r) where - originate'r initData x = originate'r @ct @('PropBalance : props) $ setBalance x initData + originate'r initData x = originate'r @ct @('PropBalance : props) $ initData{odBalance = x} -- | Set delegate. instance OFConstraints ct 'PropDelegate props r => OriginateFunc ct props (KeyHash -> r) where - originate'r initData x = originate'r @ct @('PropDelegate : props) $ setDelegate x initData + originate'r initData x = originate'r @ct @('PropDelegate : props) $ initData{odDelegate = Just x} -- | Set large origination. instance (OFConstraints ct 'PropLarge props r, GetLarge props ~ 'NotLarge) => OriginateFunc ct props (Large -> r) where - originate'r initData Large = originate'r @ct @('PropLarge ': props) $ setLarge initData + originate'r initData Large = originate'r @ct @('PropLarge ': props) $ coerce initData +-- | Common constraints for terminating 'OriginateFunc' cases. +type TerminatingOFConstraints ct props m a = + (Originator (GetLarge props) m, a ~ OriginationResult (ContractOriginateType ct)) + -- | The terminating case for batched transfer. -instance Originator (ContractOriginateData ct (GetLarge props)) (ClevelandOpsBatch a) - => OriginateFunc ct props (ClevelandOpsBatch a) +instance TerminatingOFConstraints ct props ClevelandOpsBatch a + => OriginateFunc ct props (ClevelandOpsBatch a) where + originate'r = originateFn -- | The terminating case for Cleveland monads. -instance Originator (ContractOriginateData ct (GetLarge props)) (ReaderT cap base a) - => OriginateFunc ct props (ReaderT cap base a) +instance TerminatingOFConstraints ct props (ReaderT cap base) a + => OriginateFunc ct props (ReaderT cap base a) where + originate'r = originateFn -- | A convenient synonym class to require the terminating instance for a given -- monad without leaking too much implementation detail. class (MonadOpsInternal m - , forall ct props a. Originator (ContractOriginateData ct (GetLarge props)) (m a) - => OriginateFunc ct props (m a)) - => MonadOriginate m + , forall ct props a. TerminatingOFConstraints ct props m a => OriginateFunc ct props (m a) + ) => MonadOriginate m instance (MonadOpsInternal m - , forall ct props a. Originator (ContractOriginateData ct (GetLarge props)) (m a) - => OriginateFunc ct props (m a)) - => MonadOriginate m + , forall ct props a. TerminatingOFConstraints ct props m a => OriginateFunc ct props (m a) + ) => MonadOriginate m -- | Catchall incoherent instance to report argument errors. instance {-# INCOHERENT #-} @@ -228,24 +225,3 @@ -- -- Such origination cannot be batched (it simply may not fit). data Large = Large - --- | Type class implementing modifications to origination data. -class ModifyOriginationData od where - setBalance :: Mutez -> od large -> od large - setDelegate :: KeyHash -> od large -> od large - setLarge :: od 'NotLarge -> od 'IsLarge - -instance ModifyOriginationData (OriginateData cp st vd) where - setBalance bal od = od {odBalance = bal} - setDelegate kh od = od {odDelegate = Just kh} - setLarge OriginateData{..} = OriginateData{..} - -instance ModifyOriginationData (UntypedOriginateData) where - setBalance bal od = od {uodBalance = bal} - setDelegate kh od = od {uodDelegate = Just kh} - setLarge UntypedOriginateData{..} = UntypedOriginateData{..} - -instance ModifyOriginationData (TypedOriginateData cp st vd) where - setBalance bal od = od {todBalance = bal} - setDelegate kh od = od {todDelegate = Just kh} - setLarge TypedOriginateData{..} = TypedOriginateData{..} diff --git a/src/Test/Cleveland/Internal/Actions/Transfer.hs b/src/Test/Cleveland/Internal/Actions/Transfer.hs --- a/src/Test/Cleveland/Internal/Actions/Transfer.hs +++ b/src/Test/Cleveland/Internal/Actions/Transfer.hs @@ -18,7 +18,7 @@ import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Test.Cleveland.Internal.Abstract -import Test.Cleveland.Internal.Actions.MonadOps +import Test.Cleveland.Internal.Actions.MonadOpsInternal import Test.Cleveland.Lorentz.Types -- $setup @@ -187,6 +187,8 @@ type family InitialTransferMode addr :: TransferMode where InitialTransferMode ContractAddress = 'Unchecked InitialTransferMode ImplicitAddress = 'Unchecked + InitialTransferMode ContractAddressWithAlias = 'Unchecked + InitialTransferMode ImplicitAddressWithAlias = 'Unchecked InitialTransferMode L1Address = 'Unchecked InitialTransferMode (L1TAddress param _) = 'Checked param InitialTransferMode (ContractHandle param _ _) = 'Checked param diff --git a/src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs b/src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs --- a/src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs +++ b/src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs @@ -8,8 +8,8 @@ ( module Test.Cleveland.Internal.Actions.TransferFailurePredicate ) where -import Data.Either.Validation (Validation(..)) -import Fmt (Builder, build) +import Control.Lens (makeLenses) +import Fmt (Buildable(..), Builder) import Lorentz (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText, @@ -18,7 +18,6 @@ import Morley.Micheline (Expression, fromExpression, toExpression) import Morley.Michelson.Printer.Util (buildRenderDoc) import Morley.Michelson.Typed (Constrained(..), SomeConstant) -import Morley.Michelson.Typed qualified as T import Test.Cleveland.Internal.Abstract import Test.Cleveland.Lorentz.Types @@ -26,13 +25,30 @@ -- -- Predicates can be combined using the '&&' and '||' operators. data TransferFailurePredicate - = TransferFailurePredicate - (TransferFailure -> Validation Builder ()) - -- ^ A predicate that either returns () or, if it fails, - -- a message explaining what the expected outcome was. + = TransferFailurePredicate -- ^ Predicate with a description + TransferFailurePredicateDesc -- ^ The explanation of the expected outcome. + (TransferFailure -> Bool) -- ^ The predicate itself. | AndPredicate (NonEmpty TransferFailurePredicate) | OrPredicate (NonEmpty TransferFailurePredicate) +data TransferFailurePredicateDesc = TransferFailurePredicateDesc + { _tfpdNegated :: Bool + , _tfpdDescription :: Builder + } + +makeLenses ''TransferFailurePredicateDesc + +instance Buildable TransferFailurePredicateDesc where + build TransferFailurePredicateDesc{..} + | _tfpdNegated = "NOT (" <> build _tfpdDescription <> ")" + | otherwise = build _tfpdDescription + +instance IsString TransferFailurePredicateDesc where + fromString = tfpd . fromString + +tfpd :: Builder -> TransferFailurePredicateDesc +tfpd = TransferFailurePredicateDesc False + instance Boolean TransferFailurePredicate where AndPredicate l && AndPredicate r = AndPredicate $ l <> r AndPredicate l && r = AndPredicate $ l <> one r @@ -44,61 +60,71 @@ l || OrPredicate r = OrPredicate $ one l <> r l || r = OrPredicate $ one l <> one r + not = \case + TransferFailurePredicate msg p -> TransferFailurePredicate (msg & tfpdNegated %~ not) (not . p) + AndPredicate xs -> OrPredicate $ not <$> xs + OrPredicate xs -> AndPredicate $ not <$> xs + transferFailureReasonPredicate - :: (TransferFailureReason -> Validation Builder ()) + :: Builder + -> (TransferFailureReason -> Bool) -> TransferFailurePredicate -transferFailureReasonPredicate p = TransferFailurePredicate $ +transferFailureReasonPredicate b p = TransferFailurePredicate (tfpd b) \(TransferFailure _ reason) -> p reason -- | Asserts that interpretation of a contract failed due to an overflow error. shiftOverflow :: TransferFailurePredicate -shiftOverflow = transferFailureReasonPredicate \case - ShiftOverflow -> pass - _ -> Failure "Contract failed due to an overflow error" +shiftOverflow = transferFailureReasonPredicate + "Contract failed due to an overflow error" + (== ShiftOverflow) -- | Asserts that an action failed due to an attempt to transfer 0tz towards a simple address. emptyTransaction :: TransferFailurePredicate -emptyTransaction = transferFailureReasonPredicate \case - EmptyTransaction -> pass - _ -> Failure "Attempted to transfer 0tz to a simple address" +emptyTransaction = transferFailureReasonPredicate + "Attempted to transfer 0tz to a simple address" + (== EmptyTransaction) -- | Asserts that an action failed due to an attempt to call a contract with an invalid parameter. badParameter :: TransferFailurePredicate -badParameter = transferFailureReasonPredicate \case - BadParameter -> pass - _ -> Failure "Attempted to call a contract with a parameter of the wrong type" +badParameter = transferFailureReasonPredicate + "Attempted to call a contract with a parameter of the wrong type" + (== BadParameter) -- | Asserts that interpretation of a contract failed due to gas exhaustion. gasExhaustion :: TransferFailurePredicate -gasExhaustion = transferFailureReasonPredicate \case - GasExhaustion -> pass - _ -> Failure "Execution failed due to gas exhaustion" +gasExhaustion = transferFailureReasonPredicate + "Execution failed due to gas exhaustion" + (== GasExhaustion) -- | Asserts that interpretation of a contract ended with @FAILWITH@, throwing the given error. -- -- This function should be used together with one of the "@FAILWITH@ constructors" -- (e.g. 'constant', 'customError'). failedWith :: SomeConstant -> TransferFailurePredicate -failedWith expectedFailWithVal = transferFailureReasonPredicate \case - FailedWith (EOTVExpression actualFailWithExpr) _ - | actualFailWithExpr `isEq` expectedFailWithVal -> pass - FailedWith (EOTVTypedValue actualFailWithVal) _ - | toExpression actualFailWithVal `isEq` expectedFailWithVal -> pass - _ -> Failure $ "Contract failed with: " <> buildRenderDoc expectedFailWithVal +failedWith expectedFailWithVal = failedWithPredicate + ("Contract failed with: " <> buildRenderDoc expectedFailWithVal) + (isEq expectedFailWithVal) where - isEq :: Expression -> SomeConstant -> Bool - isEq expr (SomeConstant (v :: T.Value t)) = - either (const False) (== v) (fromExpression @(T.Value t) expr) + isEq :: SomeConstant -> Expression -> Bool + isEq (SomeConstant v) = either (const False) (== v) . fromExpression +-- | Asserts that interpretation of a contract ended with @FAILWITH@, and the +-- error satisfies the given predicate. +failedWithPredicate :: Builder -> (Expression -> Bool) -> TransferFailurePredicate +failedWithPredicate msg valPredicate = transferFailureReasonPredicate msg $ \case + FailedWith eotv _ -> valPredicate $ case eotv of + EOTVExpression expr -> expr + EOTVTypedValue tv -> toExpression tv + _ -> False + -- | Asserts that the error occurred while interpreting the contract with the given address. addressIs :: ToAddress addr => addr -- ^ The expected address. -> TransferFailurePredicate -addressIs (toAddress -> expectedAddr) = TransferFailurePredicate \err -> do - let TransferFailure addrAndAlias _ = err - when (toAddress addrAndAlias /= expectedAddr) $ - Failure $ "Failure occurred in contract with address: " <> build expectedAddr +addressIs (toAddress -> expectedAddr) = TransferFailurePredicate + (tfpd $ "Failure occurred in contract with address: " <> build expectedAddr) + \(TransferFailure addrAndAlias _) -> toAddress addrAndAlias == expectedAddr ---------------------------------------------------------------------------- -- 'FAILWITH' errors diff --git a/src/Test/Cleveland/Internal/Actions/TransferTicket.hs b/src/Test/Cleveland/Internal/Actions/TransferTicket.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/TransferTicket.hs @@ -0,0 +1,56 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# OPTIONS_HADDOCK not-home #-} + +-- | Machinery for transferring tickets from implicit accounts. +module Test.Cleveland.Internal.Actions.TransferTicket + ( module Test.Cleveland.Internal.Actions.TransferTicket + ) where + +import Lorentz +import Morley.Client.Types +import Morley.Michelson.Typed (Dict(..), pattern VTicket) +import Morley.Tezos.Address +import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Internal.Actions.MonadOpsInternal +import Test.Cleveland.Lorentz.Types + +-- | Transfer tickets. +transferTicket + :: forall cp vd arg m addr ticketerAddr mname. + ( MonadOpsInternal m, NiceParameter arg, NiceComparable arg + , ImplicitAddressParameterHelper addr cp (Ticket arg) + , ToL1TAddress cp vd addr, ToAddress ticketerAddr + , HasEntrypointArg cp (EntrypointRef mname) (Ticket arg) + , HasCallStack + ) + => addr -> EntrypointRef mname -> ticketerAddr -> arg -> Natural -> m [ContractEvent] +transferTicket to' epRef + | (Dict, epName) <- useHasEntrypointArg @cp @_ @(Ticket arg) epRef + = unsafeTransferTicket to' epName + where _ = Dict @(ImplicitAddressParameterHelper addr cp (Ticket arg)) + +-- | Transfer tickets without checking the recipient can accept them. +unsafeTransferTicket + :: forall arg m addr ticketerAddr. + ( MonadOpsInternal m, NiceParameter arg, NiceComparable arg + , ToL1Address addr, ToAddress ticketerAddr + , HasCallStack + ) + => addr -> EpName -> ticketerAddr -> arg -> Natural -> m [ContractEvent] +unsafeTransferTicket (toL1Address -> ttdTo) ttdEntrypoint (toAddress -> tTicketer) tData tAmount = + withOpsCap \opsCap -> runSingleOperation opsCap "transfer_ticket" (OpTransferTicket ttData) \case + OpTransferTicket ops -> Just ops + _ -> Nothing + where + ttdParameter = VTicket tTicketer (toVal tData) tAmount + ttData = TransferTicketData{..} + +-- | Implicit address may only have the root entrypoint, so full parameter type +-- is exactly the argument parameter type. This is used to improve type +-- inference when using 'transferTicket' with implicit addresses. +type family ImplicitAddressParameterHelper addr cp arg :: Constraint where + ImplicitAddressParameterHelper ImplicitAddress cp arg = cp ~ arg + ImplicitAddressParameterHelper ImplicitAddressWithAlias cp arg = cp ~ arg + ImplicitAddressParameterHelper _ _ _ = () diff --git a/src/Test/Cleveland/Internal/Actions/View.hs b/src/Test/Cleveland/Internal/Actions/View.hs --- a/src/Test/Cleveland/Internal/Actions/View.hs +++ b/src/Test/Cleveland/Internal/Actions/View.hs @@ -14,8 +14,10 @@ import Lorentz (Contract(..), HasView, Label, NiceViewable, toVal) import Lorentz qualified as L import Morley.AsRPC +import Morley.Client.Types (awaAddress) import Morley.Michelson.Typed (pattern (:#)) import Morley.Michelson.Typed qualified as T +import Morley.Tezos.Address import Morley.Util.TypeLits (KnownSymbol, symbolValT') import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions.Assertions (failure) @@ -88,7 +90,7 @@ res <- runCode RunCode { rcAmount = 0 , rcBalance = contractBalance - , rcSource = Just sender' + , rcSource = Just $ awaAddress sender' , rcContract = ct , rcParameter = T.untypeValue $ T.toVal arg , rcStorage = T.untypeValue $ T.toVal (Nothing :: Maybe ret) diff --git a/src/Test/Cleveland/Internal/Client.hs b/src/Test/Cleveland/Internal/Client.hs --- a/src/Test/Cleveland/Internal/Client.hs +++ b/src/Test/Cleveland/Internal/Client.hs @@ -7,40 +7,16 @@ -- talks to a Tezos node and uses @octez-client@. module Test.Cleveland.Internal.Client - ( ClientM (..) - , runNetworkT - - -- * Capability implementations - , networkOpsImpl - , networkMiscImpl - - -- * Internals - , revealKeyUnlessRevealed - , setupMoneybagAddress - , ClientState(..) - , TestError(..) - , MoneybagConfigurationException (..) - - -- * Environment - , mkMorleyOnlyRpcEnvNetwork - - -- * Lens for 'NetworkEnv' - , neMorleyClientEnvL - , neSecretKeyL - , neMoneybagAliasL - , neExplicitDataDirL - - -- * Error types - , InternalNetworkScenarioError(..) + ( module Test.Cleveland.Internal.Client ) where import Control.Lens (_head, each, filtered) import Data.Aeson.Text qualified as J import Data.Constraint (withDict) -import Data.Default (def) import Data.Ratio ((%)) import Data.Set qualified as Set import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, secondsToNominalDiffTime) +import Data.Type.Equality (pattern Refl) import Fmt (Buildable(build), Builder, indentF, pretty, unlinesF, (+|), (|+)) import System.IO (hFlush) import Time (KnownDivRat, Second, Time, sec, threadDelay, toNum, toUnit) @@ -51,18 +27,18 @@ import Lorentz.Constraints.Scopes (NiceUnpackedValue) import Morley.AsRPC (AsRPC, HasRPCRepr(..), TAsRPC, notesAsRPC, rpcSingIEvi) import Morley.Client - (AliasBehavior(..), MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, runMorleyClientM) + (AliasBehavior(..), MorleyClientEnv, OperationInfo(..), RevealData(..), disableAlphanetWarning, + runMorleyClientM) import Morley.Client qualified as Client import Morley.Client.Action (Result) import Morley.Client.Action.Common (DelegationData(..), runErrorsToClientError) -import Morley.Client.Action.Reveal qualified as RevealRPC import Morley.Client.App (failOnTimeout, retryOnceOnTimeout) import Morley.Client.Full qualified as Client import Morley.Client.Logging (logInfo, logWarning) import Morley.Client.RPC.Error qualified as RPC (ClientRpcError(..), RunCodeErrors(..)) import Morley.Client.RPC.Types (AppliedResult(..), BlockConstants(bcHeader), BlockHeaderNoHash(bhnhLevel, bhnhTimestamp), - BlockId(..), IntOpEvent(..), OriginationScript(..), + BlockId(..), IntOpEvent(..), OperationHash, OriginationScript(..), ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize)) import Morley.Client.TezosClient.Impl qualified as TezosClient import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) @@ -71,7 +47,6 @@ (Expression, MichelinePrimitive(..), StringEncode(..), TezosInt64, TezosMutez(..), _ExpressionPrim, _ExpressionSeq, fromExpression, mpaArgsL, mpaPrimL, toExpression) import Morley.Michelson.Text (unMText) -import Morley.Michelson.TypeCheck (typeCheckContractAndStorage, typeCheckingWith) import Morley.Michelson.Typed (BigMapId, SomeAnnotatedValue(..), SomeContractAndStorage(..), toVal) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped qualified as U @@ -82,9 +57,9 @@ unsafeSubMutez) import Morley.Tezos.Crypto import Morley.Util.Constrained -import Morley.Util.Exception import Morley.Util.Named import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Internal.Common import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Lorentz (toL1Address) import Test.Cleveland.Util (ceilingUnit) @@ -197,23 +172,22 @@ (Nothing, Just addr) -> do unless neExplicitDataDir do ek <- runMorleyClientM setupEnv $ - (retryOnceOnTimeout ... TezosClient.getSecretKey) - (AddressAlias neMoneybagAlias) + retryOnceOnTimeout $ TezosClient.getSecretKey neMoneybagAlias void $ runMorleyClientM neMorleyClientEnv $ failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek - pure addr + pure $ Client.AddressWithAlias addr neMoneybagAlias (Nothing, Nothing) -> throwM $ NoMoneybagAddress neMoneybagAlias (Just ek, Just sa) | mkKeyAddress (toPublic ek) == sa -> do unless neExplicitDataDir $ void $ runMorleyClientM neMorleyClientEnv $ failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek - pure sa + pure $ Client.AddressWithAlias sa neMoneybagAlias | otherwise -> throwM $ TwoMoneybagKeys neMoneybagAlias ek sa (Just ek, Nothing) -> do runMorleyClientM neMorleyClientEnv $ failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek - return $ mkKeyAddress (toPublic ek) + return $ Client.AddressWithAlias (mkKeyAddress (toPublic ek)) neMoneybagAlias -- | Implementation that works with real network and uses @octez-node@ -- RPC and @octez-client@. @@ -229,27 +203,41 @@ mapClevelandMiscImplExceptions (addCallStack . exceptionHandler neMorleyClientEnv) ClevelandMiscImpl { cmiRunIO = liftIO - , cmiOriginateLargeUntyped = \(Sender sender) UntypedOriginateData{..} -> do - let originationScenario = - Client.originateLargeUntypedContract OverwriteDuplicateAlias uodName - (AddressResolved sender) uodBalance uodContract uodStorage Nothing uodDelegate + , cmiOriginateLargeUntyped = + \(Sender sender) OriginateData{..} -> do + let originationScenario :: Client.MorleyClientM (OperationHash, ContractAddress) + originationScenario = case odContractAndStorage of + ODContractAndStorageUntyped{..} -> + Client.originateLargeUntypedContract OverwriteDuplicateAlias odName + sender odBalance uodContract uodStorage Nothing odDelegate + ODContractAndStorageTyped{..} | T.Contract{} <- todContract -> + Client.originateLargeContract OverwriteDuplicateAlias odName + sender odBalance todContract (T.toVal todStorage) + Nothing odDelegate + ODContractAndStorageLorentz{..} | L.Contract{} <- odContract -> + Client.lOriginateLargeContract OverwriteDuplicateAlias odName + sender odBalance odContract odStorage Nothing odDelegate -- Note that tezos key reveal operation cost an additional fee -- so that's why we reveal keys in origination and transaction -- rather than doing it before scenario execution - (_, res) <- liftIO $ do + (_ :: OperationHash, res) <- liftIO $ do revealKeyUnlessRevealed neMorleyClientEnv sender runMorleyClientM neMorleyClientEnv originationScenario - comment $ "Originated large smart contract " +| uodName |+ " with address " <> pretty res + comment $ "Originated large smart contract " +| odName |+ " with address " <> pretty res pure res , cmiSignBytes = \hash signer -> liftIO $ runMorleyClientM neMorleyClientEnv $ -- We don't use password protected accounts in cleveland tests - Client.signBytes (AddressResolved signer) Nothing hash + Client.signBytes signer Nothing hash , cmiGenKey = \sodAlias -> do alias <- resolveSpecificOrDefaultAlias sodAlias liftIO $ runMorleyClientM neMorleyClientEnv $ Client.genKey alias + , cmiImportKey = \key sodAlias -> do + alias <- resolveSpecificOrDefaultAlias sodAlias + liftIO $ runMorleyClientM neMorleyClientEnv $ TezosClient.importKey True alias key + , cmiGenFreshKey = \sodAlias -> do alias <- resolveSpecificOrDefaultAlias sodAlias liftIO $ runMorleyClientM neMorleyClientEnv $ Client.genFreshKey alias @@ -265,6 +253,45 @@ , .. } where + cmiTicketBalance + :: forall t. (T.HasNoOp t, T.SingI t) + => L1Address -> ContractAddress -> T.Value t -> ClientM Natural + cmiTicketBalance owner ticketer value = liftIO . runMorleyClientM neMorleyClientEnv $ + Client.getTicketBalance owner Client.GetTicketBalance + { Client.gtbTicketer = ticketer + , Client.gtbContent = toExpression $ T.untypeValueHashable value + , Client.gtbContentType = toExpression $ T.starNotes @t + } + + cmiAllTicketBalances :: ContractAddress -> ClientM [SomeTicket] + cmiAllTicketBalances owner = do + tickets <- liftIO $ runMorleyClientM neMorleyClientEnv $ Client.getAllTicketBalances owner + forM tickets \Client.GetAllTicketBalancesResponse{..} -> do + uTy <- fromExpression gatbrContentType & \case + Right ty -> pure ty + Left err -> clientFailure $ unlinesF + [ "Failed to decode ticket value:" + , "Value:" + , indentF 2 $ build (J.encodeToTextBuilder gatbrContentType) + , "Decoding error:" + , indentF 2 $ build err + ] + T.withUType uTy \(_ :: T.Notes t) -> do + case fromExpression @(T.Value t) gatbrContent of + Right val -> + pure @ClientM $ SomeTicket T.Ticket + { tTicketer = Constrained gatbrTicketer + , tData = val + , tAmount = unStringEncode gatbrAmount + } + Left err -> clientFailure $ unlinesF + [ "Failed to decode ticket value:" + , "Value:" + , indentF 2 $ build (J.encodeToTextBuilder gatbrContentType) + , "Decoding error:" + , indentF 2 $ build err + ] + cmiGetBigMapValueMaybe :: (NicePackedValue k, NiceUnpackedValue v) => BigMapId k v -> k -> ClientM (Maybe v) cmiGetBigMapValueMaybe bigMapId k = liftIO . runMorleyClientM neMorleyClientEnv $ Client.readBigMapValueMaybe bigMapId k @@ -320,13 +347,13 @@ , indentF 2 $ build err ] - cmiResolveAddress :: Alias kind -> ClientM (KindedAddress kind) + cmiResolveAddress :: AddressOrAlias kind -> ClientM (Client.AddressWithAlias kind) cmiResolveAddress = - liftIO . runMorleyClientM neMorleyClientEnv . Client.resolveAddress . AddressAlias + liftIO . runMorleyClientM neMorleyClientEnv . Client.resolveAddressWithAlias - cmiGetPublicKey :: ImplicitAddress -> ClientM PublicKey - cmiGetPublicKey = liftIO . runMorleyClientM neMorleyClientEnv . - (retryOnceOnTimeout ... TezosClient.getPublicKey) . AddressResolved + cmiGetPublicKey :: Client.ImplicitAddressWithAlias -> ClientM PublicKey + cmiGetPublicKey = + liftIO . runMorleyClientM neMorleyClientEnv . retryOnceOnTimeout . Client.getPublicKey getBalanceHelper :: L1AddressKind kind => KindedAddress kind -> ClientM Mutez getBalanceHelper = liftIO . runMorleyClientM neMorleyClientEnv . Client.getBalance @@ -407,7 +434,7 @@ , rcpSource = rcSource , rcpLevel = rcLevel , rcpNow = rcNow - , rcpSender = Just sender + , rcpSender = Just $ Client.awaAddress sender } `catch` \case err@(RPC.RunCodeErrors errs) @@ -446,7 +473,7 @@ runOperationBatch :: MorleyClientEnv - -> ImplicitAddress + -> Client.ImplicitAddressWithAlias -> [OperationInfo ClevelandInput] -> ClientM [OperationInfo ClevelandResult] runOperationBatch env sender ops = do @@ -458,12 +485,33 @@ liftIO $ revealKeyUnlessRevealed env sender ops' <- forM ops \case - OpOriginate uod -> - OpOriginate <$> convertOriginateUntypedData uod - OpTransfer td -> - pure . OpTransfer $ convertTransferData td + OpOriginate (SomeOriginateData OriginateData{..}) -> do + SomeContractAndStorage odContract odStorage <- either throwM pure $ + typeCheckODContractAndStorageIfNeeded odContractAndStorage + pure $ OpOriginate Client.OriginationData + { odAliasBehavior = OverwriteDuplicateAlias + , odMbFee = Nothing + , .. + } + OpTransfer TransferData{..} -> + pure $ OpTransfer $ Client.TransactionData Client.TD + { tdReceiver = toL1Address tdTo + , tdAmount = tdAmount + , tdEpName = tdEntrypoint + , tdParam = toVal tdParameter + , tdMbFee = Nothing + } + OpTransferTicket TransferTicketData{..} + | T.VTicket ttdTicketTicketer (ttdTicketContents :: T.Value t) ttdTicketAmount <- ttdParameter + , Refl <- T.comparabilityImpliesNoNestedBigMaps @t + , Refl <- T.comparabilityImpliesNoOp @t + -> pure $ OpTransferTicket Client.TransferTicketData + { ttdDestination = L.toAddress $ toL1Address ttdTo + , ttdMbFee = Nothing + , .. + } OpReveal key -> - pure $ OpReveal RevealRPC.RevealData + pure $ OpReveal RevealData { rdPublicKey = key , rdMbFee = Nothing } @@ -475,11 +523,11 @@ let refill :: Word -> Client.MorleyClientM Word refill iter = do - void $ dryRunOperations (AddressResolved sender) ops' + void $ dryRunOperations sender ops' pure iter `catch` \errs -> do - when (iter > 3) $ throwM $ TooManyRefillIterations iter sender - realBalance <- Client.getBalance sender + when (iter > 3) $ throwM $ TooManyRefillIterations iter $ Client.awaAddress sender + realBalance <- Client.getBalance $ Client.awaAddress sender let handleRunErrors errs' | Just (arg #balance -> balance, arg #required -> required) <- findBalanceTooLow errs' = do @@ -519,7 +567,7 @@ | Just (RPC.RunCodeErrors err) <- fromException errs -> handleRunErrors err | otherwise -> throwM errs logInfo $ "Will transfer " +| amount |+ " from " +| moneybag |+ "" - void $ Client.lTransfer moneybag sender amount U.DefEpName () Nothing + void $ Client.lTransfer moneybag (Client.awaAddress sender) amount U.DefEpName () Nothing refill (iter + 1) -- loop addSafetyMutez x = fromMaybe x $ addMutez x safetyMutez minimalMutez = 5e5 @@ -527,7 +575,7 @@ safetyStorage = 20 approximateRequired balance = do -- dry-run as moneybag and estimate cost+burn+fees - (appliedResults, fees) <- unzip <$> dryRunOperations (AddressResolved moneybag) ops' + (appliedResults, fees) <- unzip <$> dryRunOperations moneybag ops' ProtocolParameters{..} <- Client.getProtocolParameters -- uses quite a bit of unsafe mutez arithmetic, but arguably -- if we end up running into overflow while computing the @@ -541,8 +589,9 @@ $ map opcostAndOriginationCount ops costPerByte = unTezosMutez ppCostPerByte opcostAndOriginationCount = \case - OpOriginate uod -> (uodBalance uod, originationSz) + OpOriginate (SomeOriginateData od) -> (odBalance od, originationSz) OpTransfer td -> (tdAmount td, 0) + OpTransferTicket _ -> (zeroMutez, 0) OpReveal _ -> (zeroMutez, 0) OpDelegation _ -> (zeroMutez, 0) storageDiff AppliedResult{..} = safetyStorage + Unsafe.fromIntegral @TezosInt64 @Natural arPaidStorageDiff @@ -554,16 +603,17 @@ \Fees: " +| totalFees |+ "; Storage burn cost: " +| storageBurnInMutez |+ "" pure $ fromMaybe zeroMutez $ subMutez required balance - refillable <- isAddressRefillable sender + refillable <- isAddressRefillable $ Client.awaAddress sender results <- liftIO $ runMorleyClientM env $ do when refillable $ do tookIters <- refill 0 when (tookIters > 1) $ logWarning $ "Refill of " +| sender |+ " took " +| tookIters |+ " iterations." - snd <$> Client.runOperations (AddressResolved sender) ops' + snd <$> Client.runOperations sender ops' forM_ results $ \case OpTransfer _ -> pass + OpTransferTicket _ -> pass OpOriginate addr -> do alias <- getAlias env addr comment $ "Originated smart contract '" +| alias |+ @@ -576,6 +626,7 @@ toClevelandResult :: OperationInfo Result -> ClientM (OperationInfo ClevelandResult) toClevelandResult = \case OpTransfer ops -> OpTransfer <$> mapM intOpEventToContractEvent ops + OpTransferTicket ops -> OpTransferTicket <$> mapM intOpEventToContractEvent ops OpOriginate ops -> pure $ OpOriginate ops OpReveal ops -> pure $ OpReveal ops OpDelegation ops -> pure $ OpDelegation ops @@ -605,7 +656,7 @@ toTy t = U.Ty t U.noAnn -dryRunOperations :: ImplicitAddressOrAlias +dryRunOperations :: Client.ImplicitAddressWithAlias -> [OperationInfo Client.ClientInput] -> Client.MorleyClientM [(AppliedResult, Mutez)] dryRunOperations s = \case @@ -633,7 +684,7 @@ case addr of ImplicitAddress{} -> AddressAndAlias addr <$> getAliasMaybe env addr ContractAddress{} -> AddressAndAlias addr <$> getAliasMaybe env addr - TxRollupAddress{} -> pure (AddressAndAlias addr Nothing) + SmartRollupAddress{} -> pure (AddressAndAlias addr Nothing) exceptionToTransferFailure :: MorleyClientEnv -> RPC.ClientRpcError -> ClientM TransferFailure exceptionToTransferFailure env = \case @@ -675,39 +726,10 @@ -- Helpers ---------------------------------------------------------------------------- -convertOriginateUntypedData - :: (MonadThrow m) - => UntypedOriginateData 'NotLarge -> m Client.OriginationData -convertOriginateUntypedData UntypedOriginateData{..} = do - SomeContractAndStorage contract storage <- - throwLeft . pure $ typeCheckingWith def $ - typeCheckContractAndStorage uodContract uodStorage - return Client.OriginationData - { odAliasBehavior = OverwriteDuplicateAlias - , odName = uodName - , odBalance = uodBalance - , odContract = contract - , odStorage = storage - , odMbFee = Nothing - , odDelegate = uodDelegate - } - -convertTransferData - :: TransferData -> Client.TransactionData -convertTransferData TransferData{ tdParameter = param :: p, ..} = - Client.TransactionData Client.TD - { tdReceiver = toL1Address tdTo - , tdAmount = tdAmount - , tdEpName = tdEntrypoint - , tdParam = toVal param - , tdMbFee = Nothing - } - -- | Runs 'Client.revealKeyUnlessRevealed' with given client environment. -revealKeyUnlessRevealed :: MorleyClientEnv -> ImplicitAddress -> IO () +revealKeyUnlessRevealed :: MorleyClientEnv -> Client.ImplicitAddressWithAlias -> IO () revealKeyUnlessRevealed env addr = runMorleyClientM env $ - -- We don't use password protected accounts in cleveland. - Client.revealKeyUnlessRevealed addr Nothing + Client.revealKeyUnlessRevealed addr ---------------------------------------------------------------------------- -- Validation diff --git a/src/Test/Cleveland/Internal/Common.hs b/src/Test/Cleveland/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Common.hs @@ -0,0 +1,28 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# OPTIONS_HADDOCK not-home #-} + +-- | Helpers common to all 'MonadCleveland' implementations +module Test.Cleveland.Internal.Common + ( module Test.Cleveland.Internal.Common + ) where + +import Data.Default (def) + +import Lorentz qualified as L +import Morley.Michelson.TypeCheck (TcError, typeCheckContractAndStorage, typeCheckingWith) +import Morley.Michelson.Typed qualified as T + +import Test.Cleveland.Internal.Abstract + +typeCheckODContractAndStorageIfNeeded + :: ODContractAndStorage oty + -> Either TcError T.SomeContractAndStorage +typeCheckODContractAndStorageIfNeeded = \case + ODContractAndStorageUntyped{..} -> + typeCheckingWith def $ typeCheckContractAndStorage uodContract uodStorage + ODContractAndStorageTyped{..} | T.Contract{} <- todContract -> + pure $ T.SomeContractAndStorage todContract (T.toVal todStorage) + ODContractAndStorageLorentz{..} | L.Contract{} <- odContract -> + pure $ T.SomeContractAndStorage (L.toMichelsonContract odContract) (T.toVal odStorage) diff --git a/src/Test/Cleveland/Internal/Exceptions.hs b/src/Test/Cleveland/Internal/Exceptions.hs --- a/src/Test/Cleveland/Internal/Exceptions.hs +++ b/src/Test/Cleveland/Internal/Exceptions.hs @@ -5,23 +5,10 @@ -- | This module defines common exception helpers. module Test.Cleveland.Internal.Exceptions - ( ExceptionAnnotation(..) - , annotateExceptions - , fromPossiblyAnnotatedException - - -- * Utilities - , lookupAnnEx - , insertAnnEx - , removeAnnEx - - -- * Specific annotations - , ErrorsClarification(..) - , ScenarioBranchName(..) - , CallStackAnnotation(..) - , addCallStack + ( module Exports ) where -import Test.Cleveland.Internal.Exceptions.Annotated -import Test.Cleveland.Internal.Exceptions.CallStack -import Test.Cleveland.Internal.Exceptions.ErrorsClarification -import Test.Cleveland.Internal.Exceptions.ScenarioBranchName +import Test.Cleveland.Internal.Exceptions.Annotated as Exports +import Test.Cleveland.Internal.Exceptions.CallStack as Exports +import Test.Cleveland.Internal.Exceptions.ErrorsClarification as Exports +import Test.Cleveland.Internal.Exceptions.ScenarioBranchName as Exports diff --git a/src/Test/Cleveland/Internal/Exceptions/CallStack.hs b/src/Test/Cleveland/Internal/Exceptions/CallStack.hs --- a/src/Test/Cleveland/Internal/Exceptions/CallStack.hs +++ b/src/Test/Cleveland/Internal/Exceptions/CallStack.hs @@ -6,8 +6,7 @@ -- | This module defines 'CallStackAnnotation' and required helpers and -- instances to use it with 'ExceptionAnnotation'. module Test.Cleveland.Internal.Exceptions.CallStack - ( CallStackAnnotation(..) - , addCallStack + ( module Test.Cleveland.Internal.Exceptions.CallStack ) where import Fmt (build, unlinesF) diff --git a/src/Test/Cleveland/Internal/Exceptions/ErrorsClarification.hs b/src/Test/Cleveland/Internal/Exceptions/ErrorsClarification.hs --- a/src/Test/Cleveland/Internal/Exceptions/ErrorsClarification.hs +++ b/src/Test/Cleveland/Internal/Exceptions/ErrorsClarification.hs @@ -6,7 +6,7 @@ -- | This module defines 'ErrorsClarification' and required instances to use it -- with 'ExceptionAnnotation'. module Test.Cleveland.Internal.Exceptions.ErrorsClarification - ( ErrorsClarification(..) + ( module Test.Cleveland.Internal.Exceptions.ErrorsClarification ) where import Fmt (Builder, nameF) diff --git a/src/Test/Cleveland/Internal/Exceptions/ScenarioBranchName.hs b/src/Test/Cleveland/Internal/Exceptions/ScenarioBranchName.hs --- a/src/Test/Cleveland/Internal/Exceptions/ScenarioBranchName.hs +++ b/src/Test/Cleveland/Internal/Exceptions/ScenarioBranchName.hs @@ -6,7 +6,7 @@ -- | This module defines 'ScenarioBranchName' and required instances to use it -- with 'ExceptionAnnotation'. module Test.Cleveland.Internal.Exceptions.ScenarioBranchName - (ScenarioBranchName(..) + ( module Test.Cleveland.Internal.Exceptions.ScenarioBranchName ) where import Fmt (Buildable(..), nameF, (+|), (|+)) diff --git a/src/Test/Cleveland/Internal/Hedgehog.hs b/src/Test/Cleveland/Internal/Hedgehog.hs --- a/src/Test/Cleveland/Internal/Hedgehog.hs +++ b/src/Test/Cleveland/Internal/Hedgehog.hs @@ -5,9 +5,7 @@ -- | Hedgehog-related helpers module Test.Cleveland.Internal.Hedgehog - ( MonadTest (..) - , evalIO - , testScenarioProps + ( module Test.Cleveland.Internal.Hedgehog ) where import Data.Char (isSpace) diff --git a/src/Test/Cleveland/Internal/Pure.hs b/src/Test/Cleveland/Internal/Pure.hs --- a/src/Test/Cleveland/Internal/Pure.hs +++ b/src/Test/Cleveland/Internal/Pure.hs @@ -5,51 +5,33 @@ -- | Integration with integrational testing engine (pun intended). module Test.Cleveland.Internal.Pure - ( PureM(..) - , runEmulatedT - - -- * Capability implementations - , PureState - , TestError(..) - , emulatedImpl - , clevelandOpsImpl - , clevelandMiscImpl - - -- * Initial environment for Emulated tests - , initEnv - - -- * Support functions - , moneybagAlias - - -- * Optics - , psSecretKeys - , psDefaultAliasesCounter - , psRefillableAddresses - , psNow - , psLevel - , psMinBlockTime - , psGState + ( module Test.Cleveland.Internal.Pure ) where -import Control.Lens (assign, at, makeLenses, modifying, to, (%=), (.=), (?=), (?~)) +import Unsafe qualified ((!!)) + +import Control.Lens (LensLike', assign, at, makeLenses, modifying, to, (%=), (.=), (?=), (?~)) +import Control.Lens.At (At, Index, IxValue) import Control.Lens.Unsound (lensProduct) import Control.Monad.Catch.Pure (CatchT, runCatchT) import Control.Monad.Writer (MonadWriter, WriterT, listen, runWriterT, tell) -import Data.Constraint (Dict(..), withDict, (\\)) +import Crypto.Number.Serialize.LE (os2ip) +import Data.Constraint (withDict, (\\)) import Data.Default (def) import Data.Map qualified as Map import Data.Ratio ((%)) import Data.Set qualified as Set +import Data.Type.Equality (pattern Refl) import Fmt (Buildable(..), Builder, build, pretty, unlinesF, (+|), (|+)) import Time (Second, toNum, toUnit) import Lorentz (Mutez, NiceComparable, pattern DefEpName) import Lorentz qualified as L -import Lorentz.Entrypoints (HasEntrypointArg, TrustEpName(..), useHasEntrypointArg) import Morley.AsRPC (HasRPCRepr(AsRPC), notesAsRPC, rpcStorageScopeEvi, valueAsRPC) import Morley.Client (OperationInfo(..)) +import Morley.Client.Types (AddressWithAlias(..)) import Morley.Michelson.Interpret - (InterpretError(..), InterpretResult(..), MichelsonFailed(..), MichelsonFailureWithStack(..)) + (InterpretError(..), MichelsonFailed(..), MichelsonFailureWithStack(..), ResultStateLogs(..)) import Morley.Michelson.Runtime hiding (ExecutorOp(..), transfer) import Morley.Michelson.Runtime qualified as Runtime import Morley.Michelson.Runtime.Dummy @@ -57,8 +39,8 @@ import Morley.Michelson.Runtime.GState (AddressStateFam, GState(..), ImplicitState(..), addressesL, genesisAddress, genesisSecretKey, gsChainIdL, gsContractAddressAliasesL, gsContractAddressesL, gsImplicitAddressAliasesL, - gsVotingPowersL, initGState, lookupBalance) -import Morley.Michelson.TypeCheck (TcError, typeCheckContractAndStorage, typeCheckingWith) + gsVotingPowersL, initGState, lookupBalance, toTicketKey) +import Morley.Michelson.TypeCheck (TcError) import Morley.Michelson.Typed (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), SomeVBigMap(..), ToT, Value, Value'(..), castM, fromVal, toVal) @@ -69,13 +51,14 @@ import Morley.Tezos.Address import Morley.Tezos.Address.Alias import Morley.Tezos.Core (Timestamp, timestampPlusSeconds, unsafeSubMutez, zeroMutez) -import Morley.Tezos.Crypto (KeyHash, SecretKey(..), detSecretKey, sign, toPublic) +import Morley.Tezos.Crypto (KeyHash, KeyType(..), SecretKey(..), detSecretKey', sign, toPublic) import Morley.Util.Constrained import Morley.Util.MismatchError import Morley.Util.Named import Morley.Util.Bimap qualified as Bimap import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Internal.Common import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Lorentz import Test.Cleveland.Util (ceilingUnit) @@ -133,12 +116,13 @@ runEmulatedT :: ImplicitAlias -> EmulatedT PureM a -> IO a runEmulatedT moneybagAlias' scenario = do let clevelandCaps = ClevelandCaps - { ccSender = Sender genesisAddress - , ccMoneybag = Moneybag genesisAddress + { ccSender = Sender awa + , ccMoneybag = Moneybag awa , ccMiscCap = clevelandMiscImpl , ccOpsCap = clevelandOpsImpl } caps = EmulatedCaps emulatedImpl clevelandCaps + awa = AddressWithAlias genesisAddress "moneybag" let pureM = runReaderT scenario caps env <- newIORef (initEnv moneybagAlias') (res, _logs) <- runWriterT $ runCatchT $ runReaderT (unPureM pureM) env @@ -158,37 +142,46 @@ } clevelandOpsImpl :: Sender -> ClevelandOpsImpl PureM -clevelandOpsImpl (Sender sender) = +clevelandOpsImpl (Sender (awaAddress -> sender)) = mapClevelandOpsImplExceptions (addCallStack . exceptionHandler) ClevelandOpsImpl { coiRunOperationBatch = mapM \case - OpOriginate UntypedOriginateData{..} -> do - OpOriginate <$> originate uodContract uodName uodStorage uodBalance uodDelegate - OpTransfer TransferData{..} -> do - let fromAddr = #from :! sender - let toAddr = #to :! toL1Address tdTo - refillable <- isAddressRefillable sender - when refillable $ do - balance <- getBalance sender - when (balance < tdAmount) $ do - let moneybag = #from :! genesisAddress - toSender = #to :! sender - void $ transfer @() moneybag toSender (unsafeSubMutez tdAmount balance) - (TrustEpName DefEpName) () - -- Here @toAddr@ is 'Address', so we can not check anything - -- about it and assume that entrypoint is correct. We pass - -- unit as contract parameter because it won't be checked - -- anyway. - emitOps <- transfer @() fromAddr toAddr tdAmount - (TrustEpName tdEntrypoint) tdParameter - - return $ OpTransfer $ emitOpToContractEvent <$> emitOps + OpOriginate (SomeOriginateData od) -> OpOriginate <$> originate od + OpTransfer TransferData{..} -> + OpTransfer <$> doTransfer sender tdTo tdAmount tdEntrypoint tdParameter + OpTransferTicket TransferTicketData{..} + | T.VTicket _ (_ :: T.Value t) _ <- ttdParameter + , Refl <- T.comparabilityImpliesNoOp @t + -> OpTransferTicket <$> + doTransfer sender ttdTo zeroMutez ttdEntrypoint ttdParameter OpReveal{} -> do -- We do not care about reveals in our Morley runtime return $ OpReveal () OpDelegation mbAddress -> OpDelegation <$> setDelegate sender mbAddress } +doTransfer + :: (T.ParameterScope (T.ToT v), IsoValue v, ToL1Address addr) + => ImplicitAddress + -> addr + -> Mutez + -> U.EpName + -> v + -> PureM [ContractEvent] +doTransfer sender to' amount entrypoint parameter = do + let fromAddr = #from :! sender + let toAddr = #to :! toL1Address to' + refillable <- isAddressRefillable sender + when refillable $ do + balance <- getBalance sender + when (balance < amount) $ do + let moneybag = #from :! genesisAddress + toSender = #to :! sender + void $ transfer moneybag toSender (unsafeSubMutez amount balance) DefEpName () + emitOps <- transfer fromAddr toAddr amount entrypoint parameter + + return $ emitOpToContractEvent <$> emitOps + emitOpToContractEvent :: EmitOperation -> ContractEvent emitOpToContractEvent EmitOperation{eoEmit=T.Emit{..},..} = ContractEvent { cePayload = case T.notesT emNotes of @@ -208,29 +201,36 @@ Left (err :: SomeException) -> throwM err , cmiResolveAddress = \case - a@ImplicitAlias{} -> resolveImplicit a - a@ContractAlias{} -> resolveContract a + AddressAlias a -> case a of + ImplicitAlias{} -> resolveAlias gsImplicitAddressAliasesL a + ContractAlias{} -> resolveAlias gsContractAddressAliasesL a + AddressResolved a -> case a of + ImplicitAddress{} -> resolveAddress gsImplicitAddressAliasesL a + ContractAddress{} -> resolveAddress gsContractAddressAliasesL a , cmiSignBytes = \bs addr -> do - sk <- getSecretKey addr + sk <- getSecretKey $ awaAddress addr liftIO $ sign sk bs , cmiGenKey = \sodAlias -> do alias <- resolveSpecificOrDefaultAlias sodAlias - smartGenKey Nothing alias + flip AddressWithAlias alias <$> smartGenKey Nothing alias + , cmiImportKey = \key sodAlias -> do + alias <- resolveSpecificOrDefaultAlias sodAlias + flip AddressWithAlias alias <$> importSecretKey key alias + , cmiGenFreshKey = \sodAlias -> do alias <- resolveSpecificOrDefaultAlias sodAlias existingAddr <- use (psGState . gsImplicitAddressAliasesL . at alias) - smartGenKey existingAddr alias + flip AddressWithAlias alias <$> smartGenKey existingAddr alias , cmiOriginateLargeUntyped = originateUntyped -- Comments are not supported by integrational testing engine (yet). , cmiComment = const pass - , cmiGetPublicKey = \addr -> do - toPublic <$> getSecretKey addr + , cmiGetPublicKey = fmap toPublic . getSecretKey . awaAddress , cmiGetDelegate = \(Constrained addr) -> addressState addr <&> case addr of ContractAddress{} -> csDelegate ImplicitAddress{} -> isDelegate @@ -257,9 +257,8 @@ where setAddressRefillable addr = psRefillableAddresses %= Set.insert addr - originateUntyped :: Sender -> UntypedOriginateData 'IsLarge -> PureM ContractAddress - originateUntyped _ UntypedOriginateData {..} = do - originate uodContract uodName uodStorage uodBalance uodDelegate + originateUntyped :: Sender -> OriginateData oty 'IsLarge -> PureM ContractAddress + originateUntyped _ = originate cmiGetBigMapValueMaybe :: forall k v. @@ -302,6 +301,30 @@ (valueAsRPC storage) \\ rpcStorageScopeEvi @t + cmiTicketBalance + :: forall t. (T.HasNoOp t, T.Comparable t) + => L1Address -> ContractAddress -> T.Value t -> PureM Natural + cmiTicketBalance (Constrained owner) ticketer value = case owner of + ContractAddress{} -> do + ContractState _ _ storage _ <- addressState owner + pure . getSum $ (`T.dfsFoldMapValue` storage) \case + VTicket ticketer' (value' :: Value arg) amount + | ticketer' == toAddress ticketer + , T.SomeValue value == T.SomeValue value' + -> Sum amount + _ -> mempty + ImplicitAddress{} -> do + ImplicitState{..} <- addressState owner + pure . fromMaybe 0 $ + isTickets ^. at (fst . toTicketKey $ T.VTicket (toAddress ticketer) value 0) + + cmiAllTicketBalances :: ContractAddress -> PureM [SomeTicket] + cmiAllTicketBalances owner = do + ContractState _ _ storage _ <- addressState owner + pure $ (`T.dfsFoldMapValue` storage) \case + VTicket tTicketer tData tAmount -> [SomeTicket T.Ticket{..}] + _ -> mempty + -- Generate a fresh address for a given alias. -- -- If this alias is not yet associated with any address, @@ -315,9 +338,22 @@ smartGenKey existingAddr alias@(ImplicitAlias aliasTxt) = do let seed = maybe aliasTxt (mappend aliasTxt . pretty) existingAddr - sk = detSecretKey (encodeUtf8 seed) - addr = detGenKeyAddress (encodeUtf8 seed) + -- octez-client will only generate tz1 keys (unless explicitly + -- instructed otherwise); we're a bit more lenient here, but we still + -- exclude tz4 keys, as those can't be used as delegates. + seedBytes = encodeUtf8 seed + seedInt = os2ip seedBytes + keyTypes = filter (/= KeyTypeBLS) [minBound..] + keyType = keyTypes Unsafe.!! + (fromIntegralOverflowing $ seedInt `mod` fromIntegral (length keyTypes)) + sk = detSecretKey' keyType seedBytes + importSecretKey sk alias + + importSecretKey :: SecretKey -> ImplicitAlias -> PureM ImplicitAddress + importSecretKey sk alias = do + let addr = mkKeyAddress (toPublic sk) + -- Save alias/address association. psGState . gsImplicitAddressAliasesL . at alias ?= addr -- Save the address's secret key. @@ -334,7 +370,7 @@ cmiRunCode :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st)) => Sender -> RunCode cp st vd -> PureM (AsRPC st) - cmiRunCode (Sender sender) (RunCode rcContract rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) = do + cmiRunCode (Sender (awaAddress -> sender)) (RunCode rcContract rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) = do contract@T.Contract{..} <- pure $ L.toMichelsonContract rcContract T.MkEntrypointCallRes _ (epc :: T.EntrypointCallT (T.ToT cp) arg) <- pure $ T.mkDefEntrypointCall cParamNotes @@ -343,7 +379,7 @@ knownContracts <- use $ psGState . gsContractAddressesL bigMapFinder <- registerInterpretation Runtime.mkBigMapFinder let tcBm :: forall (t :: T.T). T.SingI t => U.Value -> PureM (T.Value t) - tcBm = either (throwM . UnexpectedTypeCheckError) pure . + tcBm = either throwM pure . resolveRunCodeBigMaps bigMapFinder rcParameterT <- tcBm rcParameter rcStorageT <- tcBm rcStorage @@ -390,7 +426,7 @@ TransferFailure addr BadParameter EEUnexpectedParameterType addr _ -> return $ TransferFailure addr BadParameter - EEInterpreterFailed addr (InterpretError (MichelsonFailureWithStack{..}, _)) -> + EEInterpreterFailed addr (InterpretError{ieFailure=MichelsonFailureWithStack{..}}) -> case mfwsFailed of MichelsonFailedWith val -> return $ TransferFailure addr $ @@ -421,14 +457,29 @@ addressState addr = maybe (unknownAddress addr) pure =<< use (psGState . addressesL addr . at addr) -resolveImplicit :: ImplicitAlias -> PureM ImplicitAddress -resolveImplicit alias = do - use (psGState . gsImplicitAddressAliasesL . at alias) >>= maybe (unknownAlias alias) pure +resolveLens + :: (MonadState PureState m, At x) + => LensLike' (Const (Maybe (IxValue x))) GState x + -> (Index x -> m b) + -> (Index x -> IxValue x -> b) + -> Index x + -> m b +resolveLens f e c x = use (psGState . f . at x) >>= maybe (e x) (pure . c x) -resolveContract :: ContractAlias -> PureM ContractAddress -resolveContract alias = do - use (psGState . gsContractAddressAliasesL . at alias) >>= maybe (unknownAlias alias) pure +resolveAlias + :: (At x, Index x ~ Alias kind, IxValue x ~ KindedAddress kind) + => LensLike' (Const (Maybe (IxValue x))) GState x + -> Alias kind + -> PureM (AddressWithAlias kind) +resolveAlias f = resolveLens f unknownAlias $ flip AddressWithAlias +resolveAddress + :: ( x ~ Bimap.Bimap (Alias kind) (KindedAddress kind)) + => LensLike' (Const (Maybe (Index x))) GState x + -> KindedAddress kind + -> PureM (AddressWithAlias kind) +resolveAddress f = resolveLens (f . Bimap.flipped) unknownAddress AddressWithAlias + unknownAddress :: KindedAddress kind -> PureM whatever unknownAddress = throwM . CustomTestError . @@ -468,44 +519,38 @@ ---------------------------------------------------------------------------- transfer - :: forall cp vd epRef epArg addr. - (HasEntrypointArg cp epRef epArg, T.IsoValue epArg, L.ToTAddress cp vd addr) + :: (T.ParameterScope (T.ToT epArg), T.IsoValue epArg, L.ToAddress addr) => "from" :! ImplicitAddress -> "to" :! addr -> Mutez - -> epRef + -> U.EpName -> epArg -> PureM [EmitOperation] -transfer (arg #from -> from) (arg #to -> toAddr) money epRef param = - let L.TAddress to' = L.toTAddress @cp @vd toAddr in - case useHasEntrypointArg @cp @epRef @epArg epRef of - (Dict, epName) -> registerInterpretation do - executeGlobalOperations def $ one $ - Runtime.TransferOp $ TransferOperation - { toDestination = to' - , toCounter = 0 - , toTxData = TxData - { tdSenderAddress = Constrained from - , tdParameter = TxTypedParam (T.toVal param) - , tdEntrypoint = epName - , tdAmount = money - } - } +transfer (arg #from -> from) (arg #to -> toAddr) money epName param = do + registerInterpretation $ executeGlobalOperations $ one $ Runtime.TransferOp TransferOperation + { toDestination = L.toAddress toAddr + , toCounter = 0 + , toTxData = TxData + { tdSenderAddress = Constrained from + , tdParameter = TxTypedParam (T.toVal param) + , tdEntrypoint = epName + , tdAmount = money + } + } -- | Originate a contract with given initial storage and balance. Its -- address is returned. -originate :: U.Contract -> ContractAlias -> U.Value -> Mutez -> Maybe KeyHash -> PureM ContractAddress -originate uContract alias uStorage balance delegate = - case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of - Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr - Right (T.SomeContractAndStorage contract storage) -> do - counter <- gsCounter <$> use psGState - registerInterpretation . executeGlobalOrigination $ - (dummyOrigination storage contract counter) - { ooBalance = balance - , ooAlias = Just alias - , ooDelegate = delegate - } +originate :: OriginateData oty large -> PureM ContractAddress +originate OriginateData{..} = do + T.SomeContractAndStorage contract storage <- either (throwM . UnexpectedTypeCheckError) pure $ + typeCheckODContractAndStorageIfNeeded odContractAndStorage + counter <- gsCounter <$> use psGState + registerInterpretation . executeGlobalOrigination $ + (dummyOrigination storage contract counter) + { ooBalance = odBalance + , ooAlias = Just odName + , ooDelegate = odDelegate + } throwEE :: ExecutorError -> PureM a throwEE err = @@ -519,7 +564,7 @@ use $ psGState . gsContractAddressAliasesL . Bimap.flipped . at kindedAddr . to (AddressAndAlias kindedAddr) ImplicitAddress{} -> use $ psGState . gsImplicitAddressAliasesL . Bimap.flipped . at kindedAddr . to (AddressAndAlias kindedAddr) - _ -> + SmartRollupAddress{} -> pure $ AddressAndAlias kindedAddr Nothing -- | Runs a set of operations and updates the engine's state. @@ -537,9 +582,9 @@ where extractLogs :: Either ExecutorError (ExecutorRes, a) -> [ScenarioLogs] extractLogs = \case - Left (EEInterpreterFailed addr (InterpretError e)) -> [ScenarioLogs addr $ snd e] - Right (res, _) -> res ^. erInterpretResults <&> \(addr, InterpretResult{..}) -> - ScenarioLogs addr iurMorleyLogs + Left (EEInterpreterFailed addr InterpretError{..}) -> [ScenarioLogs addr ieLogs] + Right (res, _) -> res ^. erInterpretResults <&> + \(addr, SomeInterpretResult ResultStateLogs{..}) -> ScenarioLogs addr rslLogs _ -> [] -- | Interpret an action and return the result _without_ updating the engine's state. @@ -549,11 +594,11 @@ level <- use psLevel gState <- use psGState minBlockTime <- use psMinBlockTime - pure $ runExecutorM now level minBlockTime dummyMaxSteps gState action + pure $ runExecutorM now level minBlockTime dummyMaxSteps def gState action setDelegate :: ImplicitAddress -> Maybe KeyHash -> PureM () setDelegate addr mbKh = void $ registerInterpretation $ - executeGlobalOperations def $ one $ + executeGlobalOperations $ one $ Runtime.SetDelegateOp SetDelegateOperation { sdoContract = Constrained addr , sdoDelegate = mbKh diff --git a/src/Test/Cleveland/Internal/Scenario.hs b/src/Test/Cleveland/Internal/Scenario.hs --- a/src/Test/Cleveland/Internal/Scenario.hs +++ b/src/Test/Cleveland/Internal/Scenario.hs @@ -4,15 +4,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Test.Cleveland.Internal.Scenario - ( Scenario - , Scenario'(..) - , MonadScenario(..) - , scenarioEmulated - , scenarioNetwork - , withInitialNow - , withInitialLevel - , withMinBlockTime - , withChainId + ( module Test.Cleveland.Internal.Scenario ) where import Control.Monad.Reader (withReaderT) diff --git a/src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs b/src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs --- a/src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs +++ b/src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs @@ -5,15 +5,7 @@ -- | Internal utilities for unit testing. module Test.Cleveland.Lorentz.Internal.Entrypoints - ( -- * Entrypoint spec passed on the type level - testCompareContractEntrypointsT - - -- * Entrypoint spec passed as a value - , testCompareContractEntrypoints - - -- * Utility types - , ContractEPTypeTest - , ContractEPTest + ( module Test.Cleveland.Lorentz.Internal.Entrypoints ) where import Lorentz hiding (contract) diff --git a/src/Test/Cleveland/Lorentz/Types.hs b/src/Test/Cleveland/Lorentz/Types.hs --- a/src/Test/Cleveland/Lorentz/Types.hs +++ b/src/Test/Cleveland/Lorentz/Types.hs @@ -7,6 +7,7 @@ , L1TAddress (..) , ToContractAddress (..) + , ToImplicitAddress (..) , ToL1Address (..) , ToL1TAddress (..) , ToStorageType (..) @@ -29,6 +30,8 @@ import Lorentz.Address import Lorentz.Constraints +import Morley.Client.Types + (AddressWithAlias(..), ContractAddressWithAlias, ImplicitAddressWithAlias) import Morley.Tezos.Address import Morley.Tezos.Address.Alias @@ -69,9 +72,21 @@ instance ToContractAddress ContractAddress where toContractAddress = id +instance ToContractAddress ContractAddressWithAlias where + toContractAddress = awaAddress + instance ToContractAddress (ContractHandle cp st vd) where toContractAddress = chAddress +class ToImplicitAddress addr where + toImplicitAddress :: addr -> ImplicitAddress + +instance ToImplicitAddress ImplicitAddress where + toImplicitAddress = id + +instance ToImplicitAddress ImplicitAddressWithAlias where + toImplicitAddress = awaAddress + class ToL1Address addr where toL1Address :: addr -> L1Address @@ -83,6 +98,9 @@ instance L1AddressKind kind => ToL1Address (KindedAddress kind) where toL1Address = Constrained + +instance L1AddressKind kind => ToL1Address (AddressWithAlias kind) where + toL1Address = Constrained . awaAddress instance ToL1Address (ContractHandle cp st vd) where toL1Address = Constrained . chAddress diff --git a/src/Test/Cleveland/Michelson/Internal/Entrypoints.hs b/src/Test/Cleveland/Michelson/Internal/Entrypoints.hs --- a/src/Test/Cleveland/Michelson/Internal/Entrypoints.hs +++ b/src/Test/Cleveland/Michelson/Internal/Entrypoints.hs @@ -5,16 +5,7 @@ -- | Internal utilities for unit testing. module Test.Cleveland.Michelson.Internal.Entrypoints - ( EPList - , EPMismatch(.., EPComparisonResultOK) - , ignoreExtraEntrypoints - , compareEntrypoints - , contractMatchesEntrypoints - , contractCoversEntrypoints - , testContractEntrypoints - , assertEPComparisonSuccessful - , michelsonRoundtripContract - , michelineRoundtripContract + ( module Test.Cleveland.Michelson.Internal.Entrypoints ) where import Data.Aeson (eitherDecode, encode) diff --git a/src/Test/Cleveland/Tasty/Internal.hs b/src/Test/Cleveland/Tasty/Internal.hs --- a/src/Test/Cleveland/Tasty/Internal.hs +++ b/src/Test/Cleveland/Tasty/Internal.hs @@ -5,34 +5,7 @@ -- | This module is the internal implementation of "Test.Cleveland.Tasty". module Test.Cleveland.Tasty.Internal - ( - -- * Main - clevelandMain - , clevelandMainWithIngredients - , clevelandIngredients - , loadTastyEnv - - -- * Test cases - , testScenario - , testScenarioOnEmulator - , testScenarioOnNetwork - - , whenNetworkEnabled - - -- * Reading/setting options - , modifyNetworkEnv - - -- * Internals - , RunOnNetwork(..) - , RunOnEmulator(..) - , tastyEnvFromOpts - , onNetworkTag - , TastyEnvOpt(..) - , TastyEnv(..) - , mkTastyEnv - , mapTastyEnv - , memoize - , loadOptionSwitcher + ( module Test.Cleveland.Tasty.Internal ) where import Control.Concurrent (modifyMVar, withMVar) diff --git a/src/Test/Cleveland/Tasty/Internal/Options.hs b/src/Test/Cleveland/Tasty/Internal/Options.hs --- a/src/Test/Cleveland/Tasty/Internal/Options.hs +++ b/src/Test/Cleveland/Tasty/Internal/Options.hs @@ -8,15 +8,7 @@ -- -- They're used to configure "Test.Cleveland". module Test.Cleveland.Tasty.Internal.Options - ( clevelandOptions - , MoneybagAliasOpt(..) - , EndpointOpt(..) - , PathOpt(..) - , DataDirOpt(..) - , VerboseOpt(..) - , SecretKeyOpt(..) - , RunModeOpt(..) - , ContextLinesOpt(..) + ( module Test.Cleveland.Tasty.Internal.Options ) where import Control.Monad.Except (runExcept) diff --git a/src/Test/Cleveland/Tasty/Internal/Report.hs b/src/Test/Cleveland/Tasty/Internal/Report.hs --- a/src/Test/Cleveland/Tasty/Internal/Report.hs +++ b/src/Test/Cleveland/Tasty/Internal/Report.hs @@ -5,7 +5,7 @@ -- | Pretty-printers for reports in Tasty logs. module Test.Cleveland.Tasty.Internal.Report - ( formatError + ( module Test.Cleveland.Tasty.Internal.Report ) where import Data.Char (isPrint, isSpace) diff --git a/test/TestSuite/Cleveland/BalanceCheck.hs b/test/TestSuite/Cleveland/BalanceCheck.hs --- a/test/TestSuite/Cleveland/BalanceCheck.hs +++ b/test/TestSuite/Cleveland/BalanceCheck.hs @@ -8,7 +8,6 @@ import Test.Tasty (TestTree) -import Morley.Tezos.Address import Morley.Util.SizedList qualified as SL import Morley.Util.SizedList.Types import Test.Cleveland @@ -16,7 +15,7 @@ test_BalanceCheck :: TestTree test_BalanceCheck = testScenario "An address's balance can be checked" $ scenario do - test :: ImplicitAddress <- newFreshAddress auto + test <- newFreshAddress auto comment "balance is updated after transfer" transfer test [tz|100u|] diff --git a/test/TestSuite/Cleveland/CallStack.hs b/test/TestSuite/Cleveland/CallStack.hs --- a/test/TestSuite/Cleveland/CallStack.hs +++ b/test/TestSuite/Cleveland/CallStack.hs @@ -34,7 +34,7 @@ import Morley.Util.Interpolate (it, lit, litu) import Morley.Util.SizedList.Types import Test.Cleveland -import Test.Cleveland.Internal.Client (neMorleyClientEnvL) +import Test.Cleveland.Internal.Abstract (neMorleyClientEnvL) import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Internal.Pure (TestError(CustomTestError)) import Test.Cleveland.Tasty @@ -147,19 +147,19 @@ , testFailureIncludesCallStack "callstack points to signBytes" [lit| - void $ signBytes "" invalidAddr - ^^^^^^^^^^^^^^^^^^^^^^^^ + void $ signBytes "" invalidAddrWAlias + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do - void $ signBytes "" invalidAddr + void $ signBytes "" invalidAddrWAlias , testFailureIncludesCallStack "callstack points to signBinary" [lit| - void $ signBinary @ByteString "" invalidAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + void $ signBinary @ByteString "" invalidAddrWAlias + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do - void $ signBinary @ByteString "" invalidAddr + void $ signBinary @ByteString "" invalidAddrWAlias , testFailureIncludesCallStack "callstack points to originate with untyped" [lit| @@ -208,7 +208,7 @@ do -- force a failure by transfering from an unknown address transfer invalidAddr [tz|1u|] - & withSender invalidAddr + & withSender invalidAddrWAlias , testFailureIncludesCallStack "callstack points to call" [lit| @@ -372,6 +372,14 @@ do expectCustomErrorNoArg #noArgError pass + , testFailureIncludesCallStack "callstack points to expectCustomErrorAnyArg" + [lit| + expectCustomErrorAnyArg #anyCustomError pass + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + |] + do + expectCustomErrorAnyArg #anyCustomError pass + , testFailureIncludesCallStack "callstack points to expectNumericError" [lit| expectNumericError @MText [] "" pass @@ -423,11 +431,11 @@ , testFailureIncludesCallStack "callstack points to getPublicKey" [lit| - void $ getPublicKey invalidAddr - ^^^^^^^^^^^^^^^^^^^^^^^^ + void $ getPublicKey invalidAddrWAlias + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do - void $ getPublicKey invalidAddr + void $ getPublicKey invalidAddrWAlias , sabotageNetworkEnv $ testFailureIncludesCallStackOnNetwork "callstack points to getChainId on network" @@ -680,6 +688,7 @@ invalidAlias :: ContractAlias invalidAlias = "UnknownAlias" invalidAddr = [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|] + invalidAddrWAlias = AddressWithAlias invalidAddr "invalid-addr" invalidContractAddr = ContractAddress $ mkContractHashHack "asdf" invalidTAddr = ContractHandle @() @() @() "asdf" invalidContractAddr diff --git a/test/TestSuite/Cleveland/Delegates.hs b/test/TestSuite/Cleveland/Delegates.hs --- a/test/TestSuite/Cleveland/Delegates.hs +++ b/test/TestSuite/Cleveland/Delegates.hs @@ -14,19 +14,22 @@ test_Delegates :: [TestTree] test_Delegates = [ testScenario "Registering delegate works" $ scenario do - addr@(ImplicitAddress kh) <- newFreshAddress "delegated" + addr <- newFreshAddress "delegated" + let kh = unImplicitAddress $ toImplicitAddress addr transfer addr [tz|1milli|] -- just about enough to pay all the fees getDelegate addr @@== Nothing registerDelegate addr getDelegate addr @@== Just kh , testScenario "Setting delegate on origination works" $ scenario do - addr@(ImplicitAddress kh) <- newFreshAddress "delegated" + addr <- newFreshAddress "delegated" + let kh = unImplicitAddress $ toImplicitAddress addr transfer addr [tz|1milli|] -- just about enough to pay all the fees registerDelegate addr contract <- originate "idContract" () (idContract @()) kh getDelegate contract @@== Just kh , testScenario "Registering delegate twice doesn't error" $ scenario do - addr@(ImplicitAddress kh) <- newFreshAddress "delegated" + addr <- newFreshAddress "delegated" + let kh = unImplicitAddress $ toImplicitAddress addr transfer addr [tz|1milli|] -- just about enough to pay all the fees registerDelegate addr getDelegate addr @@== Just kh @@ -35,7 +38,8 @@ , testScenario "Setting/unsetting delegate explicitly works" $ scenario do addr <- newFreshAddress "delegated" transfer addr [tz|2milli|] - delegate@(ImplicitAddress delegateKh) <- newAddress "delegate" + delegate <- newAddress "delegate" + let delegateKh = unImplicitAddress $ toImplicitAddress delegate registerDelegate delegate getDelegate addr @@== Nothing setDelegate addr (Just delegateKh) @@ -43,9 +47,11 @@ setDelegate addr Nothing getDelegate addr @@== Nothing , testScenario "Can't set/unset delegate on a registered delegate" $ scenario do - addr@(ImplicitAddress kh) <- newFreshAddress "delegated" + addr <- newFreshAddress "delegated" + let kh = unImplicitAddress $ toImplicitAddress addr transfer addr [tz|1milli|] - delegate@(ImplicitAddress delegateKh) <- newAddress "delegate" + delegate <- newAddress "delegate" + let delegateKh = unImplicitAddress $ toImplicitAddress delegate registerDelegate delegate registerDelegate addr getDelegate addr @@== Just kh diff --git a/test/TestSuite/Cleveland/Emulated.hs b/test/TestSuite/Cleveland/Emulated.hs --- a/test/TestSuite/Cleveland/Emulated.hs +++ b/test/TestSuite/Cleveland/Emulated.hs @@ -50,7 +50,7 @@ , testScenarioOnEmulator "adds branch name to error" $ scenarioEmulated do branchout [ "" ?- void $ - signBytes "" [ta|tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM|] + signBytes "" (AddressWithAlias [ta|tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM|] "unknown-addr") ] & shouldFailWithMessage "" ] diff --git a/test/TestSuite/Cleveland/Entrypoints.hs b/test/TestSuite/Cleveland/Entrypoints.hs --- a/test/TestSuite/Cleveland/Entrypoints.hs +++ b/test/TestSuite/Cleveland/Entrypoints.hs @@ -9,6 +9,7 @@ import Morley.Michelson.Untyped +import Test.Cleveland (def) import Test.Cleveland.Michelson.Entrypoints import TestSuite.Cleveland.Lorentz.Entrypoints (expectFailure) @@ -26,6 +27,6 @@ (Ty (TPair n n n n (Ty TInt n) (Ty TInt n)) n)) n) n , contractStorage = Ty TUnit n , contractCode = [] - , entriesOrder = PSC - , contractViews = [] + , entriesOrder = def + , contractViews = def } diff --git a/test/TestSuite/Cleveland/ExpectFailure.hs b/test/TestSuite/Cleveland/ExpectFailure.hs --- a/test/TestSuite/Cleveland/ExpectFailure.hs +++ b/test/TestSuite/Cleveland/ExpectFailure.hs @@ -13,7 +13,6 @@ import Lorentz as L hiding (comment) -import Data.Either.Validation (Validation(Success)) import Fmt (Builder, jsonListF', pretty, unlinesF) import Hedgehog (Gen, Property, PropertyT, forAllWith, property) import Hedgehog.Gen qualified as Gen @@ -95,6 +94,26 @@ expectCustomErrorNoArg #customErrorNoArg $ transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") () + expectCustomErrorAnyArg #customError $ + transfer contractAddr $ calling (ep @"TriggerFailWithCustomError") () + + expectCustomErrorAnyArg #customErrorUnit1 $ + transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit1") () + + expectCustomErrorAnyArg #customErrorNoArg $ + transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") () + + shouldFailWithMessage "Contract failed with any custom error tagged with \"WrongErrorTag\"" $ + expectCustomErrorAnyArg #wrongErrorTag $ + transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") () + + shouldFailWithMessage "Contract failed with any custom error tagged with \"CustomError\"" $ + expectCustomErrorAnyArg #customError $ + transfer contractAddr $ calling (ep @"TriggerShiftOverflow") () + + shouldFailWithMessage "Expected an exception to be thrown, but it wasn't" $ + expectCustomErrorAnyArg #customErrorNoArg pass + expectNumericError errorTagMap (VoidResult False) $ transfer contractNumericAddr $ calling (ep @"VoidEP") $ mkVoid True @@ -228,7 +247,7 @@ predicate <- forAllWith (pretty . showPredicate) genTransferFailurePredicate case predicate of - TransferFailurePredicate _ -> pass + TransferFailurePredicate{} -> pass AndPredicate ps -> forM_ ps (isFlattened predicate) OrPredicate ps -> forM_ ps (isFlattened predicate) @@ -240,7 +259,7 @@ isFlattened :: TransferFailurePredicate -> TransferFailurePredicate -> PropertyT IO () isFlattened parentPredicate predicate = case predicate of - TransferFailurePredicate _ -> pass + TransferFailurePredicate{} -> pass AndPredicate ps -> do case parentPredicate of AndPredicate _ -> failedTest "Found 2 adjacent 'and' nodes" @@ -256,7 +275,8 @@ showPredicate :: TransferFailurePredicate -> Builder showPredicate = \case - TransferFailurePredicate _ -> "TransferFailurePredicate \\_ -> Success ()" + TransferFailurePredicate{} -> + "TransferFailurePredicate (TransferFailurePredicateDesc \"\" (const True))" AndPredicate ps -> pretty $ unlinesF [ "AndPredicate" @@ -271,10 +291,11 @@ genTransferFailurePredicate :: Gen TransferFailurePredicate genTransferFailurePredicate = Gen.recursive Gen.choice - [ pure $ TransferFailurePredicate \_ -> Success () + [ pure $ TransferFailurePredicate "" (const True) ] [ Gen.subterm2 genTransferFailurePredicate genTransferFailurePredicate (&&) , Gen.subterm2 genTransferFailurePredicate genTransferFailurePredicate (||) + , Gen.subterm genTransferFailurePredicate Prelude.not ] testFailWith diff --git a/test/TestSuite/Cleveland/ImplicitTickets.hs b/test/TestSuite/Cleveland/ImplicitTickets.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/ImplicitTickets.hs @@ -0,0 +1,66 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module TestSuite.Cleveland.ImplicitTickets + ( test_ticket_to_implicit + , test_ticket_from_implicit + ) where + +import Lorentz hiding (assert) +import Test.Tasty (TestTree) + +import Test.Cleveland + +import Morley.Util.SizedList.Types + +test_ticket_to_implicit :: TestTree +test_ticket_to_implicit = testScenario "sending tickets to implicit addresses works" $ scenario do + ticketer <- originate "ticketer" () $ ticketerContract @Integer + senderAddr ::< receiverAddr ::< Nil' <- newAddresses $ "sender" :< "receiver" :< Nil + + withSender senderAddr $ inBatch do + transfer ticketer $ calling def (123, 3) + transferTicket receiverAddr def ticketer (123 :: Integer) 1 + unsafeTransferTicket receiverAddr def ticketer (123 :: Integer) 1 + pure () + + getTicketBalance senderAddr ticketer (123 :: Integer) @@== 1 + getTicketBalance receiverAddr ticketer (123 :: Integer) @@== 2 + +test_ticket_from_implicit :: TestTree +test_ticket_from_implicit = testScenario "sending tickets from implicit addresses works" $ scenario do + ticketer <- originate "ticketer" () $ ticketerContract @Integer + tbh <- originate "ticketBlackHole" () $ ticketBlackHole @Integer + senderAddr <- newAddress "sender" + + withSender senderAddr $ inBatch do + transfer ticketer $ calling def (123, 3) + transferTicket tbh def ticketer 123 2 + unsafeTransferTicket tbh def ticketer (123 :: Integer) 1 + pure () + + getTicketBalance senderAddr ticketer (123 :: Integer) @@== 0 + +ticketerContract + :: forall t. (HasAnnotation t, NiceParameter t, NiceComparable t) + => Contract (t, Natural) () () +ticketerContract = defaultContract + $ unpair + # dip + ( nil + # sender + # contract @(Ticket t) + # assertSome [mt|Failed to convert to contract|] + # push 0 + ) + # unpair + # ticket + # assertSome [mt|Failed to create ticket|] + # transferTokens + # cons + # pair + +ticketBlackHole + :: forall t. (NiceParameter t, NiceComparable t, HasAnnotation t) + => Contract (Ticket t) () () +ticketBlackHole = defaultContract $ cdr # nil # pair diff --git a/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs b/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs --- a/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs +++ b/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs @@ -148,15 +148,18 @@ "testContractMatchesEntrypoints fails on wrong nested type" (idContract @MyEntrypoints1 @()) [( #do4, genBigPair 6)] & expectFailure [it| - pair (unit %param1) - - (pair %param2 (unit %param1) - - (pair %param2 (unit %param1) - - (pair %param2 (unit %param1) - - (pair %param2 (unit %param1) - - (pair %param2 - - (unit %param1) - - (bytes %param2)))))) - + (bytes %param2) + - pair + - (unit %param1) + - (pair %param2 + - (unit %param1) + - (pair %param2 + - (unit %param1) + - (pair %param2 + - (unit %param1) + - (pair %param2 + - (unit %param1) + - (pair %param2 (unit %param1) (bytes %param2)))))) + + pair (unit %param1) (bytes %param2) |] , testContractMatchesEntrypoints "testContractMatchesEntrypoints fails on missing entrypoints" diff --git a/test/TestSuite/Cleveland/MismatchError.hs b/test/TestSuite/Cleveland/MismatchError.hs --- a/test/TestSuite/Cleveland/MismatchError.hs +++ b/test/TestSuite/Cleveland/MismatchError.hs @@ -78,16 +78,11 @@ Actual: [pair unit nat bytes, pair nat int bool, pair nat nat] Mismatch: --- expected +++ actual - - [ pair int - + [ pair unit - nat - bytes - , pair nat - - unit - + int - bool - + , pair nat - + nat + - [ pair int nat bytes + - , pair nat unit bool + + [ pair unit nat bytes + + , pair nat int bool + + , pair nat nat ] |] @@ -102,13 +97,5 @@ expected = [itu| Unexpected storage type. Expected: int - Actual: pair unit - nat - bytes - Mismatch: - --- expected +++ actual - - int - + pair unit - + nat - + bytes + Actual: pair unit nat bytes |] diff --git a/test/TestSuite/Cleveland/MonadOps.hs b/test/TestSuite/Cleveland/MonadOps.hs --- a/test/TestSuite/Cleveland/MonadOps.hs +++ b/test/TestSuite/Cleveland/MonadOps.hs @@ -35,7 +35,7 @@ goBatch :: forall n n' m. (IsoNatPeano n n', Applicative m, MonadOps m) - => SizedList n ImplicitAddress -> m () + => SizedList n ImplicitAddressWithAlias -> m () goBatch addrs = for_ addrs \addr -> transfer addr (123 :: Mutez) -- NB: The same applies to 'MonadOriginate' and 'MonadTransfer' in functions diff --git a/test/TestSuite/Cleveland/PrettyFailWith.hs b/test/TestSuite/Cleveland/PrettyFailWith.hs --- a/test/TestSuite/Cleveland/PrettyFailWith.hs +++ b/test/TestSuite/Cleveland/PrettyFailWith.hs @@ -20,7 +20,7 @@ withSender addr do cont <- originate "failing" () failing transfer cont & - shouldFailWithMessage (fmt $ "failed with: \"" +| addr |+ "\"") + shouldFailWithMessage (fmt $ "failed with: \"" +| toAddress addr |+ "\"") failing :: Contract () () () failing = defaultContract $ car # sender # failWith # nil # pair diff --git a/test/TestSuite/Cleveland/PublicKeyToAddress.hs b/test/TestSuite/Cleveland/PublicKeyToAddress.hs --- a/test/TestSuite/Cleveland/PublicKeyToAddress.hs +++ b/test/TestSuite/Cleveland/PublicKeyToAddress.hs @@ -14,7 +14,6 @@ import Unsafe qualified (fromJust) import Lorentz as L hiding (comment) -import Morley.Tezos.Address import Test.Cleveland import Test.Cleveland.Instances () import Test.Cleveland.Internal.Abstract (SpecificOrDefaultAlias(..)) @@ -43,4 +42,4 @@ transfer c $ calling def addr1pk addr2 <- Unsafe.fromJust <$> getStorage @(Maybe Address) c - MkAddress addr1 @== addr2 + toAddress addr1 @== addr2 diff --git a/test/TestSuite/Cleveland/RefillableAddress.hs b/test/TestSuite/Cleveland/RefillableAddress.hs --- a/test/TestSuite/Cleveland/RefillableAddress.hs +++ b/test/TestSuite/Cleveland/RefillableAddress.hs @@ -30,6 +30,18 @@ transfer receiver (balanceSender + 1000) -- obviously more than sender has getBalance receiver @@== (balanceSender + 1000) + , testScenario "Multiple refillable addresses refill when transfer amount > balance" $ scenario do + addr1 ::< addr2 ::< Nil' <- refillables $ newAddresses $ enumAliases "refillable" + receiver <- newFreshAddress auto + balanceSender1 <- getBalance addr1 + balanceSender2 <- getBalance addr2 + + withSender addr1 do + transfer receiver (balanceSender1 + 1000) -- obviously more than sender has + withSender addr2 do + transfer receiver (balanceSender2 + 1000) -- obviously more than sender has + + getBalance receiver @@== (balanceSender1 + balanceSender2 + 2000) , testScenario "A refillable address refills when transfer amount == balance - 1 μtz" $ scenario do refillableAddr <- refillable $ newAddress "refillable" receiver <- newFreshAddress auto diff --git a/test/TestSuite/Cleveland/ResolveAddress.hs b/test/TestSuite/Cleveland/ResolveAddress.hs --- a/test/TestSuite/Cleveland/ResolveAddress.hs +++ b/test/TestSuite/Cleveland/ResolveAddress.hs @@ -10,7 +10,6 @@ import Test.Cleveland import Test.Cleveland.Internal.Abstract (SpecificOrDefaultAlias(SpecificAlias)) -import Test.Cleveland.Lorentz.Types (toContractAddress) import TestSuite.Util (idContract) test_resolves_address_of_contract :: TestTree @@ -25,4 +24,4 @@ testScenario "Resolves address of implicit account" $ scenario do let alias = "contract-test-1" expectedAddress <- newAddress $ SpecificAlias alias - resolveAddress alias @@== expectedAddress + resolveAddress alias @@== toImplicitAddress expectedAddress diff --git a/test/TestSuite/Cleveland/RunCode.hs b/test/TestSuite/Cleveland/RunCode.hs --- a/test/TestSuite/Cleveland/RunCode.hs +++ b/test/TestSuite/Cleveland/RunCode.hs @@ -158,7 +158,7 @@ , rcParameter = untypeValue $ toVal () , rcAmount = 456 , rcBalance = 123 - , rcSource = Just source + , rcSource = Just $ toImplicitAddress source , rcNow = Just (Timestamp 8) , rcLevel = Just 29 } >>= evalJust "Expected contract to return a `Some`" diff --git a/test/TestSuite/Cleveland/StorageCheck.hs b/test/TestSuite/Cleveland/StorageCheck.hs --- a/test/TestSuite/Cleveland/StorageCheck.hs +++ b/test/TestSuite/Cleveland/StorageCheck.hs @@ -22,7 +22,7 @@ import Morley.Michelson.Typed.AnnotatedValue import Test.Cleveland -import Test.Cleveland.Lorentz (ToContractAddress, embedContract) +import Test.Cleveland.Lorentz (embedContract) import TestSuite.Util (BigMapInStorage(..), idContract, saveInStorageContract) import TestSuite.Util.Contracts (contractsDir) diff --git a/test/TestSuite/Cleveland/Tasty/Report/Examples.hs b/test/TestSuite/Cleveland/Tasty/Report/Examples.hs --- a/test/TestSuite/Cleveland/Tasty/Report/Examples.hs +++ b/test/TestSuite/Cleveland/Tasty/Report/Examples.hs @@ -222,8 +222,8 @@ CallStack (from HasCallStack): |] -unknownAddr :: ImplicitAddress -unknownAddr = [ta|tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z|] +unknownAddr :: ImplicitAddressWithAlias +unknownAddr = AddressWithAlias [ta|tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z|] "unknown-addr" reportExamples :: [(String, EmulatedT PureM (), Text)] reportExamples = diff --git a/test/TestSuite/Cleveland/TicketBalance.hs b/test/TestSuite/Cleveland/TicketBalance.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/TicketBalance.hs @@ -0,0 +1,82 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module TestSuite.Cleveland.TicketBalance + ( test_ticket_balance + , test_all_ticket_balances + ) where + +import Fmt (Buildable, (+|), (|+)) +import Lorentz hiding (assert) +import Test.Tasty (TestTree) + +import Test.Cleveland + +import Morley.Michelson.Parser (notes) + +test_ticket_balance :: [TestTree] +test_ticket_balance = + [ testScenario "getTicketBalance works" $ scenario do + ticketer <- originate "ticketer" [] $ ticketerContract @Integer + + inBatch do + transfer ticketer $ calling def (3, 1) + transfer ticketer $ calling def (3, 2) + transfer ticketer $ calling def (3, 3) + pure () + + getTicketBalance ticketer ticketer (3 :: Integer) @@== 6 + + , testScenario "getTicketBalance works with annotated types" $ scenario do + ticketer <- originate "ticketer" [] $ ticketerContract @TestTy + + inBatch do + transfer ticketer $ calling def (TestLeft, 1) + transfer ticketer $ calling def (TestRight ((), ()), 2) + pure () + + getTicketBalance ticketer ticketer TestLeft @@== 1 + getTicketBalance ticketer ticketer (TestRight ((), ())) @@== 2 + ] + +data TestTy = TestLeft | TestRight ((), ()) + deriving stock Generic + deriving anyclass IsoValue + +instance HasAnnotation TestTy where + getAnnotation _ = + [notes|or :tyOr (unit %testLeft) (pair %testRight (unit %unit1 :ty1) (unit %unit2 :ty2))|] + +test_all_ticket_balances :: TestTree +test_all_ticket_balances = + testScenario "getAllTicketBalances works" $ scenario do + ticketer <- originate "ticketer" [] $ ticketerContract @Integer + + inBatch do + transfer ticketer $ calling def (1, 1) + transfer ticketer $ calling def (2, 2) + transfer ticketer $ calling def (3, 3) + pure () + + tickets <- getAllTicketBalances ticketer + tickets `has` SomeTicket (Ticket (toAddress ticketer) (toVal (1 :: Integer)) 1) + tickets `has` SomeTicket (Ticket (toAddress ticketer) (toVal (2 :: Integer)) 2) + tickets `has` SomeTicket (Ticket (toAddress ticketer) (toVal (3 :: Integer)) 3) + +has + :: (Eq (Element a), Buildable a, Buildable (Element a), MonadCleveland caps m, Container a) + => a -> Element a -> m () +has xs x = do + assert (x `elem` xs) $ "Expected " +| xs |+ " to contain " +| x |+ "" + +ticketerContract + :: (NiceComparable t, NiceParameter t, HasAnnotation t) + => Contract (t, Natural) [Ticket t] () +ticketerContract = defaultContract + $ unpair + # unpair + # ticket + # assertSome [mt|Failed to create ticket|] + # cons + # nil + # pair