diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,40 @@ +0.2.1 +===== +* [!1199](https://gitlab.com/morley-framework/morley/-/merge_requests/1199) + Replace removed HasTezosClient actions with TezosClient.Impl version. +* [!1212](https://gitlab.com/morley-framework/morley/-/merge_requests/1212) + Support contract events + + Untie cleveland operation results from morley-client. + + Introduce `ContractEvent` type for contract events. + + Introduce new `WithContractEvents` flag for `transfer`, which tells it to + return `[ContractEvent]`. +* [!1191](https://gitlab.com/morley-framework/morley/-/merge_requests/1191) + General cleanup + + Display contract's aliases in error messages when a transfer fails (emulator-mode only). +* [!1177](https://gitlab.com/morley-framework/morley/-/merge_requests/1177) + Distinguish implicit/contract aliases and addresses on the type level +* [!1187](https://gitlab.com/morley-framework/morley/-/merge_requests/1187) + Access MorleyClientEnv in network tests + + Add `NetworkCaps` carrying `NetworkEnv`. + + Replace `ScenarioCleveland` with `ScenarioNetwork`. + + Reimplement `scenario` as a function in `MonadScenario` typeclass. + + Rename `Scenario` to `Scenario'`, add `Scenario` synonym that bakes in + `MonadScenario` constraint. + + Allow `ifEmulation` to access `NetworkCaps` in the on-network branch. +* [!1168](https://gitlab.com/morley-framework/morley/-/merge_requests/1168) + Support a mix of RPC and non-RPC representations in `runCode` +* [!1137](https://gitlab.com/morley-framework/morley/-/merge_requests/1137) + Refactor Cleveland's originate\* and `transfer`/`transferMoney`/`call` + functions + + All 9 `originate*` functions are replaced with single `originate`, + optionally accepting initial balance (as `Mutez`) and whether it's a large + origination (using `Large` argument). + + `transfer`, `transferMoney` and `call` functions replaced by `transfer` and + two helpers, `calling` and `unsafeCalling`. + 0.2.0 ===== * [!1172](https://gitlab.com/morley-framework/morley/-/merge_requests/1172) 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.2.0 +version: 0.2.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 @@ -58,6 +58,14 @@ Test.Cleveland.Instances Test.Cleveland.Internal.Abstract Test.Cleveland.Internal.Actions + Test.Cleveland.Internal.Actions.Assertions + Test.Cleveland.Internal.Actions.ExceptionHandling + Test.Cleveland.Internal.Actions.Helpers + Test.Cleveland.Internal.Actions.Misc + Test.Cleveland.Internal.Actions.MonadOps + Test.Cleveland.Internal.Actions.Originate + Test.Cleveland.Internal.Actions.Transfer + Test.Cleveland.Internal.Actions.TransferFailurePredicate Test.Cleveland.Internal.Client Test.Cleveland.Internal.Exceptions Test.Cleveland.Internal.Hedgehog @@ -108,6 +116,7 @@ GADTs GeneralizedNewtypeDeriving ImportQualifiedPost + InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf @@ -187,6 +196,7 @@ other-modules: TestSuite.Cleveland.AddressRevealing TestSuite.Cleveland.Assertions + TestSuite.Cleveland.BadAddressReuse TestSuite.Cleveland.BalanceCheck TestSuite.Cleveland.BatchOperation TestSuite.Cleveland.BatchTransferCheck @@ -196,9 +206,11 @@ TestSuite.Cleveland.ChainIdGet TestSuite.Cleveland.ContractAllocation TestSuite.Cleveland.DFS + TestSuite.Cleveland.EmitMachinery TestSuite.Cleveland.EmptyImplicitAddress TestSuite.Cleveland.Emulated TestSuite.Cleveland.Entrypoints + TestSuite.Cleveland.ErrorMessages TestSuite.Cleveland.ExpectFailure TestSuite.Cleveland.FailureLogs TestSuite.Cleveland.Import @@ -207,11 +219,13 @@ TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator TestSuite.Cleveland.Lorentz.Entrypoints TestSuite.Cleveland.MismatchError + TestSuite.Cleveland.NetworkCaps TestSuite.Cleveland.NewAddressCheck TestSuite.Cleveland.OperationReplay TestSuite.Cleveland.PrettyFailWith TestSuite.Cleveland.PublicKeyToAddress TestSuite.Cleveland.RefillableAddress + TestSuite.Cleveland.ResolveAddress TestSuite.Cleveland.RunCode TestSuite.Cleveland.StorageCheck TestSuite.Cleveland.StorageWithBigMaps @@ -253,6 +267,7 @@ GADTs GeneralizedNewtypeDeriving ImportQualifiedPost + InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf 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 @@ -34,7 +34,7 @@ import Hedgehog.Range qualified as Range import Hedgehog.Gen.Michelson.Untyped (genEpName) -import Hedgehog.Gen.Tezos.Address (genAddress) +import Hedgehog.Gen.Tezos.Address import Hedgehog.Gen.Tezos.Core (genChainId, genMutez, genTimestamp) import Hedgehog.Gen.Tezos.Crypto (genKeyHash, genPublicKey, genSignature) import Hedgehog.Gen.Tezos.Crypto.BLS12381 (genBls12381Fr, genBls12381G1, genBls12381G2) @@ -45,7 +45,7 @@ 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 (TxRollupL2Address(..)) +import Morley.Tezos.Address (ConstrainedAddress(..), TxRollupL2Address(..)) import Morley.Tezos.Core (Mutez, Timestamp) import Morley.Tezos.Crypto (parseHash) import Morley.Tezos.Crypto.BLS12381 qualified as BLS @@ -79,7 +79,7 @@ <*> Gen.map (unLength <$> len) (liftA2 (,) genKey genVal) genEpAddress :: (MonadGen m, GenBase m ~ Identity) => m EpAddress -genEpAddress = EpAddress <$> genAddress <*> genEpName +genEpAddress = EpAddress' <$> genAddress <*> genEpName genValueKeyHash :: MonadGen m => m (Value' instr 'TKeyHash) genValueKeyHash = VKeyHash <$> genKeyHash @@ -128,7 +128,7 @@ genValueTicket :: (MonadGen m, Comparable a) => Range TicketAmount -> m (Value' instr a) -> m (Value' instr ('TTicket a)) -genValueTicket range genVal = VTicket <$> genAddress <*> genVal +genValueTicket range genVal = VTicket . MkAddress <$> genContractAddress <*> genVal <*> Gen.integral (unTicketAmount <$> range) genValueChestAndKey :: MonadGen m => m (Value' instr 'TChest, Value' instr 'TChestKey) diff --git a/src/Hedgehog/Gen/Tezos/Address.hs b/src/Hedgehog/Gen/Tezos/Address.hs --- a/src/Hedgehog/Gen/Tezos/Address.hs +++ b/src/Hedgehog/Gen/Tezos/Address.hs @@ -14,14 +14,14 @@ import Hedgehog.Range qualified as Range import Hedgehog.Gen.Tezos.Crypto (genKeyHash) -import Morley.Tezos.Address (Address(..)) +import Morley.Tezos.Address import Morley.Tezos.Crypto genAddress :: MonadGen m => m Address -genAddress = Gen.choice [genKeyAddress, genContractAddress] +genAddress = Gen.choice [MkAddress <$> genKeyAddress, MkAddress <$> genContractAddress] -genKeyAddress :: MonadGen m => m Address -genKeyAddress = KeyAddress <$> genKeyHash +genKeyAddress :: MonadGen m => m ImplicitAddress +genKeyAddress = ImplicitAddress <$> genKeyHash -genContractAddress :: MonadGen m => m Address +genContractAddress :: MonadGen m => m ContractAddress genContractAddress = ContractAddress . Hash HashContract <$> Gen.bytes (Range.singleton 20) diff --git a/src/Test/Cleveland.hs b/src/Test/Cleveland.hs --- a/src/Test/Cleveland.hs +++ b/src/Test/Cleveland.hs @@ -7,12 +7,17 @@ -- for usage instructions. module Test.Cleveland ( Alias + , ContractAlias + , ImplicitAlias + , KindedAddress + , ContractAddress + , ImplicitAddress , ContractHandle (..) - , OriginateData (..) - , UntypedOriginateData (..) , TransferData (..) + , TypedContract (..) , Scenario , PureM + , ClientM -- * Validation , TransferFailure @@ -20,7 +25,9 @@ -- * Real network implementation based on @tezos-client@ and RPC. , testScenario , testScenarioOnNetwork - , scenario + , scenarioNetwork + , MonadScenario(..) + , getMorleyClientEnv -- * Emulation tests , testScenarioOnEmulator @@ -50,17 +57,13 @@ , signBytes , signBinary , originate - , originateSimple - , originateUntyped - , originateUntypedSimple - , originateTypedSimple - , originateLarge - , originateLargeSimple - , originateLargeUntyped - , originateLargeUntypedSimple + , Large (..) , transfer - , transferMoney - , call + , WithContractEvents (..) + , ContractEvent (..) + , calling + , Default(def) + , unsafeCalling , importUntypedContract , importContract , noViews @@ -89,7 +92,6 @@ , getApproximateBlockInterval , getMinBlockTime , RunCode(..) - , AsRPC.MaybeRPC(..) , runCode , branchout , offshoot @@ -99,9 +101,16 @@ , ifEmulation , inBatch + -- * Address conversions + , ToAddress(..) + , ToL1Address(..) + , ToL1TAddress(..) + -- * Primitives re-exports , EntrypointRef (..) , VotingPowers + , Mutez + , tz , mkVotingPowers , mkVotingPowersFromMap @@ -153,6 +162,8 @@ , pattern DefEpName , ep , (?-) + , (:!) + , NamedF (..) -- * Integration with @hedgehog@ , testScenarioProps @@ -178,12 +189,15 @@ , forEach ) where -import Lorentz (EntrypointRef(..), pattern DefEpName) +import Data.Default (Default(def)) + +import Lorentz (EntrypointRef(..), Mutez, ToAddress(..), pattern DefEpName, tz) import Morley.AsRPC qualified as AsRPC import Morley.Client (MorleyClientEnv, MorleyClientEnv'(..)) import Morley.Client.TezosClient.Types (TezosClientEnv(..)) import Morley.Michelson.Interpret (MorleyLogs) import Morley.Michelson.Runtime (VotingPowers, mkVotingPowers, mkVotingPowersFromMap) +import Morley.Util.Named import Test.Cleveland.Instances () import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions @@ -191,5 +205,6 @@ import Test.Cleveland.Internal.Hedgehog import Test.Cleveland.Internal.Pure import Test.Cleveland.Internal.Scenario +import Test.Cleveland.Lorentz (ToL1Address(..), ToL1TAddress(..)) 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 @@ -7,17 +7,20 @@ ( HasErrorSrcPos (..) ) where +import Data.Default (Default(..)) import Fmt (Buildable(..), eitherF, hexF, tupleF, (+|), (|+)) import GHC.Num qualified (fromInteger) import Test.Tasty.Runners (FailureReason(..)) import Time (Time) +import Lorentz.Entrypoints.Core (EntrypointRef(..), NiceEntrypointName) import Morley.Michelson.Text (MText, mkMText) import Morley.Michelson.Typed.Haskell.Value (BigMap(..)) import Morley.Michelson.Untyped qualified as U import Morley.Michelson.Untyped.Annotation (Annotation(..), mkAnnotation) -import Morley.Tezos.Address.Alias (Alias(..)) +import Morley.Tezos.Address.Alias import Morley.Tezos.Core (Mutez(..), mkMutez, unsafeAddMutez, unsafeMulMutez, unsafeSubMutez) +import Morley.Util.TypeLits (symbolValT') instance IsString (Annotation tag) where fromString = unsafe . mkAnnotation . toText @@ -145,5 +148,17 @@ instance (Buildable a, Buildable b) => Buildable (Either a b) where build = eitherF -instance IsString Alias where - fromString = Alias . fromString +instance mname ~ 'Nothing => Default (EntrypointRef mname) where + def = CallDefault + +instance Default U.EpName where + def = U.DefEpName + +instance NiceEntrypointName sym => IsLabel sym U.EpName where + fromLabel = unsafe . U.buildEpName $ symbolValT' @sym + +instance IsString ImplicitAlias where + fromString = ImplicitAlias . fromString + +instance IsString ContractAlias where + fromString = ContractAlias . fromString 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 @@ -35,8 +35,13 @@ , Sender (..) , Moneybag (..) , UntypedOriginateData (..) - , RunCode(..) + , TypedOriginateData (..) + , LargeOrigination (..) + , TypedContract (..) + , RunCode (..) , ClevelandInput + , ClevelandResult + , ContractEvent (..) , DefaultAliasCounter (..) , SpecificOrDefaultAlias (..) @@ -58,6 +63,7 @@ , runSingleOperation -- * Validation + , AddressAndAlias(..) , TransferFailure (..) , TransferFailureReason (..) , FailedInBranch (..) @@ -72,21 +78,30 @@ -- * 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 @@ -97,9 +112,16 @@ , filterLogsByAddrL , logsForAddress , collectLogs + + -- * Network environment + , NetworkEnv(..) + , neMorleyClientEnvL + , neSecretKeyL + , neMoneybagAliasL + , neExplicitDataDirL ) where -import Control.Lens (Each, each, filtered, makeLenses, makeLensesFor) +import Control.Lens (Each, each, filtered, makeLenses, makeLensesFor, makeLensesWith) import Data.Default (Default(..)) import Data.Type.Equality (pattern Refl) import Data.Typeable (cast) @@ -109,8 +131,9 @@ import Lorentz (Contract(..)) import Lorentz.Constraints -import Morley.AsRPC (HasRPCRepr(AsRPC), MaybeRPC) -import Morley.Client (Result) +import Lorentz.Entrypoints.Core (EntrypointRef(..), NiceEntrypointName, eprName) +import Morley.AsRPC (HasRPCRepr(AsRPC)) +import Morley.Client (MorleyClientEnv, Result) import Morley.Client.Types import Morley.Micheline (Expression, fromExpression) import Morley.Michelson.ErrorPos (ErrorSrcPos) @@ -123,19 +146,25 @@ import Morley.Michelson.Typed.Scope (ConstantScope) import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address -import Morley.Tezos.Address.Alias (Alias(..)) +import Morley.Tezos.Address.Alias import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.Batching +import Morley.Util.Lens (postfixLFields) import Morley.Util.Sing (eqI) import Morley.Util.TypeLits import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) import Test.Cleveland.Lorentz.Types -data OriginateData param st vd = +-- | Whether this contract should be originated in +-- a single origination operation or, if it goes over +-- the origination size limit, in multiple operations. +data LargeOrigination = IsLarge | NotLarge + +data OriginateData param st vd (large :: LargeOrigination) = OriginateData - { odName :: Alias + { odName :: ContractAlias -- ^ Alias for the originated contract. , odBalance :: Mutez -- ^ Initial balance. @@ -151,8 +180,8 @@ -- | Untyped version of OriginateData. It can be used for interaction with raw -- Michelson contracts -data UntypedOriginateData = UntypedOriginateData - { uodName :: Alias +data UntypedOriginateData (large :: LargeOrigination) = UntypedOriginateData + { uodName :: ContractAlias -- ^ Alias for the originated contract. , uodBalance :: Mutez -- ^ Initial balance. @@ -162,9 +191,22 @@ -- ^ The contract itself. } +-- | 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. + } + -- | Information about transfer operation. data TransferData = - forall v addr. (NiceParameter v, ToAddress addr) => TransferData + forall v addr. (NiceParameter v, ToL1Address addr) => TransferData { tdTo :: addr -- ^ Receiver address for this transaction. , tdAmount :: Mutez @@ -177,13 +219,31 @@ -- for transfers to key addresses. } +-- | 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 + -- | Designates an operation input. data ClevelandInput instance OperationInfoDescriptor ClevelandInput where type TransferInfo ClevelandInput = TransferData - type OriginationInfo ClevelandInput = UntypedOriginateData + type OriginationInfo ClevelandInput = UntypedOriginateData 'NotLarge type RevealInfo ClevelandInput = PublicKey +-- | Data structure representing a contract event. +data ContractEvent = ContractEvent + { ceSource :: ContractAddress + , ceTag :: Text + , cePayload :: Maybe SomeAnnotatedValue + } + +-- | Designates an operation result. +data ClevelandResult +instance OperationInfoDescriptor ClevelandResult where + type TransferInfo ClevelandResult = [ContractEvent] + type OriginationInfo ClevelandResult = OriginationInfo Result + type RevealInfo ClevelandResult = RevealInfo Result + -- | A batch returned invalid output, e.g. origination address when transaction -- was supplied. data BatchResultMismatch @@ -200,7 +260,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 :: Address } +newtype Sender = Sender { unSender :: ImplicitAddress } -- | Designates the address that gifts money to new addresses. -- @@ -212,24 +272,24 @@ -- 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 :: Address } +newtype Moneybag = Moneybag { unMoneybag :: ImplicitAddress } -- | An alias with default value that can be used to define unique alias -- automatically. data SpecificOrDefaultAlias - = SpecificAlias Alias + = SpecificAlias ImplicitAlias | DefaultAlias deriving stock (Show) instance IsString SpecificOrDefaultAlias where - fromString = SpecificAlias . Alias . fromString + fromString = SpecificAlias . ImplicitAlias . fromString instance Default SpecificOrDefaultAlias where def = DefaultAlias -mkDefaultAlias :: Natural -> Alias +mkDefaultAlias :: Natural -> ImplicitAlias mkDefaultAlias counter = - Alias . fromString $ ("default_cleveland_alias" <> show counter) + ImplicitAlias . fromString $ ("default_cleveland_alias" <> show counter) -- | Helper to use automatically determined unique alias. auto :: SpecificOrDefaultAlias @@ -242,7 +302,7 @@ -- | A record data type with operations creating primitives. data ClevelandOpsImpl m = ClevelandOpsImpl { coiRunOperationBatch - :: HasCallStack => [OperationInfo ClevelandInput] -> m [OperationInfo Result] + :: HasCallStack => [OperationInfo ClevelandInput] -> m [OperationInfo ClevelandResult] -- ^ Perform a batch of operations. } @@ -250,19 +310,19 @@ data ClevelandMiscImpl m = ClevelandMiscImpl { cmiRunIO :: forall res. HasCallStack => IO res -> m res -- ^ Runs an 'IO' action. - , cmiResolveAddress :: HasCallStack => Alias -> m Address + , cmiResolveAddress :: forall kind. HasCallStack => Alias kind -> m (KindedAddress kind) -- ^ Get the address of the implicit account / contract associated with the given alias. - , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m Address + , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddress -- ^ 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 Address + , cmiGenFreshKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddress -- ^ 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 -> Address -> m Crypto.Signature + , cmiSignBytes :: HasCallStack => ByteString -> ImplicitAddress -> m Crypto.Signature -- ^ Get the signature of the preapplied operation. - , cmiOriginateLargeUntyped :: HasCallStack => Sender -> UntypedOriginateData -> m Address + , cmiOriginateLargeUntyped :: HasCallStack => Sender -> UntypedOriginateData 'IsLarge -> m ContractAddress -- ^ Originate a new raw Michelson contract that doesn't fit into the -- origination size limit, by executing multiple operation steps. -- @@ -272,9 +332,9 @@ , cmiComment :: HasCallStack => Text -> m () -- ^ Print the given string verbatim as a comment. -- At the moment, this is a no-op in emulator tests. - , cmiGetBalance :: HasCallStack => Address -> m Mutez + , cmiGetBalance :: HasCallStack => L1Address -> m Mutez -- ^ Get the balance of the given address. - , cmiGetSomeStorage :: HasCallStack => Address -> m SomeAnnotatedValue + , cmiGetSomeStorage :: HasCallStack => ContractAddress -> m SomeAnnotatedValue -- Retrieves the contract's storage. , cmiGetBigMapValueMaybe :: forall k v. (HasCallStack, NiceComparable k, NicePackedValue k, NiceUnpackedValue v) @@ -287,12 +347,12 @@ => 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 => Address -> m Crypto.PublicKey + , cmiGetPublicKey :: HasCallStack => ImplicitAddress -> m Crypto.PublicKey -- ^ Get the public key associated with the given address. -- Fail if the given address is not an implicit account. - , cmiGetDelegate :: HasCallStack => Address -> m (Maybe Crypto.KeyHash) + , cmiGetDelegate :: HasCallStack => ContractAddress -> m (Maybe Crypto.KeyHash) -- ^ Get the delegate for the given contract. Fails on implicit contracts. - , cmiRegisterDelegate :: HasCallStack => Address -> m () + , cmiRegisterDelegate :: HasCallStack => ImplicitAddress -> m () -- ^ Register the given address as a valid delegate. , cmiGetChainId :: HasCallStack => m ChainId -- ^ Get the chain's @ChainId@. @@ -318,11 +378,12 @@ -- is minimal bound and real intervals can be larger. , cmiAttempt :: forall a e. (Exception e, HasCallStack) => m a -> m (Either e a) -- ^ Attempts to perform an action, returning either the result of the action or an exception. - , cmiMarkAddressRefillable :: Address -> m () + , cmiMarkAddressRefillable :: ImplicitAddress -> m () -- ^ Marks a given address as "refillable", i.e. if the address lacks funds for the next operation, -- some funds will automatically be transferred to it. - , cmiEmulatedImpl :: m (Maybe (EmulatedImpl m)) - -- ^ Produce 'EmulatedImpl' if possible. Used to run emulated actions in polymorphic context. + , cmiUnderlyingImpl :: m (Either (EmulatedImpl m) NetworkEnv) + -- ^ Produce underlying implementation specific data. Used to run + -- emulation-only or network-only actions in a polymorphic context. , cmiRunCode :: forall cp st vd. (HasCallStack, HasRPCRepr st, T.IsoValue (AsRPC st)) => Sender -> RunCode cp st vd -> m (AsRPC st) @@ -333,8 +394,20 @@ -- | The data needed to call the @/run_code@ RPC endpoint. data RunCode cp st vd = RunCode { rcContract :: Contract cp st vd - , rcStorage :: MaybeRPC st - , rcParameter :: MaybeRPC cp + , rcParameter :: U.Value + -- ^ The parameter value should have the same "structure" as @cp@, except it _may_ also have big_map IDs. + -- E.g. if the contract's parameter is @pair (big_map string string) (big_map string string)@, + -- then 'rcParameter' may be one of: + -- + -- * @pair (big_map string string) (big_map string string)@ + -- * @pair nat (big_map string string)@ + -- * @pair (big_map string string) nat@ + -- * @pair nat nat@ + -- + -- ... where @nat@ represents a big_map ID. + , rcStorage :: U.Value + -- ^ The storage value should have the same "structure" as @st@, except it _may_ also have big_map IDs. + -- See the documentation of 'rcParameter'. , rcAmount :: Mutez -- ^ The value that will be returned by the @AMOUNT@ instruction. , rcLevel :: Maybe Natural @@ -343,7 +416,7 @@ -- ^ The value that will be returned by the @NOW@ instruction. , rcBalance :: Mutez -- ^ The balance that will be returned by the @BALANCE@ instruction. - , rcSource :: Maybe Address + , rcSource :: Maybe ImplicitAddress -- ^ The value that will be returned by the @SOURCE@ instruction. } @@ -376,6 +449,13 @@ -- ^ Change voting power distribution. } +data NetworkEnv = NetworkEnv + { neMorleyClientEnv :: MorleyClientEnv + , neSecretKey :: Maybe Crypto.SecretKey + , neMoneybagAlias :: ImplicitAlias + , neExplicitDataDir :: Bool + } + ---------------------------------------------------------------------------- -- Log helpers ---------------------------------------------------------------------------- @@ -388,6 +468,7 @@ type LogsInfo = [ScenarioLogs] makeLenses ''ScenarioLogs +makeLensesWith postfixLFields ''NetworkEnv -- | An alias for 'slLog' with a clearer name logsL :: Lens' ScenarioLogs MorleyLogs @@ -426,7 +507,7 @@ -- @-XApplicativeDo@ extension for nicer experience. newtype ClevelandOpsBatch a = ClevelandOpsBatch { unClevelandOpsBatch - :: BatchingM (OperationInfo ClevelandInput) (OperationInfo Result) Void a + :: BatchingM (OperationInfo ClevelandInput) (OperationInfo ClevelandResult) Void a } deriving newtype (Functor, Applicative) instance @@ -480,7 +561,7 @@ :: (HasCallStack, Buildable e, Functor m) => Proxy e -> ClevelandOpsImpl m - -> BatchingM (OperationInfo ClevelandInput) (OperationInfo Result) e a + -> BatchingM (OperationInfo ClevelandInput) (OperationInfo ClevelandResult) e a -> m a runOperationBatchM _ impl = fmap snd . unsafeRunBatching (fmap ((), ) . coiRunOperationBatch impl) @@ -491,7 +572,7 @@ => ClevelandOpsImpl m -> Text -> OperationInfo ClevelandInput - -> (OperationInfo Result -> Maybe a) + -> (OperationInfo ClevelandResult -> Maybe a) -> m a runSingleOperation impl desc opData parseRes = runOperationBatchM (Proxy @BatchResultMismatch) impl $ @@ -521,10 +602,17 @@ EOTVExpression e -> either (const $ build e) build $ fromExpression @U.Value e EOTVTypedValue v -> build v +data AddressAndAlias = AddressAndAlias Address (Maybe ContractAlias) + deriving stock (Show, Eq) + +instance Buildable AddressAndAlias where + build (AddressAndAlias addr mbAlias) = + build addr +| maybe "" (\alias -> " (" +| alias |+ ")") mbAlias + -- | Failures that could be expected in the execution of a transfer. -- These can be caught and handled with 'Test.Cleveland.attempt'. data TransferFailure = TransferFailure - { tfAddress :: Address + { tfAddressAndAlias :: AddressAndAlias , tfReason :: TransferFailureReason } deriving stock (Show, Eq) @@ -542,7 +630,7 @@ -- ^ Expect that interpretation of contract with the given address ended -- with an overflow error. | GasExhaustion - -- TODO: [#284] add more errors here! + -- TODO [#284]: add more errors here! deriving stock (Show, Eq) -- | When an exception is thrown in a 'Test.Cleveland.branchout' branch, we wrap it in this @@ -614,16 +702,39 @@ -- Other helpers ---------------------------------------------------------------------------- --- | A short partial constructor for 'EpName'. It is supposed to be --- applied to string constants, so programmer is responsible for --- validity. And this code is for tests anyway, so each failure is a --- programmer mistake. --- --- It is intentionally here and not in some deeper module because the --- name is really short and more suitable for writing scenarios. -ep :: HasCallStack => Text -> EpName -ep = unsafe . U.buildEpName +class NiceEntrypointName epName => EntrypointNameConstructor (epName :: Symbol) a where + -- | A short partial constructor for 'EpName' or 'EntrypointRef'. It accepts a + -- type-level string as its type argument. The programmer is responsible for + -- validity. And this code is for tests anyway, so each failure is a + -- programmer mistake. + -- + -- Note that entrypoint names should be capitalized, e.g. + -- + -- > ep @"Entrypoint" + -- + -- corresponds to @entrypoint@, etc. + -- + -- It is intentionally here and not in some deeper module because the name is + -- really short and more suitable for writing scenarios. + -- + -- For 'EpName', an instance is provided accepting a value-level t'Text' + -- instead of a type-level symbol. This is mostly for cases where the + -- type-level symbol doesn't work. Note that value-level string will be used + -- verbatim, hence capitalization is arbitrary. + -- + -- > ep "entrypoint" + ep :: a +instance (NiceEntrypointName epName, mname ~ 'Just epName) + => EntrypointNameConstructor epName (EntrypointRef mname) where + ep = Call + +instance NiceEntrypointName epName => EntrypointNameConstructor epName EpName where + ep = eprName $ Call @epName + +instance (any ~ "", t ~ Text) => EntrypointNameConstructor any (t -> EpName) where + ep = unsafe . U.buildEpName + -- | Runs a handler over every action. mapClevelandOpsImplExceptions :: (forall a. HasCallStack => m a -> m a) @@ -662,7 +773,7 @@ , cmiAttempt = \action -> cmiAttempt action , cmiMarkAddressRefillable = f . cmiMarkAddressRefillable , cmiThrow = cmiThrow - , cmiEmulatedImpl = f $ cmiEmulatedImpl + , cmiUnderlyingImpl = f $ cmiUnderlyingImpl , cmiRunCode = f ... cmiRunCode } @@ -680,8 +791,15 @@ , ecClevelandCaps :: ClevelandCaps m } +-- | A record with all the capabilities available to a cleveland test on the network. +data NetworkCaps m = NetworkCaps + { ncNetworkEnv :: NetworkEnv + , ncClevelandCaps :: ClevelandCaps m + } + makeLensesFor [("ccSender", "ccSenderL"), ("ccMoneybag", "ccMoneybagL")] ''ClevelandCaps makeLensesFor [("ecClevelandCaps", "ecClevelandCapsL")] ''EmulatedCaps +makeLensesFor [("ncClevelandCaps", "ncClevelandCapsL")] ''NetworkCaps -- | A proof that the given @caps@ record contains -- the basic cleveland capabilities. @@ -691,7 +809,7 @@ clevelandCapsL :: Lens' caps (ClevelandCaps (ClevelandBaseMonad caps)) -- | A proof that the given @caps@ record contains --- the basic cleveland capabilities + the emulator capabiilities. +-- the basic cleveland capabilities + the emulator capabilities. class HasClevelandCaps caps => HasEmulatedCaps caps where getEmulatedCap :: caps -> EmulatedImpl (ClevelandBaseMonad caps) @@ -718,21 +836,43 @@ instance Monad m => HasEmulatedCaps (EmulatedCaps m) where getEmulatedCap = ecEmulatedCap +-- | A proof that the given @caps@ record contains +-- the basic cleveland capabilities + the network capabilities. +class HasClevelandCaps caps => HasNetworkCaps caps where + getNetworkEnvCap :: caps -> NetworkEnv + +instance Monad m => HasClevelandCaps (NetworkCaps m) where + type ClevelandBaseMonad (NetworkCaps m) = m + clevelandCapsL = ncClevelandCapsL + +instance Monad m => HasNetworkCaps (NetworkCaps m) where + getNetworkEnvCap = ncNetworkEnv + -- | Constraint for a monad in which we can do cleveland actions. type MonadCleveland caps m = ( m ~ ReaderT caps (ClevelandBaseMonad caps) , HasClevelandCaps caps ) --- | Constraint for a monad in which we can do cleveland actions that can't be run on a real network. --- It requires the 'EmulatedImpl' capability. +-- | Constraint for a monad in which we can do cleveland actions that can't be +-- run on a real network. It requires the 'EmulatedCaps' capability. type MonadEmulated caps m = ( MonadCleveland caps m , HasEmulatedCaps caps ) +-- | Constraint for a monad in which we can do cleveland actions that can only +-- be run on a real network. It requires the 'NetworkCaps' capability. +type MonadNetwork caps m = + ( MonadCleveland caps m + , HasNetworkCaps caps + ) + -- | Monad transformer that adds only the 'ClevelandCaps' capabilities. type ClevelandT m = ReaderT (ClevelandCaps m) m -- | Monad transformer that adds both 'ClevelandCaps' and 'EmulatedCaps' capabilities. type EmulatedT m = ReaderT (EmulatedCaps m) m + +-- | Monad transformer that adds both 'ClevelandCaps' and 'NetworkCaps' capabilities. +type NetworkT m = ReaderT (NetworkCaps m) m 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 @@ -3,1254 +3,123 @@ -- | Cleveland actions. module Test.Cleveland.Internal.Actions - ( MonadOps(..) - , withSender - , withMoneybag - , runIO - , resolveAddress - , refillable - , newAddress - , newAddresses - , newFreshAddress - , enumAliases - , signBytes - , signBinary - , originate - , originateSimple - , originateUntyped - , originateUntypedSimple - , originateTypedSimple - , originateLarge - , originateLargeSimple - , originateLargeUntyped - , originateLargeUntypedSimple - , transfer - , transferMoney - , call - , 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 - , setVotingPowers - , whenEmulation - , whenNetwork - , ifEmulation - - -- * Assertions - , failure - , assert - , (@==) - , (@/=) - , (@@==) - , (@@/=) - , checkCompares - , checkComparesWith - , evalJust - , evalRight - - -- * 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 - - -- * Helpers - , withCap - ) where - -import Data.Constraint (Dict(Dict), (\\)) -import Data.Either.Validation (Validation(..)) -import Data.List.NonEmpty qualified as NE -import Data.Singletons (demote) -import Fmt (Buildable, Builder, build, indentF, nameF, pretty, unlinesF, (+|), (|+)) -import Time (KnownDivRat, Second, Time, toNum) -import Unsafe qualified (fromIntegral) - -import Lorentz - (BigMapId, Contract(..), CustomError(..), DemoteViewsDescriptor, ErrorTagMap, - HasEntrypointArg(useHasEntrypointArg), IsError, IsoValue, Label, MText, MustHaveErrorArg, - ToTAddress, errorTagToMText, errorToVal, errorToValNumeric, noViews, pattern DefEpName, - toMichelsonContract, toTAddress, toVal, zeroMutez) -import Lorentz.Bytes -import Lorentz.Constraints -import Morley.AsRPC (HasRPCRepr(..)) -import Morley.Client (OperationInfo(..)) -import Morley.Micheline (Expression, fromExpression, toExpression) -import Morley.Michelson.Printer.Util (buildRenderDoc) -import Morley.Michelson.Runtime (VotingPowers) -import Morley.Michelson.Runtime.Import qualified as Runtime -import Morley.Michelson.Typed - (SomeAnnotatedValue, SomeConstant, SomeConstrainedValue(..), convertContract, untypeValue) -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 (Address) -import Morley.Tezos.Address.Alias (Alias(..)) -import Morley.Tezos.Core (ChainId, Mutez, Timestamp) -import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature) -import Morley.Util.SizedList qualified as SL -import Morley.Util.SizedList.Types -import Test.Cleveland.Internal.Abstract -import Test.Cleveland.Internal.Client qualified as Client (TestError(..)) -import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) -import Test.Cleveland.Internal.Pure as Pure (TestError(..)) -import Test.Cleveland.Lorentz.Import qualified as LorentzImport -import Test.Cleveland.Lorentz.Types - -{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-} - --- $setup --- >>> :m +Morley.Util.SizedList.Types --- >>> :{ --- isEquivalentTo :: Show a => a -> a -> Bool --- isEquivalentTo a b = show a == show b --- infix 0 `isEquivalentTo` --- :} - --- | 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. -class Functor m => MonadOps 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 MonadOps ClevelandOpsBatch where - withOpsCap mkAction = mkAction batchedOpsImpl - -instance (HasClevelandCaps caps, ClevelandBaseMonad caps ~ m) => MonadOps (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' - --- | Update the current sender on whose behalf transfers and originations are --- invoked. -withSender :: MonadCleveland caps m => Address -> 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 => Address -> m a -> m a -withMoneybag addr = - local (set moneybagL (Moneybag addr)) - --- | Runs an 'IO' action. -runIO :: (HasCallStack, MonadCleveland caps m) => IO res -> m res -runIO io = do - withCap getMiscCap \cap -> cmiRunIO cap io - --- | Get the address of the implicit account / contract associated with the given alias. -resolveAddress - :: (HasCallStack, MonadCleveland caps m) - => Alias -> m Address -resolveAddress alias = do - withCap getMiscCap \cap -> cmiResolveAddress cap 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 Address -> m Address -refillable action = do - addr <- action - withCap getMiscCap \cap -> cmiMarkAddressRefillable cap addr - pure addr - --- | 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. --- --- If the account has too low of a balance, a small amount of XTZ will --- be transferred to it. --- --- Notes: --- --- * By default, the XTZ is transferred from the account associated with the @moneybag@ alias. --- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the --- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withMoneybag'. --- > do --- > addr1 <- newAddress "alias" --- > addr2 <- resolveAddress $ mkAlias "prefix.alias" --- > addr1 @== addr2 -newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m Address -newAddress alias = do - addrs <- newAddresses $ alias :< Nil - case addrs of - addr :< Nil -> pure addr - --- | Batched version of `newAddress` -newAddresses - :: forall n n' caps m. - (HasCallStack, MonadCleveland caps m, IsoNatPeano n n') - => SizedList n SpecificOrDefaultAlias - -> m (SizedList n Address) -newAddresses aliases = do - addrs <- withCap getMiscCap \cap -> traverse (cmiGenKey cap) aliases - Moneybag moneybag <- view moneybagL - - -- Addresses may exist from previous scenarios runs and have sufficient - -- balance for the sake of testing; if so, we can save some time - balances <- traverse getBalance addrs - withSender moneybag do - inBatch do - sequenceA_ $ - SL.zipWith refillIfLowBalance addrs balances - - pure addrs - -refillIfLowBalance :: (HasCallStack, Applicative m, MonadOps m) => Address -> Mutez -> m () -refillIfLowBalance addr balance = - when (balance < 0.5_e6) do -- < 0.5 XTZ - transferMoney addr 0.9_e6 -- 0.9 XTZ - --- | Generate a new secret key and record it with given alias. If the --- alias is already known, the key will be overwritten. The address is --- guaranteed to be fresh, i. e. no operations on it have been made. --- --- Notes: --- --- * Beware that if an "alias prefix" is set, it'll be prepended to the given alias. --- An "alias prefix" can be set using the @--cleveland-alias-prefix@ command line option, the --- @TASTY_CLEVELAND_ALIAS_PREFIX@ env var, or with 'Test.Cleveland.Tasty.setAliasPrefix'. --- > do --- > addr1 <- newFreshAddress "alias" --- > addr2 <- resolveAddress $ mkAlias "prefix.alias" --- > addr1 @== addr2 -newFreshAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m Address -newFreshAddress alias = do - withCap getMiscCap \cap -> cmiGenFreshKey cap alias - --- | Get the signature of the preapplied operation. -signBytes :: (HasCallStack, MonadCleveland caps m) => ByteString -> Address -> m Signature -signBytes bytes signer = do - withCap getMiscCap \cap -> cmiSignBytes cap bytes signer - --- | Create a list of similarly named 'SpecificAlias'es. --- --- For example, --- --- >>> enumAliases @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil --- True -enumAliases - :: forall n n'. - (SingIPeano n, IsoNatPeano n n') - => Alias -> SizedList n SpecificOrDefaultAlias -enumAliases (Alias pfx) = SpecificAlias <$> SL.generate @n (\n -> Alias $ pfx <> "-" <> show n) - --- | Type-safer version of 'signBytes'. -signBinary :: (HasCallStack, BytesLike bs, MonadCleveland caps m) => bs -> Address -> m (TSignature bs) -signBinary bs addr = TSignature <$> signBytes (toBytes bs) addr - --- | Originate a new raw Michelson contract with given data. -originateUntyped :: (HasCallStack, MonadOps m) => UntypedOriginateData -> m Address -originateUntyped uod = withOpsCap \opsCap -> - runSingleOperation opsCap "origination" (OpOriginate uod) \case - OpOriginate addr -> Just addr - _ -> Nothing - --- | A simplified version of the originateUntyped command. --- The contract will have 0 balance. -originateUntypedSimple - :: (HasCallStack, MonadOps m) => Alias -> U.Value -> U.Contract -> m Address -originateUntypedSimple uodName uodStorage uodContract = do - let uodBalance = zeroMutez - originateUntyped UntypedOriginateData{..} - --- | Lorentz version for origination. --- --- By default, the sender is the account associated with the @moneybag@ alias. --- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the --- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'. -originate - :: forall cp st vd m. - (HasCallStack, MonadOps m) - => OriginateData cp st vd -> m (ContractHandle cp st vd) -originate dat@OriginateData{ odContract = Contract{}, .. } = do - addr <- originateUntyped (originateDataToUntyped dat) - pure $ ContractHandle (pretty odName) addr - --- | A simplified version of the originate command. --- The contract will have 0 balance. -originateSimple - :: forall cp st vd m. - ( HasCallStack - , MonadOps m - ) - => Alias - -> st - -> Contract cp st vd - -> m (ContractHandle cp st vd) -originateSimple odName odStorage odContract = do - let odBalance = zeroMutez - originate OriginateData{..} - --- | Like 'originateUntypedSimple', but accepts typed contract and initial storage --- as a Haskell value. -originateTypedSimple - :: forall cp st vd m. - ( HasCallStack - , MonadOps m - , NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd - ) - => Alias -> st -> T.Contract (T.ToT cp) (T.ToT st) -> m (ContractHandle cp st vd) -originateTypedSimple name storage contract@T.Contract{} = do - addr <- originateUntypedSimple name (untypeHelper storage) (convertContract contract) - pure $ ContractHandle (pretty name) addr - --- | Originate a new Michelson contract that doesn't fit into the --- origination size limit, by executing multiple operation steps. --- --- This operation cannot be batched (it simply may not fit). -originateLargeUntyped - :: (HasCallStack, MonadCleveland caps m) => UntypedOriginateData -> m Address -originateLargeUntyped uod = do - sender <- view senderL - withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender uod - --- | A simplified version of the originateLargeUntyped command. --- The contract will have 0 balance. -originateLargeUntypedSimple - :: (HasCallStack, MonadCleveland caps m) - => Alias -> U.Value -> U.Contract -> m Address -originateLargeUntypedSimple uodName uodStorage uodContract = do - let uodBalance = zeroMutez - originateLargeUntyped UntypedOriginateData{..} - --- | Lorentz version for large origination. -originateLarge - :: forall param st vd m caps. - (HasCallStack, MonadCleveland caps m) - => OriginateData param st vd -> m (ContractHandle param st vd) -originateLarge dat@OriginateData{ odContract = Contract{}, .. } = do - addr <- originateLargeUntyped (originateDataToUntyped dat) - pure $ ContractHandle (pretty odName) addr - --- | A simplified version of the originateLarge command. --- The contract will have 0 balance. -originateLargeSimple - :: forall param st vd m caps. - ( HasCallStack - , MonadCleveland caps m - ) - => Alias - -> st - -> Contract param st vd - -> m (ContractHandle param st vd) -originateLargeSimple odName odStorage odContract = do - let odBalance = zeroMutez - originateLarge OriginateData{..} - --- | Base method for making a transfer. --- --- Avoid using this method in favour of 'transferMoney' and 'call', unless --- you need the semantics of both in one operation. -transfer :: (HasCallStack, MonadOps m) => TransferData -> m () -transfer td = withOpsCap \opsCap -> - runSingleOperation opsCap "transfer" (OpTransfer td) \case - OpTransfer () -> Just () - _ -> Nothing - --- | Simply transfer money to an address. --- --- This assumes that target address is either an implicit address or has --- a default entrypoint with a unit argument; otherwise the call fails. -transferMoney :: (HasCallStack, MonadOps m, ToAddress addr) => addr -> Mutez -> m () -transferMoney to amount = transfer TransferData - { tdTo = to - , tdAmount = amount - , tdEntrypoint = DefEpName - , tdParameter = () - } - --- | Call a certain entrypoint of the given contract. --- --- By default, the sender is the account associated with the @moneybag@ alias. --- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the --- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'. -call - :: forall param vd addr m epRef epArg. - (HasCallStack, MonadOps m, ToTAddress param vd addr, HasEntrypointArg param epRef epArg - , IsoValue epArg, Typeable epArg) - => addr - -> epRef - -> epArg - -> m () -call to epRef param = - case useHasEntrypointArg @param @epRef @epArg epRef of - (Dict, epName) -> - transfer TransferData - { tdTo = toAddress $ toTAddress @param @vd @addr to - , tdAmount = zeroMutez - , tdEntrypoint = epName - , tdParameter = param - } - --- | Import an untyped contract from file. -importUntypedContract :: (HasCallStack, MonadCleveland caps m) => FilePath -> m U.Contract -importUntypedContract = runIO . Runtime.importUntypedContract - --- | 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'. -importContract - :: ( HasCallStack, NiceParameter param, NiceStorage st - , NiceViewsDescriptor vd, DemoteViewsDescriptor vd - , MonadCleveland caps m - ) - => FilePath -> m (Contract param st vd) -importContract = runIO . LorentzImport.importContract - -{- | Run operations in a batch. -Best used with the @ApplicativeDo@ GHC extension. - -Example: - -@ -{-# LANGUAGE ApplicativeDo #-} - -contract <- inBatch $ do - contract <- originate ... - for_ [1..3] \i -> - transfer ... - return contract -@ - -Batched operations should be applied to chain faster, but note that batches have -their own limits. For instance, at the moment of writing, the gas limit on a -batch is 10x of gas limit applied to a single operation. - -A context of a batch is only 'Applicative', not 'Monad'. This means that: - -* Return values of one function cannot be passed to another function in the same - batch, it can only be returned; -* Sometimes the compiler does not recognize that only 'Applicative' context is - required, in case of any issues with that - follow the error messages. - --} -inBatch :: (HasCallStack, MonadCleveland caps m) => ClevelandOpsBatch a -> m a -inBatch batch = do - withCap getOpsCap \cap -> runBatched cap batch - --- | Print the given string verbatim as a comment. --- At the moment, this is a no-op in emulator tests. -comment :: (HasCallStack, MonadCleveland caps m) => Text -> m () -comment cmt = do - withCap getMiscCap \cap -> cmiComment cap cmt - --- | Get the balance of the given address. -getBalance :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m Mutez -getBalance addr = do - withCap getMiscCap \cap -> cmiGetBalance cap (toAddress addr) - --- | Get the delegate for the given contract. Fails on implicit contracts. -getDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m (Maybe KeyHash) -getDelegate addr = do - withCap getMiscCap \cap -> cmiGetDelegate cap (toAddress addr) - --- | Register the given address as a valid delegate. -registerDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m () -registerDelegate addr = do - withCap getMiscCap \cap -> cmiRegisterDelegate cap (toAddress addr) - --- | Retrieve a contract's storage in its "RPC representation" --- (i.e., all its big_maps will be replaced by big_map IDs). --- --- If the storage is of a user-defined type, then 'Test.Cleveland.deriveRPC' / --- 'Test.Cleveland.deriveManyRPC' should be used to create an RPC representation of the storage --- type. --- --- > data MyStorage = MyStorage { field1 :: Natural, field2 :: BigMap Integer MText } --- > deriveRPC "MyStorage" -getStorage - :: forall st addr caps m. - (HasCallStack, MonadCleveland caps m, ToStorageType st addr, IsoValue (AsRPC st)) - => addr - -> m (AsRPC st) -getStorage contract = do - someSt <- getSomeStorage contract - case someSt ^? castTo @(AsRPC st) . value of - Just st -> pure st - Nothing -> failure $ unlinesF - [ "Expected storage to be of type:" - , indentF 2 $ build $ demote @(T.ToT (AsRPC st)) - , "But its type was:" - , indentF 2 $ build $ getT someSt - ] - --- | Retrieve a contract's full storage, including the contents of its big_maps. --- --- This function can only be used in emulator-only tests. -getFullStorage - :: forall st addr caps m. - (HasCallStack, MonadEmulated caps m, ToStorageType st addr) - => addr - -> m st -getFullStorage contract = do - withCap getEmulatedCap \cap -> eiGetStorage cap contract - --- | Similar to 'getStorage', but doesn't require knowing --- the storage type in advance. --- --- Use the optics in 'Morley.Michelson.Typed.AnnotatedValue' to --- read data from the storage. -getSomeStorage - :: forall addr caps m. - (HasCallStack, MonadCleveland caps m, ToAddress addr) - => addr - -> m SomeAnnotatedValue -getSomeStorage contract = do - withCap getMiscCap \cap -> cmiGetSomeStorage cap (toAddress contract) - --- | Retrieve a big_map value, given a big_map ID and a key. --- Returns 'Nothing' when the big_map ID does not exist, or it exists but --- does not contain the given key. -getBigMapValueMaybe - :: forall k v caps m. - ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NicePackedValue k, NiceUnpackedValue v - ) - => BigMapId k v -> k -> m (Maybe v) -getBigMapValueMaybe bmId key = do - withCap getMiscCap \cap -> cmiGetBigMapValueMaybe cap bmId key - --- | Like 'getBigMapValueMaybe', but fails the tests instead of returning 'Nothing'. -getBigMapValue - :: forall k v caps m. - ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NicePackedValue k, NiceUnpackedValue v - , Buildable k - ) - => BigMapId k v -> k -> m v -getBigMapValue bmId k = - getBigMapValueMaybe bmId k >>= \case - Just v -> pure v - Nothing -> failure $ unlinesF @_ @Builder - [ "Either:" - , " 1. A big_map with ID '" +| bmId |+ "' does not exist, or" - , " 2. It exists, but does not contain the key '" +| k |+ "'." - ] - --- | Retrieve all big_map values, given a big_map ID. --- Returns 'Nothing' when the big_map ID does not exist. -getAllBigMapValuesMaybe - :: forall k v caps m. - ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NiceUnpackedValue v - ) - => BigMapId k v -> m (Maybe [v]) -getAllBigMapValuesMaybe bmId = do - withCap getMiscCap \cap -> cmiGetAllBigMapValuesMaybe cap bmId - --- | Like 'getAllBigMapValuesMaybe', but fails the tests instead of returning 'Nothing'. -getAllBigMapValues - :: forall k v caps m. - ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NiceUnpackedValue v - ) - => BigMapId k v -> m [v] -getAllBigMapValues bmId = - getAllBigMapValuesMaybe bmId >>= \case - Just vs -> pure vs - Nothing -> failure $ "A big map with ID '" +| bmId |+ "' does not exist" - --- | Retrieve a big_map size, given a big_map ID. --- Returns 'Nothing' when the big_map ID does not exist. --- --- /O(n)/, because it's implemented with 'Morley.Client.RPC.Getters.getBigMapValues'. -getBigMapSizeMaybe - :: forall k v caps m. - ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NiceUnpackedValue v - ) - => BigMapId k v -> m (Maybe Natural) -getBigMapSizeMaybe bmId = - fmap (fmap (Unsafe.fromIntegral @Int @Natural . length)) (getAllBigMapValuesMaybe bmId) - --- | Like 'getBigMapSizeMaybe', but fails the tests instead of returning 'Nothing'. -getBigMapSize - :: forall k v caps m. - ( HasCallStack, MonadCleveland caps m - , NiceComparable k, NiceUnpackedValue v - ) - => BigMapId k v -> m Natural -getBigMapSize bmId = - Unsafe.fromIntegral @Int @Natural . length <$> getAllBigMapValues bmId - --- | Get the public key associated with given address. --- Fail if given address is not an implicit account. -getPublicKey :: (HasCallStack, MonadCleveland caps m) => Address -> m PublicKey -getPublicKey addr = do - withCap getMiscCap \cap -> cmiGetPublicKey cap addr - --- | Get the chain's @ChainId@. -getChainId :: (HasCallStack, MonadCleveland caps m) => m ChainId -getChainId = do - withCap getMiscCap \cap -> cmiGetChainId cap - --- | Advance at least the given amount of time, or until a new block is baked, --- whichever happens last. --- --- On a real network, this is implemented using @threadDelay@, so it's advisable --- to use small amounts of time only. -advanceTime - :: forall unit caps m - . (HasCallStack, MonadCleveland caps m, KnownDivRat unit Second) - => Time unit -> m () -advanceTime time = do - withCap getMiscCap \cap -> cmiAdvanceTime cap time - --- | Wait till the provided number of levels is past. -advanceLevel - :: forall caps m - . (HasCallStack, MonadCleveland caps m) - => Natural -> m () -advanceLevel l = do - withCap getMiscCap \cap -> cmiAdvanceToLevel cap (+ l) - --- | Wait till the provided level is reached. -advanceToLevel - :: forall caps m - . (HasCallStack, MonadCleveland caps m) - => Natural -> m () -advanceToLevel target = do - withCap getMiscCap \cap -> cmiAdvanceToLevel cap (const target) - --- | Get the timestamp observed by the last block to be baked. -getNow :: (HasCallStack, MonadCleveland caps m) => m Timestamp -getNow = do - withCap getMiscCap \cap -> cmiGetNow cap - --- | Get the current level observed by the last block to be baked. -getLevel :: (HasCallStack, MonadCleveland caps m) => m Natural -getLevel = do - withCap getMiscCap \cap -> cmiGetLevel cap - --- | Get approximate block interval in seconds. Note, that this value --- is minimal bound and real intervals can be larger, see --- http://tezos.gitlab.io/active/consensus.html#minimal-block-delay-function --- for more information about block delays. -getApproximateBlockInterval :: (HasCallStack, MonadCleveland caps m) => m (Time Second) -getApproximateBlockInterval = do - withCap getMiscCap \cap -> cmiGetApproximateBlockInterval cap - --- | Get minimal block delay in seconds. This is essentially the same as --- 'getApproximateBlockInterval', but returns a 'Natural' instead of @Time --- Second@. --- --- Can be useful when testing code using @MIN_BLOCK_TIME@ instruction. -getMinBlockTime :: (HasCallStack, MonadCleveland caps m) => m Natural -getMinBlockTime = toNum @Second <$> getApproximateBlockInterval - --- | Execute a contract's code without originating it. --- The chain's state will not be modified. --- --- Notes: --- --- * If the contract's code emits operations, they will not be executed. --- * The sender's account won't be debited. --- * When running an _originated_ contract, the @BALANCE@ instruction returns the --- sum of the contract's balance before the transfer operation + the amount of tz being transferred. --- In other words, this invariant holds: @BALANCE >= AMOUNT@. --- However, since `runCode` allows overriding the @BALANCE@ instruction, --- then this invariant no longer holds. It's possible that @BALANCE < AMOUNT@. -runCode - :: (HasCallStack, MonadCleveland caps m, HasRPCRepr st, IsoValue (AsRPC st)) - => RunCode cp st vd -> m (AsRPC st) -runCode rc = do - sender <- view senderL - withCap getMiscCap \cap -> cmiRunCode cap sender rc - --- | Execute multiple testing scenarios independently. --- --- * Actions performed before 'branchout' will be observed by all branches. --- * Actions performed in branches will _not_ be observed by any actions performed after 'branchout'. --- * Actions performed in one branch will _not_ be observed by another branch. --- * The test succeeds IFF all branches succeed. --- * If any branch fails, the test ends immediately and the remaining branches --- won't be executed. --- --- The following property holds: --- --- > pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c] --- --- The list of branches must be non-empty. -branchout :: forall caps m. (MonadEmulated caps m) => [(Text, m ())] -> m () -branchout branches = do - caps <- ask - let branches' :: [(Text, ClevelandBaseMonad caps ())] = second (flip runReaderT caps) <$> branches - lift $ eiBranchout (getEmulatedCap caps) branches' - --- | Execute one or more actions and roll them back afterwards. --- Actions performed in 'offshoot' will _not_ be observed by any --- actions performed after 'offshoot'. --- --- Similar to 'branchout', but accepts one single branch. -offshoot :: forall caps m. MonadEmulated caps m => Text -> m () -> m () -offshoot branchName branch = branchout [(branchName, branch)] - -{- | Returns the result of the action with the logs it produced. Logs are messages -printed by the Lorentz instruction 'Lorentz.printComment'. - -This function can be combined either with lens-based accessors or helper functions to get -more specific information about logs. - -Examples: - -@ -(logsInfo, _) <- getMorleyLogs scenario -logsInfo ^.. each . logsL @== [MorleyLogs ["log"], MorleyLogs ["log2"]] -logsInfo ^.. each . filterLogsByAddrL addr @== [MorleyLogs ["log"]] -@ - -@ -(logsInfo, _) <- getMorleyLogs scenario -collectLogs logsInfo @== MorleyLogs ["log", "log2"] -logsForAddress logsInfo @== [MorleyLogs ["log"]] -@ - --} -getMorleyLogs :: forall a caps m. MonadEmulated caps m => m a -> m (LogsInfo, a) -getMorleyLogs action = do - caps <- ask - let action' :: ClevelandBaseMonad caps a = runReaderT action caps - lift $ eiGetMorleyLogs (getEmulatedCap caps) action' - --- | Version of `getMorleyLogs` for actions that don't return a result. -getMorleyLogs_ :: MonadEmulated caps m => m () -> m LogsInfo -getMorleyLogs_ action = fst <$> getMorleyLogs action - --- | Updates voting power accessible via @VOTING_POWER@ and similar --- instructions. -setVotingPowers :: MonadEmulated caps m => VotingPowers -> m () -setVotingPowers vp = do - withCap getEmulatedCap \cap -> eiSetVotingPowers cap vp - --- | A helper constraint synonym to make signatures below a bit shorter -type EqBaseMonad a b = ClevelandBaseMonad a ~ ClevelandBaseMonad b - --- | Perform an action if we are currently in emulation mode. --- See also 'ifEmulation' note on constraints. -whenEmulation - :: MonadCleveland caps m - => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 ()) - -> m () -whenEmulation action = ifEmulation action pass - --- | Perform an action if we are currently in network mode. --- See also 'ifEmulation' note on constraints. -whenNetwork - :: MonadCleveland caps m - => (forall caps1 m1. (EqBaseMonad caps caps1, MonadCleveland caps1 m1) => m1 ()) - -> m () -whenNetwork action = ifEmulation pass action - -{- | Perform one action if we are currently in emulation mode, another otherwise - -Functions passed as the first two arguments are universally quantified over -the outer monad, so if additional constraints are required beyond -'MonadEmulated' or 'MonadCleveland', those constraints have to go on the base -monad, e.g. - -@ -someFunction :: (MonadCleveland caps m, MonadFail (ClevelandBaseMonad caps)) => m () -someFunction = whenEmulation do - Just x <- pure (Just 1 :: Maybe Int) -- this would error without MonadFail - runIO $ print x -@ --} -ifEmulation - :: forall a caps m - . MonadCleveland caps m - => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 a) - -> (forall caps1 m1. (EqBaseMonad caps caps1, MonadCleveland caps1 m1) => m1 a) - -> m a -ifEmulation onEmu onNet = withCap getMiscCap cmiEmulatedImpl >>= \case - Nothing -> onNet - Just impl -> withCap (view clevelandCapsL) (runReaderT onEmu . EmulatedCaps impl) - ----------------------------------------------------------------------------- --- Assertions ----------------------------------------------------------------------------- - --- | Fails the test with the given error message. -failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Builder -> m a -failure msg = do - withCap getMiscCap \cap -> cmiFailure cap msg - --- | Fails the test with the given error message if the given condition is false. -assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Builder -> m () -assert b errMsg = - unless b $ failure errMsg - --- | @x \@== expected@ fails the test if @x@ is not equal to @expected@. -(@==) - :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a) - => a -- ^ The actual value. - -> a -- ^ The expected value. - -> m () -actual @== expected = - assert (actual == expected) $ - unlinesF - [ "Failed comparison" - , "━━ Expected (rhs) ━━" - , build expected - , "━━ Got (lhs) ━━" - , build actual - ] -infix 1 @== - --- | Fails the test if the two given values are equal. -(@/=) - :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a) - => a -> a -> m () -a @/= b = - assert (a /= b) $ - unlinesF - [ "The two values are equal:" - , build a - ] -infix 1 @/= - --- | Monadic version of '@=='. --- --- > getBalance addr @@== 10 -(@@==) - :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a) - => m a -- ^ The actual value. - -> a -- ^ The expected value. - -> m () -getActual @@== expected = do - actual <- getActual - actual @== expected -infix 1 @@== - --- | Monadic version of '@/='. --- --- > getBalance addr @@/= 10 -(@@/=) - :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a) - => m a -> a -> m () -getA @@/= b = do - a <- getA - a @/= b -infix 1 @@/= - --- | Fails the test if the comparison operator fails when applied to the given arguments. --- Prints an error message with both arguments. --- --- Example: --- --- > checkCompares 2 (>) 1 -checkCompares - :: forall a b caps m - . (HasCallStack, MonadCleveland caps m, Buildable a, Buildable b) - => a - -> (a -> b -> Bool) - -> b - -> m () -checkCompares a f b = checkComparesWith pretty a f pretty b - --- | Like 'checkCompares', but with an explicit show function. --- This function does not have any constraint on the type parameters @a@ and @b@. --- --- For example, to print with 'Fmt.pretty': --- --- > checkComparesWith pretty a (<) pretty b -checkComparesWith - :: forall a b caps m - . (HasCallStack, MonadCleveland caps m) - => (a -> Text) - -> a - -> (a -> b -> Bool) - -> (b -> Text) - -> b - -> m () -checkComparesWith showA a f showB b = - assert (f a b) $ - unlinesF - [ "Failed" - , "━━ lhs ━━" - , showA a - , "━━ rhs ━━" - , showB b - ] - --- | Fails the test if the `Maybe` is `Nothing`, otherwise returns the value in the `Just`. -evalJust :: (HasCallStack, MonadCleveland caps m) => Builder -> Maybe a -> m a -evalJust err = maybe (failure err) pure - --- | Fails the test if the `Either` is `Left`, otherwise returns the value in the `Right`. -evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Builder) -> Either a b -> m b -evalRight mkErr = either (failure . mkErr) pure - ----------------------------------------------------------------------------- --- Exception Handling ----------------------------------------------------------------------------- - --- | Attempt to run an action and return its result or, if interpretation fails, an error. -attempt - :: forall e caps m a. (HasCallStack, MonadCleveland caps m, Exception e) - => m a -> m (Either e a) -attempt action = do - caps <- ask - let action' :: ClevelandBaseMonad caps a = runReaderT action caps - lift $ cmiAttempt (getMiscCap caps) action' - --- | Asserts that a transfer should fail, and returns the exception. -catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure -catchTransferFailure action = - attempt action >>= \case - Left err -> return err - Right _ -> runIO $ throwM UnexpectedSuccess - --- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the --- exception. --- --- > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $ --- > call contractAddr (Call @"Ep") arg --- --- > call contractAddr (Call @"Ep") arg & expectTransferFailure --- > ( failedWith (customError #tag 3) && --- > addressIs contractAddr --- > ) -expectTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailurePredicate -> m a -> m () -expectTransferFailure predicate act = do - err <- catchTransferFailure act - checkTransferFailure err predicate - --- | Check whether a given predicate holds for a given 'TransferFailure'. -checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m () -checkTransferFailure err predicate = - case go predicate of - Success () -> pass - Failure expectedOutcome -> failure $ unlinesF - [ "Expected transfer to fail with an error such that:" - , "" - , indentF 2 $ unlinesF expectedOutcome - , "" - , "But these conditions were not met." - , "Actual transfer error:" - , indentF 2 $ build err - ] - where - go :: TransferFailurePredicate -> Validation (NonEmpty 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 - - fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder - fmtExpectedOutcomes delimiter = \case - expectedOutcome :| [] -> one expectedOutcome - expectedOutcomes -> - one $ unlinesF - [ "(" - , indentF 2 $ unlinesF $ NE.intersperse delimiter expectedOutcomes - , ")" - ] - --- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant --- value. -expectFailedWith - :: forall err a caps m - . (HasCallStack, MonadCleveland caps m, NiceConstant err) - => err -> m a -> m () -expectFailedWith err = expectTransferFailure $ failedWith (constant err) - --- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz --- error. -expectError - :: forall err a caps m - . (HasCallStack, MonadCleveland caps m, IsError err) - => err -> m a -> m () -expectError err = expectTransferFailure $ failedWith (lerror err) - --- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom --- lorentz error. -expectCustomError - :: forall arg a tag caps m - . ( HasCallStack, MonadCleveland caps m - , IsError (CustomError tag) - , MustHaveErrorArg tag (MText, arg) - ) - => Label tag -> arg -> m a -> m () -expectCustomError tag arg = expectTransferFailure $ failedWith (customError tag arg) - --- | Version of 'expectCustomError' for error with @unit@ argument. -expectCustomError_ - :: ( HasCallStack, MonadCleveland caps m - , IsError (CustomError tag) - , MustHaveErrorArg tag (MText, ()) - ) - => Label tag -> m a -> m () -expectCustomError_ tag = expectCustomError tag () - --- | Version of 'expectCustomError' specialized for expecting @NoErrorArg@s. -expectCustomErrorNoArg - :: ( HasCallStack, MonadCleveland caps m - , IsError (CustomError tag) - , MustHaveErrorArg tag MText - ) - => Label tag -> m a -> m () -expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag) - --- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz --- numeric error. -expectNumericError - :: forall err a caps m - . (HasCallStack, MonadCleveland caps m, IsError err) - => ErrorTagMap -> err -> m a -> m () -expectNumericError tagMap err = expectTransferFailure $ failedWith (numericError tagMap err) - --- | Prefix /scenario-custom/ error messages (i.e. @CustomTestError@ either from pure or non-pure --- implementation), potentially thrown from the given code block. --- --- The prefix will be put at a separate line before the main text, if text is multiline, otherwise --- it will be separated from the main text with @: @. --- --- This affects errors produced by functions like 'failure', 'assert', '@==', etc. --- Errors related to events in the chain will not be touched. --- --- Example: --- --- > for [1..10] \i -> clarifyErrors ("For i=" +| i |+ "") $ --- > askContract i @@== i * 2 -clarifyErrors :: forall caps m a. (MonadCleveland caps m) - => Builder -> m a -> m a -clarifyErrors message action = do - attempt action >>= \case - Left (e :: SomeException) -> withCap getMiscCap \cap -> cmiThrow cap (handle e) - Right val -> pure val - where - handle :: SomeException -> SomeException - handle e = fromMaybe e $ - wrap testClientErrorHandler e - <|> wrap testPureErrorHandler e - <|> wrap withCallStackErrorHandler e - - wrap f = fmap (toException . f) . fromException - - addPrefix = pretty . nameF message . build - - testClientErrorHandler :: Client.TestError -> Client.TestError - testClientErrorHandler = \case - Client.CustomTestError msg -> Client.CustomTestError $ addPrefix msg - - testPureErrorHandler :: Pure.TestError -> Pure.TestError - testPureErrorHandler = \case - Pure.CustomTestError msg -> Pure.CustomTestError $ addPrefix msg - err -> err - - withCallStackErrorHandler :: WithCallStack -> WithCallStack - withCallStackErrorHandler (WithCallStack cst e) = WithCallStack cst $ handle e - ----------------------------------------------------------------------------- --- TransferFailure Predicates ----------------------------------------------------------------------------- - --- | A predicate that checks whether a transfer operation failed for the expected reason. --- --- 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. - | AndPredicate (NonEmpty TransferFailurePredicate) - | OrPredicate (NonEmpty TransferFailurePredicate) - -instance Boolean TransferFailurePredicate where - AndPredicate l && AndPredicate r = AndPredicate $ l <> r - AndPredicate l && r = AndPredicate $ l <> one r - l && AndPredicate r = AndPredicate $ one l <> r - l && r = AndPredicate $ one l <> one r - - OrPredicate l || OrPredicate r = OrPredicate $ l <> r - OrPredicate l || r = OrPredicate $ l <> one r - l || OrPredicate r = OrPredicate $ one l <> r - l || r = OrPredicate $ one l <> one r - -transferFailureReasonPredicate - :: (TransferFailureReason -> Validation Builder ()) - -> TransferFailurePredicate -transferFailureReasonPredicate p = TransferFailurePredicate $ - \(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" - --- | 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" - --- | 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" - --- | 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" - --- | 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 - where - isEq :: Expression -> SomeConstant -> Bool - isEq expr (SomeConstant (v :: T.Value t)) = - either (const False) (== v) (fromExpression @(T.Value t) expr) - --- | 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 actualAddr _ = err - when (actualAddr /= expectedAddr) $ - Failure $ "Failure occurred in contract with address: " <> build expectedAddr - ----------------------------------------------------------------------------- --- 'FAILWITH' errors ----------------------------------------------------------------------------- - --- | A constant michelson value that a contract threw with @FAILWITH@. -constant :: forall err. NiceConstant err => err -> SomeConstant -constant err = - withDict (niceConstantEvi @err) $ - SomeConstant $ toVal err - --- | A lorentz error. -lerror :: forall err. IsError err => err -> SomeConstant -lerror err = errorToVal err SomeConstant - --- | A custom lorentz error. -customError - :: forall arg tag. (IsError (CustomError tag), MustHaveErrorArg tag (MText, arg)) - => Label tag -> arg -> SomeConstant -customError tag arg = - lerror $ CustomError tag (errorTagToMText tag, arg) - --- | A custom lorentz error with a @unit@ argument. -customError_ - :: (IsError (CustomError tag), MustHaveErrorArg tag (MText, ())) - => Label tag -> SomeConstant -customError_ tag = customError tag () - --- | A custom lorentz error with no argument. -customErrorNoArg - :: (IsError (CustomError tag), MustHaveErrorArg tag MText) - => Label tag -> SomeConstant -customErrorNoArg tag = - lerror $ CustomError tag (errorTagToMText tag) - --- | A lorentz numeric error. -numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant -numericError tagMap err = errorToValNumeric tagMap err SomeConstant - ----------------------------------------------------------------------------- --- Internal helpers ----------------------------------------------------------------------------- - -withCap :: Monad m => (caps -> cap) -> (cap -> m a) -> ReaderT caps m a -withCap getCap useCap = do - cap <- asks getCap - lift $ useCap cap - --- | Common conversion function from 'OriginateData' to 'UntypedOriginateData' -originateDataToUntyped :: OriginateData param st vd -> UntypedOriginateData -originateDataToUntyped OriginateData{ odContract = contract@Contract{}, .. } = - UntypedOriginateData - { uodName = odName - , uodBalance = odBalance - , uodStorage = untypeHelper odStorage - , uodContract = convertContract $ toMichelsonContract contract - } - -untypeHelper :: forall st. NiceStorage st => st -> U.Value -untypeHelper = untypeValue . toVal \\ niceStorageEvi @st + ( 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 + , setVotingPowers + , whenEmulation + , whenNetwork + , ifEmulation + , getMorleyClientEnv + + -- * Assertions + , failure + , assert + , (@==) + , (@/=) + , (@@==) + , (@@/=) + , checkCompares + , checkComparesWith + , evalJust + , evalRight + + -- * 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 + ) 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 +import Test.Cleveland.Internal.Actions.Transfer +import Test.Cleveland.Internal.Actions.TransferFailurePredicate + +-- | 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. diff --git a/src/Test/Cleveland/Internal/Actions/Assertions.hs b/src/Test/Cleveland/Internal/Actions/Assertions.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/Assertions.hs @@ -0,0 +1,125 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Various test assertions in the 'MonadCleveland' context. +module Test.Cleveland.Internal.Actions.Assertions + ( module Test.Cleveland.Internal.Actions.Assertions + ) where + +import Fmt (Buildable, Builder, build, pretty, unlinesF) + +import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Internal.Actions.Helpers + +{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-} + +-- | Fails the test with the given error message. +failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Builder -> m a +failure msg = do + withCap getMiscCap \cap -> cmiFailure cap msg + +-- | Fails the test with the given error message if the given condition is false. +assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Builder -> m () +assert b errMsg = + unless b $ failure errMsg + +-- | @x \@== expected@ fails the test if @x@ is not equal to @expected@. +(@==) + :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a) + => a -- ^ The actual value. + -> a -- ^ The expected value. + -> m () +actual @== expected = + assert (actual == expected) $ + unlinesF + [ "Failed comparison" + , "━━ Expected (rhs) ━━" + , build expected + , "━━ Got (lhs) ━━" + , build actual + ] +infix 1 @== + +-- | Fails the test if the two given values are equal. +(@/=) + :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a) + => a -> a -> m () +a @/= b = + assert (a /= b) $ + unlinesF + [ "The two values are equal:" + , build a + ] +infix 1 @/= + +-- | Monadic version of '@=='. +-- +-- > getBalance addr @@== 10 +(@@==) + :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a) + => m a -- ^ The actual value. + -> a -- ^ The expected value. + -> m () +getActual @@== expected = do + actual <- getActual + actual @== expected +infix 1 @@== + +-- | Monadic version of '@/='. +-- +-- > getBalance addr @@/= 10 +(@@/=) + :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a) + => m a -> a -> m () +getA @@/= b = do + a <- getA + a @/= b +infix 1 @@/= + +-- | Fails the test if the comparison operator fails when applied to the given arguments. +-- Prints an error message with both arguments. +-- +-- Example: +-- +-- > checkCompares 2 (>) 1 +checkCompares + :: forall a b caps m + . (HasCallStack, MonadCleveland caps m, Buildable a, Buildable b) + => a + -> (a -> b -> Bool) + -> b + -> m () +checkCompares a f b = checkComparesWith pretty a f pretty b + +-- | Like 'checkCompares', but with an explicit show function. +-- This function does not have any constraint on the type parameters @a@ and @b@. +-- +-- For example, to print with 'Fmt.pretty': +-- +-- > checkComparesWith pretty a (<) pretty b +checkComparesWith + :: forall a b caps m + . (HasCallStack, MonadCleveland caps m) + => (a -> Text) + -> a + -> (a -> b -> Bool) + -> (b -> Text) + -> b + -> m () +checkComparesWith showA a f showB b = + assert (f a b) $ + unlinesF + [ "Failed" + , "━━ lhs ━━" + , showA a + , "━━ rhs ━━" + , showB b + ] + +-- | Fails the test if the `Maybe` is `Nothing`, otherwise returns the value in the `Just`. +evalJust :: (HasCallStack, MonadCleveland caps m) => Builder -> Maybe a -> m a +evalJust err = maybe (failure err) pure + +-- | Fails the test if the `Either` is `Left`, otherwise returns the value in the `Right`. +evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Builder) -> Either a b -> m b +evalRight mkErr = either (failure . mkErr) pure diff --git a/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs b/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs @@ -0,0 +1,188 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Exception handling +module Test.Cleveland.Internal.Actions.ExceptionHandling + ( module Test.Cleveland.Internal.Actions.ExceptionHandling + ) where + +import Data.Either.Validation (Validation(..)) +import Data.List.NonEmpty qualified as NE +import Fmt (Builder, build, indentF, nameF, pretty, unlinesF) + +import Lorentz (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg) +import Lorentz.Constraints +import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Internal.Actions.Assertions +import Test.Cleveland.Internal.Actions.Helpers +import Test.Cleveland.Internal.Actions.Misc +import Test.Cleveland.Internal.Actions.TransferFailurePredicate +import Test.Cleveland.Internal.Client qualified as Client (TestError(..)) +import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) +import Test.Cleveland.Internal.Pure as Pure (TestError(..)) + +-- | Attempt to run an action and return its result or, if interpretation fails, an error. +attempt + :: forall e caps m a. (HasCallStack, MonadCleveland caps m, Exception e) + => m a -> m (Either e a) +attempt action = do + caps <- ask + let action' :: ClevelandBaseMonad caps a = runReaderT action caps + lift $ cmiAttempt (getMiscCap caps) action' + +-- | Asserts that a transfer should fail, and returns the exception. +catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure +catchTransferFailure action = + attempt action >>= \case + Left err -> return err + Right _ -> runIO $ throwM UnexpectedSuccess + +-- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the +-- exception. +-- +-- > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $ +-- > call contractAddr (Call @"Ep") arg +-- +-- > call contractAddr (Call @"Ep") arg & expectTransferFailure +-- > ( failedWith (customError #tag 3) && +-- > addressIs contractAddr +-- > ) +expectTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailurePredicate -> m a -> m () +expectTransferFailure predicate act = do + err <- catchTransferFailure act + checkTransferFailure err predicate + +-- | Check whether a given predicate holds for a given 'TransferFailure'. +checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m () +checkTransferFailure err predicate = + case go predicate of + Success () -> pass + Failure expectedOutcome -> failure $ unlinesF + [ "Expected transfer to fail with an error such that:" + , "" + , indentF 2 $ unlinesF expectedOutcome + , "" + , "But these conditions were not met." + , "Actual transfer error:" + , indentF 2 $ build err + ] + where + go :: TransferFailurePredicate -> Validation (NonEmpty 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 + + fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder + fmtExpectedOutcomes delimiter = \case + expectedOutcome :| [] -> one expectedOutcome + expectedOutcomes -> + one $ unlinesF + [ "(" + , indentF 2 $ unlinesF $ NE.intersperse delimiter expectedOutcomes + , ")" + ] + +-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant +-- value. +expectFailedWith + :: forall err a caps m + . (HasCallStack, MonadCleveland caps m, NiceConstant err) + => err -> m a -> m () +expectFailedWith err = expectTransferFailure $ failedWith (constant err) + +-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz +-- error. +expectError + :: forall err a caps m + . (HasCallStack, MonadCleveland caps m, IsError err) + => err -> m a -> m () +expectError err = expectTransferFailure $ failedWith (lerror err) + +-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom +-- lorentz error. +expectCustomError + :: forall arg a tag caps m + . ( HasCallStack, MonadCleveland caps m + , IsError (CustomError tag) + , MustHaveErrorArg tag (MText, arg) + ) + => Label tag -> arg -> m a -> m () +expectCustomError tag arg = expectTransferFailure $ failedWith (customError tag arg) + +-- | Version of 'expectCustomError' for error with @unit@ argument. +expectCustomError_ + :: ( HasCallStack, MonadCleveland caps m + , IsError (CustomError tag) + , MustHaveErrorArg tag (MText, ()) + ) + => Label tag -> m a -> m () +expectCustomError_ tag = expectCustomError tag () + +-- | Version of 'expectCustomError' specialized for expecting @NoErrorArg@s. +expectCustomErrorNoArg + :: ( HasCallStack, MonadCleveland caps m + , IsError (CustomError tag) + , MustHaveErrorArg tag MText + ) + => Label tag -> m a -> m () +expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag) + +-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz +-- numeric error. +expectNumericError + :: forall err a caps m + . (HasCallStack, MonadCleveland caps m, IsError err) + => ErrorTagMap -> err -> m a -> m () +expectNumericError tagMap err = expectTransferFailure $ failedWith (numericError tagMap err) + +-- | Prefix /scenario-custom/ error messages (i.e. @CustomTestError@ either from pure or non-pure +-- implementation), potentially thrown from the given code block. +-- +-- The prefix will be put at a separate line before the main text, if text is multiline, otherwise +-- it will be separated from the main text with @: @. +-- +-- This affects errors produced by functions like 'failure', 'assert', '@==', etc. +-- Errors related to events in the chain will not be touched. +-- +-- Example: +-- +-- > for [1..10] \i -> clarifyErrors ("For i=" +| i |+ "") $ +-- > askContract i @@== i * 2 +clarifyErrors :: forall caps m a. (MonadCleveland caps m) + => Builder -> m a -> m a +clarifyErrors message action = do + attempt action >>= \case + Left (e :: SomeException) -> withCap getMiscCap \cap -> cmiThrow cap (handle e) + Right val -> pure val + where + handle :: SomeException -> SomeException + handle e = fromMaybe e $ + wrap testClientErrorHandler e + <|> wrap testPureErrorHandler e + <|> wrap withCallStackErrorHandler e + + wrap f = fmap (toException . f) . fromException + + addPrefix = pretty . nameF message . build + + testClientErrorHandler :: Client.TestError -> Client.TestError + testClientErrorHandler = \case + Client.CustomTestError msg -> Client.CustomTestError $ addPrefix msg + + testPureErrorHandler :: Pure.TestError -> Pure.TestError + testPureErrorHandler = \case + Pure.CustomTestError msg -> Pure.CustomTestError $ addPrefix msg + err -> err + + withCallStackErrorHandler :: WithCallStack -> WithCallStack + withCallStackErrorHandler (WithCallStack cst e) = WithCallStack cst $ handle e diff --git a/src/Test/Cleveland/Internal/Actions/Helpers.hs b/src/Test/Cleveland/Internal/Actions/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/Helpers.hs @@ -0,0 +1,12 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Helpers for working in @MonadCleveland@ context. +module Test.Cleveland.Internal.Actions.Helpers + ( module Test.Cleveland.Internal.Actions.Helpers + ) where + +withCap :: Monad m => (caps -> cap) -> (cap -> m a) -> ReaderT caps m a +withCap getCap useCap = do + cap <- asks getCap + lift $ useCap cap diff --git a/src/Test/Cleveland/Internal/Actions/Misc.hs b/src/Test/Cleveland/Internal/Actions/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/Misc.hs @@ -0,0 +1,552 @@ +-- SPDX-FileCopyrightText: 2021 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | The bulk of Cleveland actions. +module Test.Cleveland.Internal.Actions.Misc + ( module Test.Cleveland.Internal.Actions.Misc + , noViews + ) where + +import Data.Singletons (demote) +import Fmt (Buildable, Builder, build, indentF, unlinesF, (+|), (|+)) +import Time (KnownDivRat, Second, Time, toNum) +import Unsafe qualified (fromIntegral) + +import Lorentz (BigMapId, Contract(..), DemoteViewsDescriptor, IsoValue, noViews) +import Lorentz.Bytes +import Lorentz.Constraints +import Morley.AsRPC (HasRPCRepr(..)) +import Morley.Client (MorleyClientEnv) +import Morley.Michelson.Runtime (VotingPowers) +import Morley.Michelson.Runtime.Import qualified as Runtime +import Morley.Michelson.Typed (SomeAnnotatedValue) +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.Alias (Alias(..)) +import Morley.Tezos.Core (ChainId, Mutez, Timestamp) +import Morley.Tezos.Crypto (KeyHash, PublicKey, 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.Transfer +import Test.Cleveland.Lorentz.Import qualified as LorentzImport +import Test.Cleveland.Lorentz.Types + +{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-} + +-- $setup +-- >>> :m +Morley.Util.SizedList.Types +-- >>> :{ +-- isEquivalentTo :: Show a => a -> a -> Bool +-- isEquivalentTo a b = Debug.show a == Debug.show b +-- infix 0 `isEquivalentTo` +-- :} + +-- | Update the current sender on whose behalf transfers and originations are +-- invoked. +withSender :: MonadCleveland caps m => ImplicitAddress -> 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 addr = + local (set moneybagL (Moneybag addr)) + +-- | Runs an 'IO' action. +runIO :: (HasCallStack, MonadCleveland caps m) => IO res -> m res +runIO io = do + withCap getMiscCap \cap -> cmiRunIO cap io + +-- | Get the address of the implicit account / contract associated with the given alias. +resolveAddress + :: (HasCallStack, MonadCleveland caps m) + => Alias kind -> m (KindedAddress kind) +resolveAddress alias = do + withCap getMiscCap \cap -> cmiResolveAddress cap 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 + +-- | 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. +-- +-- If the account has too low of a balance, a small amount of XTZ will +-- be transferred to it. +-- +-- Notes: +-- +-- * 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 alias = do + addrs <- newAddresses $ alias :< Nil + case addrs of + addr :< Nil -> pure addr + +-- | Batched version of `newAddress` +newAddresses + :: forall n n' caps m. + (HasCallStack, MonadCleveland caps m, IsoNatPeano n n') + => SizedList n SpecificOrDefaultAlias + -> m (SizedList n ImplicitAddress) +newAddresses aliases = do + addrs <- withCap getMiscCap \cap -> traverse (cmiGenKey cap) aliases + Moneybag moneybag <- view moneybagL + + -- Addresses may exist from previous scenarios runs and have sufficient + -- balance for the sake of testing; if so, we can save some time + balances <- traverse getBalance addrs + withSender moneybag do + inBatch do + sequenceA_ $ + SL.zipWith refillIfLowBalance addrs balances + + pure addrs + where + refillIfLowBalance addr balance = + when (balance < 0.5_e6) do -- < 0.5 XTZ + transfer addr (0.9_e6 :: Mutez) -- 0.9 XTZ + +-- | Generate a new secret key and record it with given alias. If the +-- alias is already known, the key will be overwritten. The address is +-- guaranteed to be fresh, i. e. no operations on it have been made. +newFreshAddress + :: (HasCallStack, MonadCleveland caps m) + => SpecificOrDefaultAlias -> m ImplicitAddress +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 bytes signer = do + withCap getMiscCap \cap -> cmiSignBytes cap bytes signer + +-- | Create a list of similarly named 'SpecificAlias'es. +-- +-- For example, +-- +-- >>> enumAliases @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil +-- True +enumAliases + :: forall n n'. + (SingIPeano n, IsoNatPeano n n') + => ImplicitAlias -> SizedList n SpecificOrDefaultAlias +enumAliases (ImplicitAlias pfx) = + SpecificAlias <$> SL.generate @n (\n -> ImplicitAlias $ pfx <> "-" <> show n) + +-- | Type-safer version of 'signBytes'. +signBinary + :: (HasCallStack, BytesLike bs, MonadCleveland caps m) + => bs -> ImplicitAddress -> m (TSignature bs) +signBinary bs addr = TSignature <$> signBytes (toBytes bs) addr + +-- | Import an untyped contract from file. +importUntypedContract :: (HasCallStack, MonadCleveland caps m) => FilePath -> m U.Contract +importUntypedContract = runIO . Runtime.importUntypedContract + +-- | 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'. +importContract + :: ( HasCallStack, NiceParameter param, NiceStorage st + , NiceViewsDescriptor vd, DemoteViewsDescriptor vd + , MonadCleveland caps m + ) + => FilePath -> m (Contract param st vd) +importContract = runIO . LorentzImport.importContract + +{- | Run operations in a batch. +Best used with the @ApplicativeDo@ GHC extension. + +Example: + +@ +{-# LANGUAGE ApplicativeDo #-} + +contract <- inBatch $ do + contract <- originate ... + for_ [1..3] \i -> + transfer ... + return contract +@ + +Batched operations should be applied to chain faster, but note that batches have +their own limits. For instance, at the moment of writing, the gas limit on a +batch is 10x of gas limit applied to a single operation. + +A context of a batch is only 'Applicative', not 'Monad'. This means that: + +* Return values of one function cannot be passed to another function in the same + batch, it can only be returned; +* Sometimes the compiler does not recognize that only 'Applicative' context is + required, in case of any issues with that - follow the error messages. + +-} +inBatch :: (HasCallStack, MonadCleveland caps m) => ClevelandOpsBatch a -> m a +inBatch batch = do + withCap getOpsCap \cap -> runBatched cap batch + +-- | Print the given string verbatim as a comment. +-- At the moment, this is a no-op in emulator tests. +comment :: (HasCallStack, MonadCleveland caps m) => Text -> m () +comment cmt = do + withCap getMiscCap \cap -> cmiComment cap cmt + +-- | Get the balance of the given address. +getBalance + :: (HasCallStack, MonadCleveland caps m, ToL1Address addr) + => addr -> m Mutez +getBalance addr = do + withCap getMiscCap \cap -> cmiGetBalance cap (toL1Address addr) + +-- | Get the delegate for the given contract. Fails on implicit contracts. +getDelegate + :: (HasCallStack, MonadCleveland caps m, ToContractAddress addr) + => addr -> m (Maybe KeyHash) +getDelegate addr = do + withCap getMiscCap \cap -> cmiGetDelegate cap (toContractAddress addr) + +-- | Register the given address as a valid delegate. +registerDelegate :: (HasCallStack, MonadCleveland caps m) => ImplicitAddress -> m () +registerDelegate addr = do + withCap getMiscCap \cap -> cmiRegisterDelegate cap addr + +-- | Retrieve a contract's storage in its "RPC representation" +-- (i.e., all its big_maps will be replaced by big_map IDs). +-- +-- If the storage is of a user-defined type, then 'Test.Cleveland.deriveRPC' / +-- 'Test.Cleveland.deriveManyRPC' should be used to create an RPC representation of the storage +-- type. +-- +-- > data MyStorage = MyStorage { field1 :: Natural, field2 :: BigMap Integer MText } +-- > deriveRPC "MyStorage" +getStorage + :: forall st addr caps m. + (HasCallStack, MonadCleveland caps m, ToStorageType st addr, IsoValue (AsRPC st)) + => addr + -> m (AsRPC st) +getStorage contract = do + someSt <- getSomeStorage contract + case someSt ^? castTo @(AsRPC st) . value of + Just st -> pure st + Nothing -> failure $ unlinesF + [ "Expected storage to be of type:" + , indentF 2 $ build $ demote @(T.ToT (AsRPC st)) + , "But its type was:" + , indentF 2 $ build $ getT someSt + ] + +-- | Retrieve a contract's full storage, including the contents of its big_maps. +-- +-- This function can only be used in emulator-only tests. +getFullStorage + :: forall st addr caps m. + (HasCallStack, MonadEmulated caps m, ToStorageType st addr) + => addr + -> m st +getFullStorage contract = do + withCap getEmulatedCap \cap -> eiGetStorage cap contract + +-- | Similar to 'getStorage', but doesn't require knowing +-- the storage type in advance. +-- +-- Use the optics in 'Morley.Michelson.Typed.AnnotatedValue' to +-- read data from the storage. +getSomeStorage + :: forall addr caps m. + (HasCallStack, MonadCleveland caps m, ToContractAddress addr) + => addr + -> m SomeAnnotatedValue +getSomeStorage contract = do + withCap getMiscCap \cap -> cmiGetSomeStorage cap (toContractAddress contract) + +-- | Retrieve a big_map value, given a big_map ID and a key. +-- Returns 'Nothing' when the big_map ID does not exist, or it exists but +-- does not contain the given key. +getBigMapValueMaybe + :: forall k v caps m. + ( HasCallStack, MonadCleveland caps m + , NiceComparable k, NicePackedValue k, NiceUnpackedValue v + ) + => BigMapId k v -> k -> m (Maybe v) +getBigMapValueMaybe bmId key = do + withCap getMiscCap \cap -> cmiGetBigMapValueMaybe cap bmId key + +-- | Like 'getBigMapValueMaybe', but fails the tests instead of returning 'Nothing'. +getBigMapValue + :: forall k v caps m. + ( HasCallStack, MonadCleveland caps m + , NiceComparable k, NicePackedValue k, NiceUnpackedValue v + , Buildable k + ) + => BigMapId k v -> k -> m v +getBigMapValue bmId k = + getBigMapValueMaybe bmId k >>= \case + Just v -> pure v + Nothing -> failure $ unlinesF @_ @Builder + [ "Either:" + , " 1. A big_map with ID '" +| bmId |+ "' does not exist, or" + , " 2. It exists, but does not contain the key '" +| k |+ "'." + ] + +-- | Retrieve all big_map values, given a big_map ID. +-- Returns 'Nothing' when the big_map ID does not exist. +getAllBigMapValuesMaybe + :: forall k v caps m. + ( HasCallStack, MonadCleveland caps m + , NiceComparable k, NiceUnpackedValue v + ) + => BigMapId k v -> m (Maybe [v]) +getAllBigMapValuesMaybe bmId = do + withCap getMiscCap \cap -> cmiGetAllBigMapValuesMaybe cap bmId + +-- | Like 'getAllBigMapValuesMaybe', but fails the tests instead of returning 'Nothing'. +getAllBigMapValues + :: forall k v caps m. + ( HasCallStack, MonadCleveland caps m + , NiceComparable k, NiceUnpackedValue v + ) + => BigMapId k v -> m [v] +getAllBigMapValues bmId = + getAllBigMapValuesMaybe bmId >>= \case + Just vs -> pure vs + Nothing -> failure $ "A big map with ID '" +| bmId |+ "' does not exist" + +-- | Retrieve a big_map size, given a big_map ID. +-- Returns 'Nothing' when the big_map ID does not exist. +-- +-- /O(n)/, because it's implemented with 'Morley.Client.RPC.Getters.getBigMapValues'. +getBigMapSizeMaybe + :: forall k v caps m. + ( HasCallStack, MonadCleveland caps m + , NiceComparable k, NiceUnpackedValue v + ) + => BigMapId k v -> m (Maybe Natural) +getBigMapSizeMaybe bmId = + fmap (fmap (Unsafe.fromIntegral @Int @Natural . length)) (getAllBigMapValuesMaybe bmId) + +-- | Like 'getBigMapSizeMaybe', but fails the tests instead of returning 'Nothing'. +getBigMapSize + :: forall k v caps m. + ( HasCallStack, MonadCleveland caps m + , NiceComparable k, NiceUnpackedValue v + ) + => BigMapId k v -> m Natural +getBigMapSize bmId = + Unsafe.fromIntegral @Int @Natural . length <$> getAllBigMapValues bmId + +-- | 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 addr = do + withCap getMiscCap \cap -> cmiGetPublicKey cap addr + +-- | Get the chain's @ChainId@. +getChainId :: (HasCallStack, MonadCleveland caps m) => m ChainId +getChainId = do + withCap getMiscCap \cap -> cmiGetChainId cap + +-- | Advance at least the given amount of time, or until a new block is baked, +-- whichever happens last. +-- +-- On a real network, this is implemented using @threadDelay@, so it's advisable +-- to use small amounts of time only. +advanceTime + :: forall unit caps m + . (HasCallStack, MonadCleveland caps m, KnownDivRat unit Second) + => Time unit -> m () +advanceTime time = do + withCap getMiscCap \cap -> cmiAdvanceTime cap time + +-- | Wait till the provided number of levels is past. +advanceLevel + :: forall caps m + . (HasCallStack, MonadCleveland caps m) + => Natural -> m () +advanceLevel l = do + withCap getMiscCap \cap -> cmiAdvanceToLevel cap (+ l) + +-- | Wait till the provided level is reached. +advanceToLevel + :: forall caps m + . (HasCallStack, MonadCleveland caps m) + => Natural -> m () +advanceToLevel target = do + withCap getMiscCap \cap -> cmiAdvanceToLevel cap (const target) + +-- | Get the timestamp observed by the last block to be baked. +getNow :: (HasCallStack, MonadCleveland caps m) => m Timestamp +getNow = do + withCap getMiscCap \cap -> cmiGetNow cap + +-- | Get the current level observed by the last block to be baked. +getLevel :: (HasCallStack, MonadCleveland caps m) => m Natural +getLevel = do + withCap getMiscCap \cap -> cmiGetLevel cap + +-- | Get approximate block interval in seconds. Note, that this value +-- is minimal bound and real intervals can be larger, see +-- http://tezos.gitlab.io/active/consensus.html#minimal-block-delay-function +-- for more information about block delays. +getApproximateBlockInterval :: (HasCallStack, MonadCleveland caps m) => m (Time Second) +getApproximateBlockInterval = do + withCap getMiscCap \cap -> cmiGetApproximateBlockInterval cap + +-- | Get minimal block delay in seconds. This is essentially the same as +-- 'getApproximateBlockInterval', but returns a 'Natural' instead of @Time +-- Second@. +-- +-- Can be useful when testing code using @MIN_BLOCK_TIME@ instruction. +getMinBlockTime :: (HasCallStack, MonadCleveland caps m) => m Natural +getMinBlockTime = toNum @Second <$> getApproximateBlockInterval + +-- | Execute a contract's code without originating it. +-- The chain's state will not be modified. +-- +-- Notes: +-- +-- * If the contract's code emits operations, they will not be executed. +-- * The sender's account won't be debited. +-- * When running an _originated_ contract, the @BALANCE@ instruction returns the +-- sum of the contract's balance before the transfer operation + the amount of tz being transferred. +-- In other words, this invariant holds: @BALANCE >= AMOUNT@. +-- However, since `runCode` allows overriding the @BALANCE@ instruction, +-- then this invariant no longer holds. It's possible that @BALANCE < AMOUNT@. +runCode + :: (HasCallStack, MonadCleveland caps m, HasRPCRepr st, IsoValue (AsRPC st)) + => RunCode cp st vd -> m (AsRPC st) +runCode rc = do + sender <- view senderL + withCap getMiscCap \cap -> cmiRunCode cap sender rc + +-- | Execute multiple testing scenarios independently. +-- +-- * Actions performed before 'branchout' will be observed by all branches. +-- * Actions performed in branches will _not_ be observed by any actions performed after 'branchout'. +-- * Actions performed in one branch will _not_ be observed by another branch. +-- * The test succeeds IFF all branches succeed. +-- * If any branch fails, the test ends immediately and the remaining branches +-- won't be executed. +-- +-- The following property holds: +-- +-- > pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c] +-- +-- The list of branches must be non-empty. +branchout :: forall caps m. (MonadEmulated caps m) => [(Text, m ())] -> m () +branchout branches = do + caps <- ask + let branches' :: [(Text, ClevelandBaseMonad caps ())] = second (flip runReaderT caps) <$> branches + lift $ eiBranchout (getEmulatedCap caps) branches' + +-- | Execute one or more actions and roll them back afterwards. +-- Actions performed in 'offshoot' will _not_ be observed by any +-- actions performed after 'offshoot'. +-- +-- Similar to 'branchout', but accepts one single branch. +offshoot :: forall caps m. MonadEmulated caps m => Text -> m () -> m () +offshoot branchName branch = branchout [(branchName, branch)] + +{- | Returns the result of the action with the logs it produced. Logs are messages +printed by the Lorentz instruction 'Lorentz.printComment'. + +This function can be combined either with lens-based accessors or helper functions to get +more specific information about logs. + +Examples: + +@ +(logsInfo, _) <- getMorleyLogs scenario +logsInfo ^.. each . logsL @== [MorleyLogs ["log"], MorleyLogs ["log2"]] +logsInfo ^.. each . filterLogsByAddrL addr @== [MorleyLogs ["log"]] +@ + +@ +(logsInfo, _) <- getMorleyLogs scenario +collectLogs logsInfo @== MorleyLogs ["log", "log2"] +logsForAddress logsInfo @== [MorleyLogs ["log"]] +@ + +-} +getMorleyLogs :: forall a caps m. MonadEmulated caps m => m a -> m (LogsInfo, a) +getMorleyLogs action = do + caps <- ask + let action' :: ClevelandBaseMonad caps a = runReaderT action caps + lift $ eiGetMorleyLogs (getEmulatedCap caps) action' + +-- | Version of `getMorleyLogs` for actions that don't return a result. +getMorleyLogs_ :: MonadEmulated caps m => m () -> m LogsInfo +getMorleyLogs_ action = fst <$> getMorleyLogs action + +-- | Updates voting power accessible via @VOTING_POWER@ and similar +-- instructions. +setVotingPowers :: MonadEmulated caps m => VotingPowers -> m () +setVotingPowers vp = do + withCap getEmulatedCap \cap -> eiSetVotingPowers cap vp + +-- | A helper constraint synonym to make signatures below a bit shorter +type EqBaseMonad a b = ClevelandBaseMonad a ~ ClevelandBaseMonad b + +-- | Perform an action if we are currently in emulation mode. +-- See also 'ifEmulation' note on constraints. +whenEmulation + :: MonadCleveland caps m + => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 ()) + -> m () +whenEmulation action = ifEmulation action pass + +-- | Perform an action if we are currently in network mode. +-- See also 'ifEmulation' note on constraints. +whenNetwork + :: MonadCleveland caps m + => (forall caps1 m1. (EqBaseMonad caps caps1, MonadNetwork caps1 m1) => m1 ()) + -> m () +whenNetwork action = ifEmulation pass action + +{- | Perform one action if we are currently in emulation mode, another otherwise + +Functions passed as the first two arguments are universally quantified over +the outer monad, so if additional constraints are required beyond +'MonadEmulated' or 'MonadCleveland', those constraints have to go on the base +monad, e.g. + +@ +someFunction :: (MonadCleveland caps m, MonadFail (ClevelandBaseMonad caps)) => m () +someFunction = whenEmulation do + Just x <- pure (Just 1 :: Maybe Int) -- this would error without MonadFail + runIO $ print x +@ +-} +ifEmulation + :: forall a caps m + . MonadCleveland caps m + => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 a) + -> (forall caps1 m1. (EqBaseMonad caps caps1, MonadNetwork caps1 m1) => m1 a) + -> m a +ifEmulation onEmu onNet = withCap getMiscCap cmiUnderlyingImpl >>= \case + Right impl -> withCap (view clevelandCapsL) (runReaderT onNet . NetworkCaps impl) + Left impl -> withCap (view clevelandCapsL) (runReaderT onEmu . EmulatedCaps impl) + +-- | Get a 'MorleyClientEnv' when running a test on network. Useful to run +-- f.ex. @tezos-client@ inside a network test. +-- +-- 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) diff --git a/src/Test/Cleveland/Internal/Actions/MonadOps.hs b/src/Test/Cleveland/Internal/Actions/MonadOps.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/MonadOps.hs @@ -0,0 +1,38 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Internally used typeclass for operations-related actions +module Test.Cleveland.Internal.Actions.MonadOps + ( module Test.Cleveland.Internal.Actions.MonadOps + ) 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 new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/Originate.hs @@ -0,0 +1,225 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Machinery for the variadic 'originate' function. +module Test.Cleveland.Internal.Actions.Originate + ( module Test.Cleveland.Internal.Actions.Originate + ) where + +import Lorentz + (Contract(..), NiceParameter, NiceStorage, NiceViewsDescriptor, niceStorageEvi, + toMichelsonContract) + +import Data.Constraint ((\\)) +import GHC.TypeLits (ErrorMessage(..), 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.Core +import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Internal.Actions.Helpers +import Test.Cleveland.Internal.Actions.MonadOps + +-- | Originate a new contract with given data. +-- +-- Can accept untypted or Lorentz contracts as-is. With typed Michelson contracts, +-- you need to wrap the contract in 'TypedContract' specifying its Haskell-land +-- parameter, storage types and view descriptors, e.g. +-- +-- > originate "typed contract" defaultStorage $ TypedContract @Param @Storage @() michelsonContract +-- +-- Storage type can be auto-deduced in most cases, so you can skip it with @\@_@. +-- +-- After the mandatory arguments, you can add 'Large' or a 'Mutez' value, e.g. +-- by using @tz@ quasi-quoter: +-- +-- > originate "contract" initialStorage contract Large +-- > originate "contract" initialStorage contract [tz|123micro|] +-- > originate "contract" initialStorage contract [tz|123micro|] Large +-- +-- The order is arbitrary, but each can be specified at most once. +originate :: forall contract r. (HasCallStack, OriginateFunc contract 'NoBalance 'NotLarge r) + => ContractAlias -> ContractStorage contract -> contract -> r +originate = originate'r @contract @'NoBalance @'NotLarge ... 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 + +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) \\ niceStorageEvi @st) + (convertContract $ toMichelsonContract (odContract od)) + ContractHandle odName <$> originateFn uod + +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)) + ContractHandle todName <$> originateFn uod + +instance (a ~ ContractAddress, MonadOpsInternal m) + => Originator (UntypedOriginateData 'NotLarge) (m a) where + originateFn uod = withOpsCap \opsCap -> + runSingleOperation opsCap "origination" (OpOriginate uod) \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 + sender <- view senderL + withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender uod + +---------------------------------------------------------------------------- +-- ContractClass +---------------------------------------------------------------------------- + +-- | 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 + +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 = flip OriginateData zeroMutez + +instance ContractClass U.Contract where + type ContractStorage U.Contract = U.Value + type ContractOriginateData U.Contract = UntypedOriginateData + initialData = flip UntypedOriginateData zeroMutez + +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 + } + +---------------------------------------------------------------------------- +-- "The printf trick" +---------------------------------------------------------------------------- + +-- | The class implementing a guarded "printf trick" for the 'originate' function. +-- +-- If you see GHC asking for this constraint, you most likely need to add +-- 'MonadOriginate' constraint on the return monad instead. +class ContractClass contract => OriginateFunc contract (bal :: HasBalance) isLarge r where + originate'r :: HasCallStack => ContractOriginateData contract isLarge -> r + default originate'r + :: (HasCallStack, Originator (ContractOriginateData contract isLarge) r) + => ContractOriginateData contract isLarge -> r + originate'r = originateFn + +-- | Simple flag to track duplicate balance specification. +data HasBalance = NoBalance | HasBalance + +-- | Type family raising a type error on 'HasBalance' argument. Used to improve +-- error reporting for 'OriginateFunc' instances with equality constraints. +type family CheckDupBalance mod :: Constraint where + CheckDupBalance 'HasBalance = TypeError ('Text "Balance is specified more than once.") + CheckDupBalance 'NoBalance = () + +instance + ( ModifyOriginationData (ContractOriginateData ct) + , OriginateFunc ct 'HasBalance isLarge r + , CheckDupBalance bal, bal ~ 'NoBalance) + => OriginateFunc ct bal isLarge (Mutez -> r) where + originate'r initData x = originate'r @ct @'HasBalance $ setBalance x initData + +-- | Type family raising a type error on 'IsLarge' argument. Used to improve +-- error reporting for 'OriginateFunc' instances with equality constraints. +type family CheckDupLarge mod :: Constraint where + CheckDupLarge 'IsLarge = TypeError ('Text "Large is specified more than once.") + CheckDupLarge 'NotLarge = () + +instance (ModifyOriginationData (ContractOriginateData ct) + , OriginateFunc ct bal 'IsLarge r + , CheckDupLarge isLarge, isLarge ~ 'NotLarge) + => OriginateFunc ct bal isLarge (Large -> r) where + originate'r initData Large = originate'r @ct @bal $ setLarge initData + +-- | Convenience synonym. +type OFConstraint ct large r = + ( ContractClass ct, Originator (ContractOriginateData ct large) r) + +-- | The terminating case for batched transfer. +instance OFConstraint ct large (ClevelandOpsBatch a) + => OriginateFunc ct bal large (ClevelandOpsBatch a) + +-- | The terminating case for Cleveland monads. +instance OFConstraint ct large (ReaderT cap base a) + => OriginateFunc ct bal large (ReaderT cap base a) + +-- | A convenient synonym class to require the terminating instance for a given +-- monad without leaking too much implementation detail. +class (forall ct bal large a. OFConstraint ct large (m a) => OriginateFunc ct bal large (m a)) + => MonadOriginate m +instance (forall ct bal large a. OFConstraint ct large (m a) => OriginateFunc ct bal large (m a)) + => MonadOriginate m + +-- | Catchall incoherent instance to report argument errors. +instance {-# INCOHERENT #-} + ( ContractClass ct + , TypeError ('Text "Incorrect argument for the 'originate' function: " ':<>: 'ShowType x ':$$: + 'Text "If in doubt, try adding a type annotation.")) + => OriginateFunc ct bal large (x -> r) where + originate'r = error "impossible" + +---------------------------------------------------------------------------- +-- Applying modifiers to the initial data +---------------------------------------------------------------------------- + +-- | Mark a contract that doesn't fit into the origination size limit. +-- This will execute multiple origination steps. +-- +-- 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 + setLarge :: od 'NotLarge -> od 'IsLarge + +instance ModifyOriginationData (OriginateData cp st vd) where + setBalance bal od = od {odBalance = bal} + setLarge OriginateData{..} = OriginateData{..} + +instance ModifyOriginationData (UntypedOriginateData) where + setBalance bal od = od {uodBalance = bal} + setLarge UntypedOriginateData{..} = UntypedOriginateData{..} + +instance ModifyOriginationData (TypedOriginateData cp st vd) where + setBalance bal od = od {todBalance = bal} + setLarge TypedOriginateData{..} = TypedOriginateData{..} diff --git a/src/Test/Cleveland/Internal/Actions/Transfer.hs b/src/Test/Cleveland/Internal/Actions/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/Transfer.hs @@ -0,0 +1,331 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Machinery for the variadic 'transfer' function. +module Test.Cleveland.Internal.Actions.Transfer + ( module Test.Cleveland.Internal.Actions.Transfer + ) where + +import Data.Singletons.TH (SingI(..), genSingletons) +import GHC.TypeLits (ErrorMessage(..), TypeError) + +import Lorentz +import Morley.Client.Types +import Morley.Michelson.Typed (Dict(..)) +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.Lorentz.Types + +---------------------------------------------------------------------------- +-- TransferResult and its singletons +---------------------------------------------------------------------------- + +-- | Simple flag to track whether we want to return list of emitted events. +data TransferResult = TransferIgnoreResult | TransferWithEmits + +-- | Type family encoding the actual 'transfer' result depending on +-- 'TransferResult' +type family FTransferResult emit :: Type where + FTransferResult 'TransferWithEmits = [ContractEvent] + FTransferResult 'TransferIgnoreResult = () + +genSingletons [''TransferResult] + +{- +Note [TransferResult singletons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If you're wondering why this complicated song and dance with singletons and not +just multiple terminating instances for each 'TransferWithEmits' value, if we +want to keep 'MonadTransfer', we need terminating instances work for any @emit@, +possibly constrained; if we have instances for a specific value, it's ambiguous +which one to choose in 'MonadTransfer'. + +They're declared at the top of the file because of TH staging rules. + +-- @lierdakil +-} + +---------------------------------------------------------------------------- +-- transfer +---------------------------------------------------------------------------- + +-- | Base method for making a transfer. +-- +-- You can specify additional arguments after the destination address to modify +-- optional transfer arguments. Those can either be 'Mutez' to specify transfer +-- amount (0 by default), or a specially constructed call descriptor. The order +-- is arbitrary, but it is usually more convenient to specify transfer amount +-- first. For example: +-- +-- > transfer addr [tz|123u|] $ calling (ep @"Entrypoint") () +-- > transfer addr [tz|123u|] +-- +-- If the call isn't specified, then the default entrypoint will be called with +-- @()@, i.e. +-- +-- > transfer addr +-- +-- is functionally the same as +-- +-- > transfer addr $ calling def () +-- +-- If the address in the first argument is untyped, the transfer is unchecked. +-- Unchecked transfers must use 'unsafeCalling' for the call specification. You +-- can also use 'unsafeCalling' with typed address to force an unchecked +-- transfer. +-- +-- See "Test.Cleveland.Internal.Actions.Transfer" for further explanation of the +-- interface. +-- +-- By default, the sender is 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 @withSender@. +transfer :: forall addr r. + ( HasCallStack + , TransferFunc ('Incomplete (InitialTransferMode addr)) + 'TransferIgnoreResult 'HasNoAmount r + , ToL1Address addr ) + => addr -> r +transfer = transfer'r @_ @'TransferIgnoreResult @'HasNoAmount . initialData @addr + +---------------------------------------------------------------------------- +-- Initial transfer data and wrappers +---------------------------------------------------------------------------- + +-- | Data-kind for tracking what type of call we're making. +data TransferMode = Checked Type | Unchecked | Incomplete TransferMode + +-- | Data-kind for call specification. +data GenericCall mode where + CheckedCall + :: (NiceParameter epArg, HasEntrypointArg param epRef epArg) + => epRef -> epArg -> GenericCall ('Checked param) + UncheckedCall :: NiceParameter epArg => U.EpName -> epArg -> GenericCall 'Unchecked + UnspecifiedCall :: GenericCall ('Incomplete param) + +-- | Generic version of 'TransferData' +data GenericTransferData mode = + GenericTransferData + { gtdAddr :: L1Address + , gtdCall :: GenericCall mode + , gtdAmount :: Mutez + } + +-- | Choose the initial 'TransferMode' based on the type of destination address. +type family InitialTransferMode addr :: TransferMode where + InitialTransferMode ContractAddress = 'Unchecked + InitialTransferMode ImplicitAddress = 'Unchecked + InitialTransferMode L1Address = 'Unchecked + InitialTransferMode (L1TAddress param _) = 'Checked param + InitialTransferMode (ContractHandle param _ _) = 'Checked param + +-- | Construct initial 'GenericTransferData' for a given address. +initialData + :: ToL1Address addr + => addr -> GenericTransferData ('Incomplete (InitialTransferMode addr)) +initialData addr = GenericTransferData + { gtdAddr = toL1Address addr + , gtdAmount = zeroMutez + , gtdCall = UnspecifiedCall + } + +---------------------------------------------------------------------------- +-- "The printf trick" for transfer +---------------------------------------------------------------------------- + +-- | Simple flag to track duplicate amount specification. +data HasAmount = HasAmount | HasNoAmount + +-- | The class implementing a guarded "printf trick" for the 'transfer' function. +-- +-- If you see GHC asking for this constraint, you most likely need to add +-- 'MonadTransfer' constraint on the return monad instead. +class TransferFunc (mode :: TransferMode) (emit :: TransferResult) (hasAmount :: HasAmount) r where + transfer'r :: HasCallStack => GenericTransferData mode -> r + +-- | Type family raising a type error on 'HasAmount' argument. Used to improve +-- error reporting for 'TransferFunc' instances with equality constraints. +type family NoDuplicateAmount am :: Constraint where + NoDuplicateAmount 'HasAmount = TypeError ('Text "Amount is specified more than once.") + NoDuplicateAmount 'HasNoAmount = () + +instance (TransferFunc mode emit 'HasAmount r, NoDuplicateAmount am, am ~ 'HasNoAmount) + => TransferFunc mode emit am (Mutez -> r) where + transfer'r initData x = transfer'r @_ @emit @'HasAmount initData{gtdAmount = x} + +-- | Type family raising a type error on 'TransferWithEmits' argument. Used to +-- improve error reporting for 'TransferFunc' instances with equality +-- constraints. +type family NoDuplicateEmit am :: Constraint where + NoDuplicateEmit 'TransferWithEmits = + TypeError ('Text "WithContractEvents is specified more than once.") + NoDuplicateEmit 'TransferIgnoreResult = () + +instance (TransferFunc mode 'TransferWithEmits am r + , NoDuplicateEmit emit, emit ~ 'TransferIgnoreResult) + => TransferFunc mode emit am (WithContractEvents -> r) where + transfer'r initData _ = transfer'r @_ @'TransferWithEmits @am initData + +-- | Type family that defines possible mode conversions in 'TransferFunc'. +-- Basically, we don't allow unchecked calls to become checked, and we require +-- that checked calls do not change the parameter type mid-way. +type family MatchModes from to :: Constraint where + MatchModes ('Incomplete _) 'Unchecked = () + MatchModes ('Incomplete ('Checked param1)) ('Checked param2) = param1 ~ param2 + MatchModes ('Incomplete 'Unchecked) _ = TypeError ( + 'Text "Can not use this type of call with an untyped address." + ':$$: 'Text "Try using 'unsafeCalling' instead." + ) + MatchModes _ _ = TypeError ('Text "Call is specified more than once.") + +instance (TransferFunc modeTo emit am r, MatchModes modeFrom modeTo) + => TransferFunc modeFrom emit am (GenericCall modeTo -> r) where + transfer'r GenericTransferData{..} x = + transfer'r @_ @emit @am $ GenericTransferData{gtdCall = x, ..} + +-- | The terminating case for batched transfer +instance ( SingI emit, DoTransfer mode, a ~ FTransferResult emit) + => TransferFunc mode emit am (ClevelandOpsBatch a) where + transfer'r = case sing @emit of + STransferWithEmits -> doTransfer + STransferIgnoreResult -> void . doTransfer + +-- | The terminating case for Cleveland monads +instance ( SingI emit, DoTransfer mode, HasClevelandCaps cap + , base ~ ClevelandBaseMonad cap, a ~ FTransferResult emit ) + => TransferFunc mode emit am (ReaderT cap base a) where + transfer'r = case sing @emit of + STransferWithEmits -> doTransfer + STransferIgnoreResult -> void . doTransfer + +-- | A convenient synonym class to require the terminating instance for a given +-- monad without leaking too much implementation detail. +class ( + forall mod am emit a. (SingI emit, DoTransfer mod, a ~ FTransferResult emit) + => TransferFunc mod emit am (m a) + ) => MonadTransfer m +instance ( + forall mod am emit a. (SingI emit, DoTransfer mod, a ~ FTransferResult emit) + => TransferFunc mod emit am (m a) + ) => MonadTransfer m + +-- | Catchall incoherent instance to report argument errors. +instance {-# INCOHERENT #-} + TypeError ('Text "Incorrect argument for the 'transfer' function: " ':<>: 'ShowType x ':$$: + 'Text "If in doubt, try adding a type annotation.") + => TransferFunc mode emit am (x -> r) where + transfer'r = error "impossible" + +---------------------------------------------------------------------------- +-- Making the actual transfer +---------------------------------------------------------------------------- + +-- | Typeclass abstracting making the actual transfer. +class DoTransfer mode where + doTransfer :: (HasCallStack, MonadOpsInternal m) => GenericTransferData mode -> m [ContractEvent] + +-- | Make the transfer given 'TransferData' +runTransfer :: (HasCallStack, MonadOpsInternal m) => TransferData -> m [ContractEvent] +runTransfer td = withOpsCap \opsCap -> + runSingleOperation opsCap "transfer" (OpTransfer td) \case + OpTransfer ops -> Just ops + _ -> Nothing + +instance DoTransfer 'Unchecked where + doTransfer GenericTransferData + { gtdAddr = tdTo + , gtdAmount = tdAmount + , gtdCall = UncheckedCall tdEntrypoint tdParameter + } = runTransfer TransferData{..} + +instance DoTransfer ('Checked param) where + doTransfer GenericTransferData + { gtdAddr = tdTo + , gtdAmount = tdAmount + , gtdCall = CheckedCall (epRef :: epRef) (tdParameter :: epArg) + } | (Dict, tdEntrypoint) <- useHasEntrypointArg @param @epRef @epArg epRef + = runTransfer TransferData{..} + +instance HasEntrypointArg param (EntrypointRef 'Nothing) () + => DoTransfer ('Incomplete ('Checked param)) where + doTransfer GenericTransferData{..} = + doTransfer GenericTransferData {gtdCall = calling CallDefault @_ @param (), ..} + +instance DoTransfer ('Incomplete 'Unchecked) where + doTransfer GenericTransferData{..} = + doTransfer GenericTransferData {gtdCall = unsafeCalling U.DefEpName (), ..} + +---------------------------------------------------------------------------- +-- Call specification +---------------------------------------------------------------------------- + +-- | Safely call an entrypoint specified by the first argument with the +-- provided parameter. +-- +-- The first character of the entrypoint name must be capitalized. +-- +-- This is "safe" in the sense that the contract is checked if it indeed has the +-- specified entrypoint and the entrypoint in question accepts the argument +-- provided, a type error is raised otherwise. +-- +-- > transfer addr $ calling (ep @"Entrypoint") () +-- +-- Use 'CallDefault' or @def@ to call the default entrypoint. +-- +-- > transfer addr $ calling def () +-- +-- Notice that type variables for entrypoint argument and full parameter are +-- specified after the entrypoint. This is done so more for readability. F. ex.: +-- +-- > transfer addr $ calling def @Integer 123 +-- +-- This does also marginally simplify type inference in the case of partial +-- application. +calling + :: forall mname. + EntrypointRef mname + -> forall epArg param. (NiceParameter epArg, HasEntrypointArg param (EntrypointRef mname) epArg) + => epArg -> GenericCall ('Checked param) +calling arg = CheckedCall arg + +-- | Unsafely call an entrypoint specified by the first argument with the +-- provided parameter. +-- +-- This is "unsafe" in the sense that there is no check that the contract +-- indeed has the specified entrypoint or that the entrypoint in question +-- accepts the argument provided. +-- +-- Also, no compile-time checks are performed on the entrypoint name, so it +-- can be malformed. +-- +-- > transfer addr $ unsafeCalling (ep @"Entrypoint") () +-- +-- Overloaded labels are supported with 'unsafeCalling', so you can specify the +-- entrypoint as an overloaded label: +-- +-- > transfer addr $ unsafeCalling #entrypoint () +-- +-- Use 'U.DefEpName' or @def@ to call the default entrypoint. +-- +-- Notice that the type variable for the entrypoint argument is specified after +-- the entrypoint. This is done so more for readability. F. ex.: +-- +-- > transfer addr $ calling def @Integer 123 +-- +-- This does also marginally simplify type inference in the case of partial +-- application. +unsafeCalling :: U.EpName -> forall epArg. NiceParameter epArg => epArg -> GenericCall 'Unchecked +unsafeCalling arg = UncheckedCall arg + +---------------------------------------------------------------------------- +-- Return value specification +---------------------------------------------------------------------------- + +-- | 'transfer' flag to signal we want contract events emitted by @EMIT@ +-- returned. Passed in the variadic part of 'transfer', e.g. +-- +-- > transfer addr [tz|123u|] WithContractEvents $ calling (ep @"Entrypoint") () +data WithContractEvents = WithContractEvents diff --git a/src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs b/src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs new file mode 100644 --- /dev/null +++ b/src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs @@ -0,0 +1,137 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | 'TransferFailure' Predicates +module Test.Cleveland.Internal.Actions.TransferFailurePredicate + ( module Test.Cleveland.Internal.Actions.TransferFailurePredicate + ) where + +import Data.Either.Validation (Validation(..)) +import Fmt (Builder, build) + +import Lorentz + (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText, + errorToVal, errorToValNumeric, toVal) +import Lorentz.Constraints +import Morley.Micheline (Expression, fromExpression, toExpression) +import Morley.Michelson.Printer.Util (buildRenderDoc) +import Morley.Michelson.Typed (SomeConstant, SomeConstrainedValue(..)) +import Morley.Michelson.Typed qualified as T +import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Lorentz.Types + +-- | A predicate that checks whether a transfer operation failed for the expected reason. +-- +-- 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. + | AndPredicate (NonEmpty TransferFailurePredicate) + | OrPredicate (NonEmpty TransferFailurePredicate) + +instance Boolean TransferFailurePredicate where + AndPredicate l && AndPredicate r = AndPredicate $ l <> r + AndPredicate l && r = AndPredicate $ l <> one r + l && AndPredicate r = AndPredicate $ one l <> r + l && r = AndPredicate $ one l <> one r + + OrPredicate l || OrPredicate r = OrPredicate $ l <> r + OrPredicate l || r = OrPredicate $ l <> one r + l || OrPredicate r = OrPredicate $ one l <> r + l || r = OrPredicate $ one l <> one r + +transferFailureReasonPredicate + :: (TransferFailureReason -> Validation Builder ()) + -> TransferFailurePredicate +transferFailureReasonPredicate p = TransferFailurePredicate $ + \(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" + +-- | 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" + +-- | 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" + +-- | 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" + +-- | 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 + where + isEq :: Expression -> SomeConstant -> Bool + isEq expr (SomeConstant (v :: T.Value t)) = + either (const False) (== v) (fromExpression @(T.Value t) expr) + +-- | 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 (AddressAndAlias actualAddr _) _ = err + when (actualAddr /= expectedAddr) $ + Failure $ "Failure occurred in contract with address: " <> build expectedAddr + +---------------------------------------------------------------------------- +-- 'FAILWITH' errors +---------------------------------------------------------------------------- + +-- | A constant michelson value that a contract threw with @FAILWITH@. +constant :: forall err. NiceConstant err => err -> SomeConstant +constant err = + withDict (niceConstantEvi @err) $ + SomeConstant $ toVal err + +-- | A lorentz error. +lerror :: forall err. IsError err => err -> SomeConstant +lerror err = errorToVal err SomeConstant + +-- | A custom lorentz error. +customError + :: forall arg tag. (IsError (CustomError tag), MustHaveErrorArg tag (MText, arg)) + => Label tag -> arg -> SomeConstant +customError tag arg = + lerror $ CustomError tag (errorTagToMText tag, arg) + +-- | A custom lorentz error with a @unit@ argument. +customError_ + :: (IsError (CustomError tag), MustHaveErrorArg tag (MText, ())) + => Label tag -> SomeConstant +customError_ tag = customError tag () + +-- | A custom lorentz error with no argument. +customErrorNoArg + :: (IsError (CustomError tag), MustHaveErrorArg tag MText) + => Label tag -> SomeConstant +customErrorNoArg tag = + lerror $ CustomError tag (errorTagToMText tag) + +-- | A lorentz numeric error. +numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant +numericError tagMap err = errorToValNumeric tagMap err SomeConstant 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 @@ -6,7 +6,7 @@ module Test.Cleveland.Internal.Client ( ClientM (..) - , runClevelandT + , runNetworkT -- * Capability implementations , networkOpsImpl @@ -20,7 +20,6 @@ , MoneybagConfigurationException (..) -- * Environment - , NetworkEnv (..) , mkMorleyOnlyRpcEnvNetwork -- * Lens for 'NetworkEnv' @@ -33,7 +32,7 @@ , InternalNetworkScenarioError(..) ) where -import Control.Lens (_head, each, filtered, makeLensesWith) +import Control.Lens (_head, each, filtered) import Data.Aeson.Text qualified as J import Data.Constraint (withDict, (\\)) import Data.Default (def) @@ -45,53 +44,46 @@ import Time (KnownDivRat, Second, Time, sec, threadDelay, toNum, toUnit) import Unsafe qualified (fromIntegral) -import Lorentz (NicePackedValue, toAddress) +import Lorentz (NicePackedValue) import Lorentz qualified as L import Lorentz.Constraints.Scopes (NiceUnpackedValue, niceParameterEvi) -import Morley.AsRPC (AsRPC, HasRPCRepr(..), MaybeRPC(..), TAsRPC, notesAsRPC, rpcSingIEvi) +import Morley.AsRPC (AsRPC, HasRPCRepr(..), TAsRPC, notesAsRPC, rpcSingIEvi) import Morley.Client (MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, runMorleyClientM) import Morley.Client qualified as Client import Morley.Client.Action (Result) import Morley.Client.Action.Reveal qualified as RevealRPC +import Morley.Client.App (failOnTimeout, retryOnceOnTimeout) import Morley.Client.Init 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(..), OperationHash, OriginationScript(..), + BlockId(..), IntOpEvent(..), OriginationScript(..), ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize)) +import Morley.Client.TezosClient.Impl as TezosClient (getPublicKey, getSecretKey, importKey) import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) import Morley.Client.Util qualified as Client import Morley.Micheline (Expression, MichelinePrimitive(..), StringEncode(..), TezosInt64, TezosMutez(..), - _ExpressionPrim, _ExpressionSeq, fromExpression, mpaArgsL, mpaPrimL) + _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 -import Morley.Tezos.Address (Address, mkKeyAddress) -import Morley.Tezos.Address.Alias (AddressOrAlias(..)) +import Morley.Tezos.Address +import Morley.Tezos.Address.Alias import Morley.Tezos.Core as Tezos (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMulMutez, unsafeSubMutez) import Morley.Tezos.Crypto -import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.Exception -import Morley.Util.Lens (postfixLFields) import Morley.Util.Named import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Exceptions (addCallStack) +import Test.Cleveland.Lorentz (toL1Address) import Test.Cleveland.Util (ceilingUnit) -data NetworkEnv = NetworkEnv - { neMorleyClientEnv :: MorleyClientEnv - , neSecretKey :: Maybe Crypto.SecretKey - , neMoneybagAlias :: Alias - , neExplicitDataDir :: Bool - } - -makeLensesWith postfixLFields ''NetworkEnv - -- | Construct 'Client.MorleyOnlyRpcEnv' from 'NetworkEnv'. mkMorleyOnlyRpcEnvNetwork :: NetworkEnv @@ -109,8 +101,8 @@ -- | This error designates that necessary preparations for running tests -- are not made. data MoneybagConfigurationException - = NoMoneybagAddress Alias - | TwoMoneybagKeys Alias SecretKey Address + = NoMoneybagAddress ImplicitAlias + | TwoMoneybagKeys ImplicitAlias SecretKey ImplicitAddress deriving stock (Generic, Show, Eq) instance Buildable MoneybagConfigurationException where @@ -144,7 +136,7 @@ data ClientState = ClientState { csDefaultAliasCounter :: DefaultAliasCounter - , csRefillableAddresses :: Set Address + , csRefillableAddresses :: Set ImplicitAddress , csMoneybagAddress :: Moneybag } @@ -154,7 +146,7 @@ deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadReader (IORef ClientState), MonadFail) -data InternalNetworkScenarioError = TooManyRefillIterations Word Address +data InternalNetworkScenarioError = TooManyRefillIterations Word ImplicitAddress deriving stock (Show) instance Buildable InternalNetworkScenarioError where @@ -164,15 +156,18 @@ instance Exception InternalNetworkScenarioError where displayException = pretty -runClevelandT :: NetworkEnv -> ClevelandT ClientM a -> IO a -runClevelandT env scenario = do +runNetworkT :: NetworkEnv -> NetworkT ClientM a -> IO a +runNetworkT env scenario = do disableAlphanetWarning moneybagAddr <- setupMoneybagAddress env - let caps = ClevelandCaps - { ccSender = Sender $ unMoneybag moneybagAddr - , ccMoneybag = moneybagAddr - , ccMiscCap = networkMiscImpl (neMorleyClientEnv env) - , ccOpsCap = networkOpsImpl (neMorleyClientEnv env) + let caps = NetworkCaps + { ncNetworkEnv = env + , ncClevelandCaps = ClevelandCaps + { ccSender = Sender $ unMoneybag moneybagAddr + , ccMoneybag = moneybagAddr + , ccMiscCap = networkMiscImpl env + , ccOpsCap = networkOpsImpl (neMorleyClientEnv env) + } } ist <- newIORef ClientState { csDefaultAliasCounter = DefaultAliasCounter 0 @@ -195,21 +190,22 @@ (Nothing, Just addr) -> do unless neExplicitDataDir do ek <- runMorleyClientM setupEnv $ - Client.getSecretKey (AddressAlias neMoneybagAlias) + (retryOnceOnTimeout ... TezosClient.getSecretKey) + (AddressAlias neMoneybagAlias) void $ runMorleyClientM neMorleyClientEnv $ - Client.importKey False neMoneybagAlias ek + failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek pure addr (Nothing, Nothing) -> throwM $ NoMoneybagAddress neMoneybagAlias (Just ek, Just sa) | mkKeyAddress (toPublic ek) == sa -> do unless neExplicitDataDir $ void $ runMorleyClientM neMorleyClientEnv $ - Client.importKey False neMoneybagAlias ek + failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek pure sa | otherwise -> throwM $ TwoMoneybagKeys neMoneybagAlias ek sa (Just ek, Nothing) -> do runMorleyClientM neMorleyClientEnv $ - Client.importKey False neMoneybagAlias ek + failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek return $ mkKeyAddress (toPublic ek) -- | Implementation that works with real network and uses @tezos-node@ @@ -221,54 +217,57 @@ { coiRunOperationBatch = runOperationBatch env sender } -networkMiscImpl :: MorleyClientEnv -> ClevelandMiscImpl ClientM -networkMiscImpl env = mapClevelandMiscImplExceptions (addCallStack . exceptionHandler) - ClevelandMiscImpl +networkMiscImpl :: NetworkEnv -> ClevelandMiscImpl ClientM +networkMiscImpl env@NetworkEnv{..} = + mapClevelandMiscImplExceptions (addCallStack . exceptionHandler) ClevelandMiscImpl { cmiRunIO = liftIO - , cmiOriginateLargeUntyped = \sender untypedOriginateData -> do - (_, res) <- runClientOrigination env - sender Client.originateLargeUntypedContract untypedOriginateData - comment $ - "Originated large smart contract " +| uodName untypedOriginateData |+ - " with address " <> pretty res + , cmiOriginateLargeUntyped = \(Sender sender) UntypedOriginateData{..} -> do + let originationScenario = + Client.originateLargeUntypedContract True uodName (AddressResolved sender) + uodBalance uodContract uodStorage Nothing + -- 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 + revealKeyUnlessRevealed neMorleyClientEnv sender + runMorleyClientM neMorleyClientEnv originationScenario + comment $ "Originated large smart contract " +| uodName |+ " with address " <> pretty res pure res - , cmiSignBytes = \hash signer -> liftIO $ runMorleyClientM env $ + , cmiSignBytes = \hash signer -> liftIO $ runMorleyClientM neMorleyClientEnv $ -- We don't use password protected accounts in cleveland tests Client.signBytes (AddressResolved signer) Nothing hash , cmiGenKey = \sodAlias -> do alias <- resolveSpecificOrDefaultAlias sodAlias - liftIO $ runMorleyClientM env $ Client.genKey alias + liftIO $ runMorleyClientM neMorleyClientEnv $ Client.genKey alias , cmiGenFreshKey = \sodAlias -> do alias <- resolveSpecificOrDefaultAlias sodAlias - liftIO $ runMorleyClientM env $ Client.genFreshKey alias + liftIO $ runMorleyClientM neMorleyClientEnv $ Client.genFreshKey alias - , cmiGetBalance = getBalanceHelper - , cmiGetChainId = liftIO $ runMorleyClientM env Client.getChainId + , cmiGetBalance = \(MkConstrainedAddress a) -> getBalanceHelper a + , cmiGetChainId = liftIO $ runMorleyClientM neMorleyClientEnv Client.getChainId , cmiAttempt = try , cmiThrow = throwM , cmiMarkAddressRefillable = setAddressRefillable - , cmiRegisterDelegate = \addr -> liftIO $ runMorleyClientM env $ do + , cmiRegisterDelegate = \addr -> liftIO $ runMorleyClientM neMorleyClientEnv $ do alias <- Client.getAlias (AddressResolved addr) Client.registerDelegate alias Nothing , cmiComment = comment - , cmiEmulatedImpl = pure Nothing + , cmiUnderlyingImpl = pure $ Right env + , cmiFailure = clientFailure , .. } where - cmiFailure :: Builder -> ClientM a - cmiFailure = throwM . CustomTestError . pretty - cmiGetBigMapValueMaybe :: (NicePackedValue k, NiceUnpackedValue v) => BigMapId k v -> k -> ClientM (Maybe v) cmiGetBigMapValueMaybe bigMapId k = - liftIO . runMorleyClientM env $ Client.readBigMapValueMaybe bigMapId k + liftIO . runMorleyClientM neMorleyClientEnv $ Client.readBigMapValueMaybe bigMapId k cmiGetAllBigMapValuesMaybe :: (NiceUnpackedValue v) => BigMapId k v -> ClientM (Maybe [v]) cmiGetAllBigMapValuesMaybe bigMapId = - liftIO . runMorleyClientM env $ Client.readAllBigMapValuesMaybe bigMapId + liftIO . runMorleyClientM neMorleyClientEnv $ Client.readAllBigMapValuesMaybe bigMapId getStorageType :: Expression -> ClientM U.Ty getStorageType contractExpr = do @@ -282,14 +281,14 @@ . _head case storageTypeExprMb of - Nothing -> cmiFailure $ unlinesF + Nothing -> clientFailure $ unlinesF [ "Contract expression did not contain a 'storage' expression." , "Contract expression:" , indentF 2 $ build (J.encodeToTextBuilder contractExpr) ] Just storageTypeExpr -> case fromExpression @U.Ty storageTypeExpr of - Left err -> cmiFailure $ unlinesF + Left err -> clientFailure $ unlinesF [ "'storage' expression was not a valid type expression." , "Storage expression:" , indentF 2 $ build (J.encodeToTextBuilder storageTypeExpr) @@ -298,9 +297,10 @@ ] Right storageType -> pure storageType - cmiGetSomeStorage :: Address -> ClientM SomeAnnotatedValue + cmiGetSomeStorage :: ContractAddress -> ClientM SomeAnnotatedValue cmiGetSomeStorage addr = do - OriginationScript {osCode, osStorage} <- liftIO . runMorleyClientM env $ Client.getContractScript addr + OriginationScript {osCode, osStorage} <- + liftIO . runMorleyClientM neMorleyClientEnv $ Client.getContractScript addr storageType <- getStorageType osCode T.withUType storageType \(storageNotes :: T.Notes t) -> do withDict (rpcSingIEvi @t) do @@ -308,7 +308,7 @@ Right storageValueRPC -> pure $ SomeAnnotatedValue (notesAsRPC storageNotes) storageValueRPC Left err -> - cmiFailure $ unlinesF + clientFailure $ unlinesF [ "Failed to decode storage expression." , "Storage expression:" , indentF 2 $ build (J.encodeToTextBuilder osStorage) @@ -316,27 +316,30 @@ , indentF 2 $ build err ] - cmiResolveAddress :: Alias -> ClientM Address - cmiResolveAddress = liftIO . runMorleyClientM env . Client.resolveAddress . AddressAlias + cmiResolveAddress :: Alias kind -> ClientM (KindedAddress kind) + cmiResolveAddress = + liftIO . runMorleyClientM neMorleyClientEnv . Client.resolveAddress . AddressAlias - cmiGetPublicKey :: Address -> ClientM PublicKey - cmiGetPublicKey = liftIO . runMorleyClientM env . Client.getPublicKey . AddressResolved + cmiGetPublicKey :: ImplicitAddress -> ClientM PublicKey + cmiGetPublicKey = liftIO . runMorleyClientM neMorleyClientEnv . + (retryOnceOnTimeout ... TezosClient.getPublicKey) . AddressResolved - getBalanceHelper :: Address -> ClientM Mutez - getBalanceHelper = liftIO . runMorleyClientM env . Client.getBalance + getBalanceHelper :: L1AddressKind kind => KindedAddress kind -> ClientM Mutez + getBalanceHelper = liftIO . runMorleyClientM neMorleyClientEnv . Client.getBalance - cmiGetDelegate :: Address -> ClientM (Maybe KeyHash) - cmiGetDelegate = liftIO . runMorleyClientM env . Client.getDelegate + cmiGetDelegate :: ContractAddress -> ClientM (Maybe KeyHash) + cmiGetDelegate = + liftIO . runMorleyClientM neMorleyClientEnv . Client.getDelegate cmiGetNow :: ClientM Tezos.Timestamp - cmiGetNow = timestampFromUTCTime <$> getLastBlockTimestamp env + cmiGetNow = timestampFromUTCTime <$> getLastBlockTimestamp neMorleyClientEnv cmiGetLevel :: ClientM Natural - cmiGetLevel = getLastBlockLevel env + cmiGetLevel = getLastBlockLevel neMorleyClientEnv cmiGetApproximateBlockInterval :: ClientM (Time Second) cmiGetApproximateBlockInterval = liftIO $ do - pp <- runMorleyClientM env $ Client.getProtocolParameters + pp <- runMorleyClientM neMorleyClientEnv $ Client.getProtocolParameters return . sec $ (unStringEncode $ ppMinimalBlockDelay pp) % 1 cmiAdvanceTime :: (KnownDivRat unit Second) => Time unit -> ClientM () @@ -350,12 +353,12 @@ deltaSec' :: NominalDiffTime deltaSec' = secondsToNominalDiffTime $ toNum @Second deltaSec - t0 <- getLastBlockTimestamp env + t0 <- getLastBlockTimestamp neMorleyClientEnv threadDelay deltaSec let go :: ClientM () go = do - now <- getLastBlockTimestamp env + now <- getLastBlockTimestamp neMorleyClientEnv if (now `diffUTCTime` t0) >= deltaSec' then pass else threadDelay (sec 1) >> go @@ -363,7 +366,7 @@ cmiAdvanceToLevel :: (Natural -> Natural) -> ClientM () cmiAdvanceToLevel targetLevelFn = do - lastLevel <- getLastBlockLevel env + lastLevel <- getLastBlockLevel neMorleyClientEnv let targetLevel = max (targetLevelFn lastLevel) lastLevel let skippedLevels = targetLevel - lastLevel -- In case we need to skip more than one level we'll jump ahead for @@ -386,21 +389,15 @@ cmiRunCode :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st)) => Sender -> RunCode cp st vd -> ClientM (AsRPC st) - cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcLevel rcNow rcBalance rcSource) = - liftIO $ runMorleyClientM env do + cmiRunCode (Sender sender) (RunCode rcContract rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) = + liftIO $ runMorleyClientM neMorleyClientEnv do -- Pattern match on the contract constructor to reveal - -- a proof of `NiceParameter cp` and `NiceStorage st` + -- a proof of `NiceStorage st` L.Contract{} <- pure rcContract T.fromVal <$> Client.runContract Client.RunContractParameters { rcpContract = L.toMichelsonContract $ rcContract - , rcpStorage = - case rcStorage of - NotRPC v -> NotRPC $ toVal v - IsRPC v -> IsRPC $ toVal v - , rcpParameter = - case rcParameter of - NotRPC v -> NotRPC $ toVal v - IsRPC v -> IsRPC $ toVal v + , rcpParameter = rcParameter + , rcpStorage = rcStorage , rcpAmount = rcAmount , rcpBalance = rcBalance , rcpSource = rcSource @@ -408,13 +405,19 @@ , rcpNow = rcNow , rcpSender = Just sender } - \\ L.niceParameterEvi @cp \\ L.niceStorageEvi @st +clientFailure :: Builder -> ClientM a +clientFailure = throwM . CustomTestError . pretty + comment :: Text -> ClientM () comment msg = liftIO $ putTextLn msg >> hFlush stdout -getAlias :: MorleyClientEnv -> Address -> ClientM Alias +getAlias + :: L1AddressKind kind + => MorleyClientEnv + -> KindedAddress kind + -> ClientM (Alias kind) getAlias env = liftIO . runMorleyClientM env . Client.getAlias . AddressResolved getLastBlockTimestamp :: MorleyClientEnv -> ClientM UTCTime @@ -426,7 +429,11 @@ bc <- liftIO $ runMorleyClientM env (Client.getBlockConstants HeadId) pure . Unsafe.fromIntegral @Int64 @Natural . bhnhLevel $ bcHeader bc -runOperationBatch :: MorleyClientEnv -> Address -> [OperationInfo ClevelandInput] -> ClientM [OperationInfo Result] +runOperationBatch + :: MorleyClientEnv + -> ImplicitAddress + -> [OperationInfo ClevelandInput] + -> ClientM [OperationInfo ClevelandResult] runOperationBatch env sender ops = do istRef <- ask ClientState{csMoneybagAddress=Moneybag moneybag} <- readIORef istRef @@ -535,16 +542,47 @@ snd <$> Client.runOperations (AddressResolved sender) ops' forM_ results $ \case - OpTransfer () -> pass + OpTransfer _ -> pass OpOriginate addr -> do alias <- getAlias env addr comment $ "Originated smart contract '" +| alias |+ "' with address " <> pretty addr OpReveal () -> pass - return results + mapM toClevelandResult results -dryRunOperations :: AddressOrAlias +toClevelandResult :: OperationInfo Result -> ClientM (OperationInfo ClevelandResult) +toClevelandResult = \case + OpTransfer ops -> OpTransfer <$> mapM intOpEventToContractEvent ops + OpOriginate ops -> pure $ OpOriginate ops + OpReveal ops -> pure $ OpReveal ops + +intOpEventToContractEvent :: IntOpEvent -> ClientM ContractEvent +intOpEventToContractEvent IntOpEvent{..} = do + T.AsUType (ceType :: T.Notes t) <- either throwM (pure . toTy) $ fromExpression @U.T ioeType + cePayload <- case ioePayload of + Nothing -> pure Nothing + Just payload -> case fromExpression @(T.Value t) . toExpression $ payload of + Right value -> pure . Just $ SomeAnnotatedValue ceType value + Left err -> + clientFailure $ unlinesF + [ "Failed to decode event payload expression." + , "Payload expression:" + , indentF 2 $ build (J.encodeToTextBuilder $ toExpression payload) + , "Decoding error:" + , indentF 2 $ build err + ] + pure $ ContractEvent + { ceSource = ioeSource + , ceTag = maybe "" unMText ioeTag + , .. + } + where + toTy :: U.T -> U.Ty + toTy t = U.Ty t U.noAnn + + +dryRunOperations :: ImplicitAddressOrAlias -> [OperationInfo Client.ClientInput] -> Client.MorleyClientM [(AppliedResult, Mutez)] dryRunOperations s = \case @@ -569,11 +607,12 @@ exceptionToTransferFailure :: RPC.ClientRpcError -> ClientM TransferFailure exceptionToTransferFailure = \case - RPC.ContractFailed addr expr -> return $ TransferFailure addr $ FailedWith (EOTVExpression expr) Nothing - RPC.BadParameter addr _ -> return $ TransferFailure addr BadParameter - RPC.EmptyTransaction addr -> return $ TransferFailure addr EmptyTransaction - RPC.ShiftOverflow addr -> return $ TransferFailure addr ShiftOverflow - RPC.GasExhaustion addr -> return $ TransferFailure addr GasExhaustion + RPC.ContractFailed addr expr -> return $ TransferFailure (AddressAndAlias (MkAddress addr) Nothing) $ + FailedWith (EOTVExpression expr) Nothing + RPC.BadParameter addr _ -> return $ TransferFailure (AddressAndAlias addr Nothing) BadParameter + RPC.EmptyTransaction addr -> return $ TransferFailure (AddressAndAlias (MkAddress addr) Nothing) EmptyTransaction + RPC.ShiftOverflow addr -> return $ TransferFailure (AddressAndAlias (MkAddress addr) Nothing) ShiftOverflow + RPC.GasExhaustion addr -> return $ TransferFailure (AddressAndAlias (MkAddress addr) Nothing) GasExhaustion internalError -> throwM internalError exceptionHandler :: ClientM a -> ClientM a @@ -581,32 +620,7 @@ Left err -> exceptionToTransferFailure err >>= throwM Right res -> return res -runClientOrigination - :: MorleyClientEnv - -> Sender - -> ( Bool - -> Alias - -> AddressOrAlias - -> Mutez - -> U.Contract - -> U.Value - -> Maybe Mutez - -> Client.MorleyClientM (OperationHash, Address) - ) - -> UntypedOriginateData - -> ClientM (OperationHash, Address) -runClientOrigination env (Sender sender) mkScenario (UntypedOriginateData{..}) = do - let originationScenario = - mkScenario True uodName (AddressResolved sender) - uodBalance uodContract uodStorage Nothing - -- 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 - liftIO $ do - revealKeyUnlessRevealed env sender - runMorleyClientM env originationScenario - -resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM Alias +resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM ImplicitAlias resolveSpecificOrDefaultAlias (SpecificAlias alias) = pure alias resolveSpecificOrDefaultAlias (DefaultAlias) = do stateRef <- ask @@ -614,13 +628,13 @@ writeIORef stateRef ist{ csDefaultAliasCounter = DefaultAliasCounter $ counter + 1 } pure $ mkDefaultAlias counter -setAddressRefillable :: Address -> ClientM () +setAddressRefillable :: ImplicitAddress -> ClientM () setAddressRefillable addr = do stRef <- ask modifyIORef stRef $ \st@ClientState{..} -> st{csRefillableAddresses=Set.insert addr csRefillableAddresses} -isAddressRefillable :: Address -> ClientM Bool +isAddressRefillable :: ImplicitAddress -> ClientM Bool isAddressRefillable addr = do stRef <- ask Set.member addr . csRefillableAddresses <$> readIORef stRef @@ -631,7 +645,7 @@ convertOriginateUntypedData :: (MonadThrow m) - => UntypedOriginateData -> m Client.OriginationData + => UntypedOriginateData 'NotLarge -> m Client.OriginationData convertOriginateUntypedData UntypedOriginateData{..} = do SomeContractAndStorage contract storage <- throwLeft . pure $ typeCheckingWith def $ @@ -649,7 +663,7 @@ :: TransferData -> Client.TransactionData convertTransferData TransferData{ tdParameter = param :: p, ..} = Client.TransactionData Client.TD - { tdReceiver = toAddress tdTo + { tdReceiver = toL1Address tdTo , tdAmount = tdAmount , tdEpName = tdEntrypoint , tdParam = toVal param @@ -657,7 +671,7 @@ } \\ niceParameterEvi @p -- | Runs 'Client.revealKeyUnlessRevealed' with given client environment. -revealKeyUnlessRevealed :: MorleyClientEnv -> Address -> IO () +revealKeyUnlessRevealed :: MorleyClientEnv -> ImplicitAddress -> IO () revealKeyUnlessRevealed env addr = runMorleyClientM env $ -- We don't use password protected accounts in cleveland. Client.revealKeyUnlessRevealed addr Nothing 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 @@ -26,9 +26,7 @@ -- | Run an 'Scenario' via the "Morley.Michelson.Runtime" emulator, -- inside an @hedgehog@ property. testScenarioProps :: (HasCallStack, MonadIO m, MonadTest m) => Scenario PureM -> m () -testScenarioProps = evalIO . \case - ScenarioCleveland s -> runClevelandT moneybagAlias s - ScenarioEmulated s -> runEmulatedT moneybagAlias s +testScenarioProps (ScenarioEmulated s) = evalIO $ runEmulatedT moneybagAlias s evalIO :: (HasCallStack, MonadIO m, MonadTest m) => IO a -> m a evalIO m = either (withFrozenCallStack failWithException) pure =<< liftIO (tryAll m) 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 @@ -4,7 +4,6 @@ -- | Integration with integrational testing engine (pun intended). module Test.Cleveland.Internal.Pure ( PureM(..) - , runClevelandT , runEmulatedT -- * Capability implementations @@ -23,36 +22,31 @@ , emptyScenarioBranch -- * Optics - , psAliases + , psSecretKeys , psDefaultAliasesCounter , psRefillableAddresses , psNow , psLevel , psMinBlockTime , psGState - , psContractsNames ) where -import Control.Lens (assign, at, makeLenses, modifying, to, (%=), (.=)) +import Control.Lens (assign, at, each, makeLenses, modifying, to, (%=), (.=), (?=), (?~)) 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 Data.Default (def) import Data.Map qualified as Map -import Data.Monoid (Ap(..)) import Data.Ratio ((%)) import Data.Set qualified as Set -import Data.Singletons (sing) -import Data.Type.Equality (type (:~:)(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), MaybeRPC(..), notesAsRPC, replaceBigMapIds, rpcStorageScopeEvi, valueAsRPC) +import Morley.AsRPC (HasRPCRepr(AsRPC), notesAsRPC, rpcStorageScopeEvi, valueAsRPC) import Morley.Client (OperationInfo(..)) import Morley.Michelson.Interpret (InterpretError(..), InterpretResult(..), MichelsonFailed(..), MichelsonFailureWithStack(..)) @@ -61,37 +55,40 @@ import Morley.Michelson.Runtime.Dummy (dummyLevel, dummyMaxSteps, dummyMinBlockTime, dummyNow, dummyOrigination) import Morley.Michelson.Runtime.GState - (GState(..), asBalance, genesisAddress, genesisSecretKey, gsAddressesL, gsChainIdL, gsCounterL, - gsVotingPowersL, initGState) -import Morley.Michelson.TypeCheck (TCError(..), typeCheckContractAndStorage, typeCheckingWith) + (GState(..), genesisAddress, genesisSecretKey, gsChainIdL, gsContractAddressAliasesL, + gsContractAddressesL, gsCounterL, gsImplicitAddressAliasesL, gsVotingPowersL, initGState, + lookupBalance) +import Morley.Michelson.TypeCheck + (BigMapFinder, TCError(..), TypeCheckOptions(..), typeCheckContractAndStorage, + typeCheckValueRunCodeCompat, typeCheckingWith) import Morley.Michelson.Typed - (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), ToT, Value, Value'(..), castM, - dfsFoldMapValue, fromVal, requireEq, toVal) + (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), SomeConstrainedValue(SomeValue), + SomeVBigMap(..), SomeValue, ToT, Value, Value'(..), castM, dfsFoldMapValue, fromVal, toVal) import Morley.Michelson.Typed qualified as T -import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..)) +import Morley.Michelson.Typed.Operation + (EmitOperation(..), OriginationOperation(..), TransferOperation(..)) import Morley.Michelson.Untyped qualified as U -import Morley.Tezos.Address (Address, detGenKeyAddress) -import Morley.Tezos.Address.Alias (Alias(..)) +import Morley.Tezos.Address +import Morley.Tezos.Address.Alias import Morley.Tezos.Core (Timestamp, timestampPlusSeconds, unsafeSubMutez, zeroMutez) import Morley.Tezos.Crypto (SecretKey(..), detSecretKey, sign, toPublic) import Morley.Util.MismatchError import Morley.Util.Named +import Morley.Util.Bimap qualified as Bimap import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Exceptions (addCallStack, catchWithCallStack, throwWithCallStack) import Test.Cleveland.Lorentz import Test.Cleveland.Util (ceilingUnit) data PureState = PureState - { _psAliases :: Aliases + { _psSecretKeys :: Map ImplicitAddress SecretKey , _psDefaultAliasesCounter :: DefaultAliasCounter - , _psRefillableAddresses :: Set Address + , _psRefillableAddresses :: Set ImplicitAddress , _psNow :: Timestamp , _psLevel :: Natural , _psMinBlockTime :: Natural , _psGState :: GState - , _psContractsNames :: Map Address Text - -- ^ Map from contracts addresses to human-readable names. } deriving stock (Eq, Show) @@ -99,69 +96,49 @@ get = ask >>= readIORef put = (ask >>=) . flip writeIORef -data AddressName = AddressName (Maybe Text) Address deriving stock (Show) - newtype PureM a = PureM { unPureM :: ReaderT (IORef PureState) (CatchT (WriterT LogsInfo IO)) a } deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadReader (IORef PureState), MonadWriter LogsInfo, MonadFail) -type Aliases = Map Alias AliasData - --- | Datatype to store alias data, we store optional 'SecretKey' in addition --- to 'Address' in order to support bytes signing. -data AliasData = AliasData - { adAddress :: Address - , adMbSecretKey :: Maybe SecretKey - } - deriving stock (Eq, Show) - data TestError = UnexpectedTypeCheckError TCError | UnexpectedStorageType (MismatchError T.T) - | UnexpectedBigMapKeyType (MismatchError T.T) - | UnexpectedBigMapValueType (MismatchError T.T) + | UnexpectedBigMapType Natural (MismatchError T.T) | CustomTestError Text deriving stock Show makeLenses ''PureState -instance Buildable AddressName where - build (AddressName mbName addr) = - build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName - instance Buildable TestError where - build (UnexpectedTypeCheckError tcErr) = - "Unexpected type check error. Reason: " +| tcErr |+ "" - build (UnexpectedStorageType merr) = - "Unexpected storage type.\n" +| merr |+ "" - build (UnexpectedBigMapKeyType merr) = - "Unexpected big map key type.\n" +| merr |+ "" - build (UnexpectedBigMapValueType merr) = - "Unexpected big map value type.\n" +| merr |+ "" - build (CustomTestError msg) = pretty msg + build = \case + UnexpectedTypeCheckError tcErr -> + "Unexpected type check error. Reason: " +| tcErr |+ "" + UnexpectedStorageType merr -> + "Unexpected storage type.\n" +| merr |+ "" + UnexpectedBigMapType bigMapId mismatchError -> + unlinesF + [ "A big_map with the ID " +| bigMapId |+ " was found, but it does not have the expected type." + , build mismatchError + ] + CustomTestError msg -> pretty msg instance Exception TestError where displayException = pretty -moneybagAlias :: Alias -moneybagAlias = Alias "moneybag" - -runEmulatedT :: Alias -> EmulatedT PureM a -> IO a -runEmulatedT moneybagAlias' scenario = - runClevelandT moneybagAlias' do - clevelandCaps <- ask - lift . runReaderT scenario $ EmulatedCaps emulatedImpl clevelandCaps +moneybagAlias :: ImplicitAlias +moneybagAlias = ImplicitAlias "moneybag" -runClevelandT :: Alias -> ClevelandT PureM a -> IO a -runClevelandT moneybagAlias' scenario = do - let caps = ClevelandCaps +runEmulatedT :: ImplicitAlias -> EmulatedT PureM a -> IO a +runEmulatedT moneybagAlias' scenario = do + let clevelandCaps = ClevelandCaps { ccSender = Sender genesisAddress , ccMoneybag = Moneybag genesisAddress , ccMiscCap = clevelandMiscImpl , ccOpsCap = clevelandOpsImpl } + caps = EmulatedCaps emulatedImpl clevelandCaps let pureM = runReaderT scenario caps env <- newIORef (initEnv moneybagAlias') (res, _logs) <- runWriterT $ runCatchT $ runReaderT (unPureM pureM) env @@ -187,32 +164,41 @@ ClevelandOpsImpl { coiRunOperationBatch = mapM \case OpOriginate UntypedOriginateData{..} -> do - ref <- originate uodContract (pretty uodName) uodStorage uodBalance - OpOriginate <$> saveAlias uodName (toAddress ref) Nothing + OpOriginate <$> originate uodContract uodName uodStorage uodBalance OpTransfer TransferData{..} -> do let fromAddr = #from :! sender - let toAddr = #to :! toAddress tdTo + 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 - transfer @() moneybag toSender (unsafeSubMutez tdAmount balance) + 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. - transfer @() fromAddr toAddr tdAmount + emitOps <- transfer @() fromAddr toAddr tdAmount (TrustEpName tdEntrypoint) tdParameter - return $ OpTransfer () + return $ OpTransfer $ emitOpToContractEvent <$> emitOps OpReveal{} -> do -- We do not care about reveals in our Morley runtime return $ OpReveal () } +emitOpToContractEvent :: EmitOperation -> ContractEvent +emitOpToContractEvent EmitOperation{eoEmit=T.Emit{..},..} = ContractEvent + { cePayload = case T.notesT emNotes of + -- A dirty hack to match reference + T.TUnit -> Nothing + _ -> Just $ SomeAnnotatedValue emNotes emValue + , ceTag = emTag + , ceSource = eoSource + } + clevelandMiscImpl :: ClevelandMiscImpl PureM clevelandMiscImpl = mapClevelandMiscImplExceptions (addCallStack . exceptionHandler) @@ -221,19 +207,13 @@ Right res -> pure res Left (err :: SomeException) -> throwM err - , cmiResolveAddress = resolve + , cmiResolveAddress = \case + a@ImplicitAlias{} -> resolveImplicit a + a@ContractAlias{} -> resolveContract a , cmiSignBytes = \bs addr -> do - -- TODO [#248]: make sure this performs fast - alias <- getAlias addr - aliases <- use psAliases - let mbMbSk = Map.lookup alias aliases - mbSk <- maybe (unknownAlias alias) (pure . adMbSecretKey) mbMbSk - case mbSk of - Nothing -> - cmiFailure $ - "Given address doesn't have known associated secret key: " <> build alias - Just sk -> liftIO $ sign sk bs + sk <- getSecretKey addr + liftIO $ sign sk bs , cmiGenKey = \sodAlias -> do alias <- resolveSpecificOrDefaultAlias sodAlias @@ -242,23 +222,15 @@ , cmiGenFreshKey = \sodAlias -> do alias <- resolveSpecificOrDefaultAlias sodAlias - aliases <- use psAliases - let mbSk = Map.lookup alias aliases - smartGenKey (adAddress <$> mbSk) alias + existingAddr <- use (psGState . gsImplicitAddressAliasesL . at alias) + smartGenKey existingAddr alias , cmiOriginateLargeUntyped = originateUntyped -- Comments are not supported by integrational testing engine (yet). , cmiComment = const pass , cmiGetPublicKey = \addr -> do - aliases <- use psAliases - let mbAliasInfo = fmap snd $ find (\(_, AliasData addr' _) -> addr == addr') (Map.toList aliases) - aliasInfo <- maybe (unknownAddress addr) pure mbAliasInfo - case adMbSecretKey aliasInfo of - Nothing -> - cmiFailure $ - "Given address doesn't have known associated public key: " <> build addr - Just sk -> pure $ toPublic sk + toPublic <$> getSecretKey addr , cmiGetDelegate = \addr -> do ContractState _ _ _ delegate <- contractStorage addr pure delegate @@ -278,20 +250,17 @@ , cmiAttempt = try , cmiThrow = throwM , cmiMarkAddressRefillable = setAddressRefillable - , cmiGetBalance = getBalance - , cmiEmulatedImpl = pure $ Just emulatedImpl + , cmiGetBalance = \(MkConstrainedAddress a) -> getBalance a + , cmiUnderlyingImpl = pure $ Left emulatedImpl + , cmiFailure = failure , .. } where - cmiFailure :: forall a. Builder -> PureM a - cmiFailure = throwM . CustomTestError . pretty - setAddressRefillable addr = psRefillableAddresses %= Set.insert addr - originateUntyped :: Sender -> UntypedOriginateData -> PureM Address + originateUntyped :: Sender -> UntypedOriginateData 'IsLarge -> PureM ContractAddress originateUntyped _ UntypedOriginateData {..} = do - ref <- originate uodContract (pretty uodName) uodStorage uodBalance - saveAlias uodName (toAddress ref) Nothing + originate uodContract uodName uodStorage uodBalance cmiGetBigMapValueMaybe :: forall k v. @@ -300,6 +269,9 @@ -> k -> PureM (Maybe v) cmiGetBigMapValueMaybe (BigMapId bmId) k = runMaybeT do + -- The RPC does not distinguish between "the bigmap does not exist" + -- and "the bigmap exists, but the key doesn't", so we mimic the RPC's behaviour here. + -- We simply return `Nothing` in both cases. VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId hoistMaybe $ fromVal @v <$> Map.lookup (toVal k) bigMap @@ -312,59 +284,6 @@ VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId pure $ fromVal @v <$> Map.elems bigMap - findBigMapById - :: forall k v. (SingI v, SingI k) - => Natural -> PureM (Value ('T.TBigMap k v)) - findBigMapById bigMapId = - runMaybeT (findBigMapByIdMaybe @k @v bigMapId) >>= maybe notFound pure - where - notFound = cmiFailure $ "BigMap with ID " <> build bigMapId <> " not found." - - - -- | Traverse storage values of all contracts and looks for a big_map with the given ID. - -- If multiple big_maps with the given ID are found, it fails with error. - findBigMapByIdMaybe - :: forall k v. (SingI v, SingI k) - => Natural -> MaybeT PureM (Value ('T.TBigMap k v)) - findBigMapByIdMaybe bigMapId = MaybeT do - addresses <- use $ psGState . gsAddressesL . to Map.elems - - let Ap result = - flip foldMap addresses \case - ASContract ContractState{csStorage} -> - findBigMapInStorage csStorage bigMapId - ASSimple {} -> Ap $ Right [] - - case result of - -- The RPC does not distinguish between "the bigmap does not exist" - -- and "the bigmap exists, but the key doesn't", so we mimic the RPC's behaviour here. - -- We simply return `Nothing` in both cases. - Right [] -> pure Nothing - Right [bigMap] -> pure $ Just bigMap - Right bigMaps -> - error $ pretty $ unlinesF @_ @Builder - [ "Expected all big_maps to have unique IDs, but found " +| length bigMaps |+ " big_maps with the ID " +| bigMapId |+ "." - , "This is most likely a bug." - ] - Left (err :: TestError) -> throwM err - - -- | Traverse a storage value and looks for a big_map with the given ID. - -- If multiple big_maps with the given ID are found, they'll all be returned. - findBigMapInStorage - :: forall k v st. (SingI k, SingI v) - => Value st -> Natural -> Ap (Either TestError) [Value ('T.TBigMap k v)] - findBigMapInStorage storage bigMapId = - dfsFoldMapValue - (\v -> case v of - VBigMap (Just bigMapId') (_ :: Map (Value k') (Value v')) - | bigMapId == bigMapId' -> do - Refl <- requireEq @k' @k (Ap . Left . UnexpectedBigMapKeyType) - Refl <- requireEq @v' @v (Ap . Left . UnexpectedBigMapValueType) - pure [v] - _ -> Ap $ Right [] - ) - storage - -- | In a real chain, when we retrieve a contract's storage via the Tezos RPC, -- the storage expression will have all the big_maps replaced with their respective big_map IDs. -- @@ -375,7 +294,7 @@ -- * A contract with big_maps in its storage is originated -- * A transfer is made and the parameter contains big_maps -- * A contract's code is run and it calls `EMPTY_BIG_MAP`, `DUP` or `DUP n`. - cmiGetSomeStorage :: Address -> PureM SomeAnnotatedValue + cmiGetSomeStorage :: ContractAddress -> PureM SomeAnnotatedValue cmiGetSomeStorage addr = do ContractState _ contract (storage :: Value t) _ <- contractStorage addr pure $ @@ -384,23 +303,28 @@ (valueAsRPC storage) \\ rpcStorageScopeEvi @t - getAlias :: Address -> PureM Alias - getAlias addr = do - aliases <- use psAliases - let maybeAlias = (fmap fst . find (\(_, AliasData addr' _) -> addr == addr') . Map.toList) aliases - maybe (unknownAddress addr) pure maybeAlias - - -- Generate a fresh address which was never generated for given alias. - -- If the address is not saved, we use the alias as its seed. - -- Otherwise we concatenate the alias with the saved address. - smartGenKey :: Maybe Address -> Alias -> PureM Address - smartGenKey existingAddr alias@(Alias aliasTxt) = + -- Generate a fresh address for a given alias. + -- + -- If this alias is not yet associated with any address, + -- we use the alias as the seed for generating a brand new address. + -- + -- If this alias is already associated with an address, + -- then we have to use a _different_ seed to guarantee we'll get a brand new address. + -- Therefore, we concatenate the alias with the existing address and use the + -- result as a seed for generating a brand new address. + smartGenKey :: Maybe ImplicitAddress -> ImplicitAlias -> PureM ImplicitAddress + smartGenKey existingAddr alias@(ImplicitAlias aliasTxt) = do let seed = maybe aliasTxt (mappend aliasTxt . pretty) existingAddr sk = detSecretKey (encodeUtf8 seed) addr = detGenKeyAddress (encodeUtf8 seed) - in saveAlias alias addr $ Just sk + -- Save alias/address association. + psGState . gsImplicitAddressAliasesL . at alias ?= addr + -- Save the address's secret key. + psSecretKeys . at addr .= Just sk + pure addr + resolveSpecificOrDefaultAlias (SpecificAlias alias) = return alias resolveSpecificOrDefaultAlias DefaultAlias = do @@ -411,12 +335,13 @@ cmiRunCode :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st)) => Sender -> RunCode cp st vd -> PureM (AsRPC st) - cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcLevel rcNow rcBalance rcSource) = do + cmiRunCode (Sender sender) (RunCode rcContract rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) = do -- Pattern match on the contract constructor to reveal -- a proof of `NiceParameter cp` and `NiceStorage st` L.Contract{} <- pure rcContract - param <- maybeRPCToVal rcParameter - storage <- maybeRPCToVal rcStorage + param <- typeCheckVal @(ToT cp) rcParameter + storage <- typeCheckVal @(ToT st) rcStorage + (now, level) <- use $ psNow `lensProduct` psLevel psNow %= maybe id const rcNow psLevel %= maybe id const rcLevel @@ -428,15 +353,15 @@ \\ L.niceStorageEvi @st \\ L.niceParameterEvi @cp - esSourceAddress .= rcSource + esSourceAddress .= (MkConstrainedAddress <$> rcSource) counter1 <- use $ esGState . gsCounterL let overrideContractBalance = Just rcBalance executeTransfer (#isGlobalOp :! False) overrideContractBalance def $ TransferOperation - { toDestination = contractAddr + { toDestination = MkAddress contractAddr , toCounter = counter1 , toTxData = TxData - { tdSenderAddress = sender + { tdSenderAddress = MkConstrainedAddress sender , tdParameter = TxTypedParam param \\ L.niceParameterEvi @cp , tdEntrypoint = DefEpName , tdAmount = rcAmount @@ -449,49 +374,83 @@ Left executorError -> throwEE executorError Right (executorRes, contractAddr) -> do -- Find the storage of the contract and return it in its RPC representation. - case executorRes ^. erGState . gsAddressesL . at contractAddr of + case executorRes ^. erGState . gsContractAddressesL . at contractAddr of Nothing -> - cmiFailure $ "Internal error: failed to find contract: '" +| contractAddr |+ "'" - Just (ASSimple {}) -> - cmiFailure $ "Internal error: expected address to belong to a contract: '" +| contractAddr |+ "'" - Just (ASContract (ContractState _ _ (finalStorage :: Value actualSt) _)) -> do + failure $ "Internal error: failed to find contract: '" +| contractAddr |+ "'" + Just (ContractState _ _ (finalStorage :: Value actualSt) _) -> do finalStorage' <- castM @actualSt @(ToT st) finalStorage (throwM . UnexpectedStorageType) pure $ fromVal $ valueAsRPC finalStorage' where - maybeRPCToVal :: MaybeRPC v -> PureM (Value (ToT v)) - maybeRPCToVal = \case - NotRPC v -> pure $ toVal v - IsRPC v -> replaceBigMapIds findBigMapById sing $ toVal v + typeCheckVal :: forall t. SingI t => U.Value -> PureM (Value t) + typeCheckVal untypedVal = do + bigMapFinder <- mkBigMapFinder + let res = + typeCheckingWith (TypeCheckOptions False False) $ + typeCheckValueRunCodeCompat bigMapFinder untypedVal + case res of + Right val -> pure val + Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr -isAddressRefillable :: Address -> PureM Bool +mkBigMapFinder :: PureM BigMapFinder +mkBigMapFinder = do + pureState <- get + + pure \bigMapId -> + pureState ^? + psGState . gsContractAddressesL . each . to getContractStorage . to (getBigMapsWithId bigMapId) . each + where + getContractStorage :: ContractState -> SomeValue + getContractStorage (ContractState _ _ storage _) = SomeValue storage + + getBigMapsWithId :: Natural -> SomeValue -> [SomeVBigMap] + getBigMapsWithId bigMapId (SomeValue val) = + dfsFoldMapValue + (\v -> case v of + VBigMap (Just bigMapId') _ | bigMapId' == bigMapId -> [SomeVBigMap v] + _ -> [] + ) + val + +-- | Traverse storage values of all contracts and looks for a big_map with the given ID. +findBigMapByIdMaybe + ::forall k v. (SingI v, SingI k) + => Natural -> MaybeT PureM (Value ('T.TBigMap k v)) +findBigMapByIdMaybe bigMapId = do + SomeVBigMap (v@VBigMap{} :: Value t) <- MaybeT $ mkBigMapFinder <*> pure bigMapId + castM @t @('T.TBigMap k v) v $ throwM . UnexpectedBigMapType bigMapId + +isAddressRefillable :: ImplicitAddress -> PureM Bool isAddressRefillable addr = Set.member addr <$> use psRefillableAddresses -getBalance :: Address -> PureM Mutez +getBalance :: L1AddressKind kind => KindedAddress kind -> PureM Mutez getBalance addr = do - GState{..} <- use psGState - return $ maybe zeroMutez asBalance $ Map.lookup addr gsAddresses - -saveAlias :: Alias -> Address -> Maybe SecretKey -> PureM Address -saveAlias name addr mbSk = do - psAliases %= Map.insert name (AliasData addr mbSk) - pure addr + gs <- use psGState + pure $ fromMaybe zeroMutez $ lookupBalance addr gs exceptionHandler :: PureM a -> PureM a exceptionHandler action = try action >>= \case Left err -> exceptionToTransferFailure err >>= throwM Right res -> return res where - exceptionToTransferFailure :: ExecutorError' AddressName -> PureM TransferFailure + exceptionToTransferFailure :: ExecutorError' AddressAndAlias -> PureM TransferFailure exceptionToTransferFailure err = case err of - EEZeroTransaction addr -> return $ TransferFailure (addrNameToAddr addr) EmptyTransaction - EEIllTypedParameter addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter - EEUnexpectedParameterType addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter + EEZeroTransaction addr -> return $ + TransferFailure addr EmptyTransaction + EEIllTypedParameter addr _ -> return $ + TransferFailure addr BadParameter + EEUnexpectedParameterType addr _ -> return $ + TransferFailure addr BadParameter EEInterpreterFailed addr (InterpretError (MichelsonFailureWithStack{..}, _)) -> case mfwsFailed of - MichelsonFailedWith val -> return $ TransferFailure (addrNameToAddr addr) $ FailedWith (EOTVTypedValue val) (Just mfwsErrorSrcPos) - MichelsonArithError (T.ShiftArithError{}) -> return $ TransferFailure (addrNameToAddr addr) ShiftOverflow - MichelsonArithError (T.MutezArithError errType _ _) -> return $ TransferFailure (addrNameToAddr addr) $ MutezArithError errType - MichelsonGasExhaustion -> return $ TransferFailure (addrNameToAddr addr) GasExhaustion + MichelsonFailedWith val -> return $ + TransferFailure addr $ + FailedWith (EOTVTypedValue val) (Just mfwsErrorSrcPos) + MichelsonArithError (T.ShiftArithError{}) -> return $ + TransferFailure addr ShiftOverflow + MichelsonArithError (T.MutezArithError errType _ _) -> return $ + TransferFailure addr $ MutezArithError errType + MichelsonGasExhaustion -> return $ + TransferFailure addr GasExhaustion _ -> throwM err _ -> throwM err @@ -504,34 +463,34 @@ => addr -> PureM st getStorageImpl addr = do withDict (pickNiceStorage @st addr) $ do - ContractState _ _ (storage :: Value actualT) _ <- contractStorage (toAddress addr) + ContractState _ _ (storage :: Value actualT) _ <- contractStorage (toContractAddress addr) val <- castM @actualT @(ToT st) storage (throwM . UnexpectedStorageType) pure $ T.fromVal val -- Attempt to retrieve a ContractState given for the given address. Fails if the -- address is unknown or the address is a simple address (contract without -- code and storage). -contractStorage :: Address -> PureM ContractState +contractStorage :: ContractAddress -> PureM ContractState contractStorage addr = do GState{..} <- use psGState - case Map.lookup addr gsAddresses of - Just (ASContract contractState) -> pure contractState - Just (ASSimple {}) -> throwM . CustomTestError $ - "Expected address to be contract with storage, but it's a simple address: " <> pretty addr + case Map.lookup addr gsContractAddresses of + Just contractState -> pure contractState Nothing -> unknownAddress addr -resolve :: Alias -> PureM Address -resolve name = do - aliases <- use psAliases - let maybeAddress = Map.lookup name aliases - maybe (unknownAlias name) (pure . adAddress) maybeAddress +resolveImplicit :: ImplicitAlias -> PureM ImplicitAddress +resolveImplicit alias = do + use (psGState . gsImplicitAddressAliasesL . at alias) >>= maybe (unknownAlias alias) pure -unknownAddress :: Address -> PureM whatever +resolveContract :: ContractAlias -> PureM ContractAddress +resolveContract alias = do + use (psGState . gsContractAddressAliasesL . at alias) >>= maybe (unknownAlias alias) pure + +unknownAddress :: KindedAddress kind -> PureM whatever unknownAddress = throwM . CustomTestError . mappend "Unknown address provided: " . pretty -unknownAlias :: Alias -> PureM whatever +unknownAlias :: Alias kind -> PureM whatever unknownAlias = throwM . CustomTestError . mappend "Unknown address alias: " . pretty @@ -546,32 +505,34 @@ appendScenarioBranch brName (ScenarioBranchName branches) = ScenarioBranchName (brName : branches) +failure :: forall a. Builder -> PureM a +failure = throwM . CustomTestError . pretty + +getSecretKey :: ImplicitAddress -> PureM SecretKey +getSecretKey addr = do + use (psSecretKeys . at addr) >>= \case + Nothing -> unknownAddress addr + Just sk -> pure sk + ---------------------------------------------------------------------------- -- Support functions ---------------------------------------------------------------------------- -initAliases :: Alias -> Aliases -initAliases alias = one ( alias - , AliasData genesisAddress $ - Just $ genesisSecretKey - ) - -initEnv :: Alias -> PureState +initEnv :: ImplicitAlias -> PureState initEnv alias = PureState - { _psAliases = initAliases alias + { _psSecretKeys = one (genesisAddress, genesisSecretKey) , _psDefaultAliasesCounter = DefaultAliasCounter 0 , _psRefillableAddresses = Set.empty , _psNow = dummyNow , _psLevel = dummyLevel - , _psGState = initGState + , _psGState = initGState & gsImplicitAddressAliasesL . at alias ?~ genesisAddress , _psMinBlockTime = dummyMinBlockTime - , _psContractsNames = Map.empty } failedInsideBranch :: Text -> SomeException -> FailedInBranch failedInsideBranch name err = case fromException @FailedInBranch err of - Just (FailedInBranch branch failure) -> - FailedInBranch (appendScenarioBranch name branch) failure + Just (FailedInBranch branch exception) -> + FailedInBranch (appendScenarioBranch name branch) exception Nothing -> FailedInBranch (appendScenarioBranch name emptyScenarioBranch) err @@ -582,12 +543,12 @@ transfer :: forall cp vd epRef epArg addr. (HasEntrypointArg cp epRef epArg, T.IsoValue epArg, L.ToTAddress cp vd addr) - => "from" :! Address + => "from" :! ImplicitAddress -> "to" :! addr -> Mutez -> epRef -> epArg - -> PureM () + -> 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 @@ -597,7 +558,7 @@ { toDestination = to' , toCounter = 0 , toTxData = TxData - { tdSenderAddress = from + { tdSenderAddress = MkConstrainedAddress from , tdParameter = withDict (T.properParameterEvi @(ToT epArg)) $ TxTypedParam (T.toVal param) , tdEntrypoint = epName @@ -607,22 +568,30 @@ -- | Originate a contract with given initial storage and balance. Its -- address is returned. -originate :: U.Contract -> Text -> U.Value -> Mutez -> PureM Address -originate uContract contractName uStorage balance = +originate :: U.Contract -> ContractAlias -> U.Value -> Mutez -> PureM ContractAddress +originate uContract alias uStorage balance = case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr Right (T.SomeContractAndStorage contract storage) -> do counter <- gsCounter <$> use psGState - address <- registerInterpretation . executeGlobalOrigination $ - (dummyOrigination storage contract counter) { ooBalance = balance } - - psContractsNames %= Map.insert address contractName - return address + registerInterpretation . executeGlobalOrigination $ + (dummyOrigination storage contract counter) + { ooBalance = balance + , ooAlias = Just alias + } throwEE :: ExecutorError -> PureM a -throwEE err = do - st <- get - throwM $ flip addrToAddrName st <$> err +throwEE err = + -- Replace all `Address`es with `AddressAndAlias` in the error and throw it. + traverse addrToAddressAndAlias err >>= throwM + where + addrToAddressAndAlias :: Address -> PureM AddressAndAlias + addrToAddressAndAlias addr@(MkAddress kindedAddr) = + case kindedAddr of + ContractAddress{} -> + use $ psGState . gsContractAddressAliasesL . Bimap.flipped . at kindedAddr . to (AddressAndAlias addr) + _ -> + pure $ AddressAndAlias addr Nothing -- | Runs a set of operations and updates the engine's state. registerInterpretation :: ExecutorM a -> PureM a @@ -652,10 +621,3 @@ gState <- use psGState minBlockTime <- use psMinBlockTime pure $ runExecutorM now level minBlockTime dummyMaxSteps gState action - -addrToAddrName :: Address -> PureState -> AddressName -addrToAddrName addr iState = - AddressName (Map.lookup addr (iState ^. psContractsNames)) addr - -addrNameToAddr :: AddressName -> Address -addrNameToAddr (AddressName _ addr) = addr 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 @@ -2,42 +2,64 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA module Test.Cleveland.Internal.Scenario - ( Scenario(..) - , scenario + ( Scenario + , Scenario'(..) + , MonadScenario(..) , scenarioEmulated + , scenarioNetwork , withInitialNow , withInitialLevel , withMinBlockTime , withChainId ) where +import Control.Monad.Reader (withReaderT) + import Morley.Michelson.Runtime.GState (gsChainIdL) import Morley.Tezos.Core qualified as TC import Test.Cleveland.Internal.Abstract +import Test.Cleveland.Internal.Client import Test.Cleveland.Internal.Pure --- | A type representing a finalized scenario -data Scenario m where - ScenarioCleveland :: ClevelandT m () -> Scenario m - ScenarioEmulated :: EmulatedT PureM () -> Scenario PureM +-- | A convenience type synonym for `Scenario'` that has 'MonadScenario' +-- constraint baked in. +type Scenario m = MonadScenario m => Scenario' m --- | Finalize a generic cleveland scenario. -scenario :: ClevelandT m () -> Scenario m -scenario = ScenarioCleveland +-- | A type representing a finalized scenario. Usually, when using this type +-- with a polymorphic argument, an additional 'MonadScenario' constraint on the +-- argument is required. +-- +-- To avoid annotating with 'MonadScenario' everywhere, consider using +-- 'Scenario' instead when possible. +data Scenario' m where + ScenarioEmulated :: EmulatedT PureM () -> Scenario' PureM + ScenarioNetwork :: NetworkT ClientM () -> Scenario' ClientM +-- | Typeclass for base monads that can implement a scenario. +class MonadFail m => MonadScenario m where + -- | Finalize a generic cleveland scenario. + scenario :: ClevelandT m () -> Scenario' m + +instance MonadScenario PureM where + scenario = ScenarioEmulated . withReaderT (view clevelandCapsL) + +instance MonadScenario ClientM where + scenario = ScenarioNetwork . withReaderT (view clevelandCapsL) + -- | Finalize a scenario that needs emulator-only features. -scenarioEmulated :: EmulatedT PureM () -> Scenario PureM +scenarioEmulated :: EmulatedT PureM () -> Scenario' PureM scenarioEmulated = ScenarioEmulated +-- | Finalize a scenario that needs network-only features. +scenarioNetwork :: NetworkT ClientM () -> Scenario' ClientM +scenarioNetwork = ScenarioNetwork + withModifiedState :: (PureState -> PureState) - -> Scenario PureM - -> Scenario PureM -withModifiedState modfn = \case - ScenarioEmulated emulated -> - ScenarioEmulated $ lift (modify modfn) >> emulated - ScenarioCleveland cleveland -> - ScenarioCleveland $ lift (modify modfn) >> cleveland + -> Scenario' PureM + -> Scenario' PureM +withModifiedState modfn (ScenarioEmulated emulated) = + ScenarioEmulated $ lift (modify modfn) >> emulated -- | Use with an emulated 'Scenario' to configure the initial @now@ value in tests. -- @@ -46,27 +68,27 @@ -- > testScenarioOnEmulator "Testname" $ withInitialNow (Timestamp 10000000) $ scenario $ tests withInitialNow :: TC.Timestamp - -> Scenario PureM - -> Scenario PureM + -> Scenario' PureM + -> Scenario' PureM withInitialNow = withModifiedState . set psNow -- | Similar to 'withInitialNow' but for the initial level withInitialLevel :: Natural - -> Scenario PureM - -> Scenario PureM + -> Scenario' PureM + -> Scenario' PureM withInitialLevel = withModifiedState . set psLevel -- | Similar to 'withInitialNow' but for the @MINIMAL_BLOCK_DELAY@ protocol constant. withMinBlockTime :: Natural - -> Scenario PureM - -> Scenario PureM + -> Scenario' PureM + -> Scenario' PureM withMinBlockTime = withModifiedState . set psMinBlockTime -- | Similar to 'withInitialNow' but for the chain id withChainId :: TC.ChainId - -> Scenario PureM - -> Scenario PureM + -> Scenario' PureM + -> Scenario' PureM withChainId = withModifiedState . set (psGState . gsChainIdL) diff --git a/src/Test/Cleveland/Lorentz.hs b/src/Test/Cleveland/Lorentz.hs --- a/src/Test/Cleveland/Lorentz.hs +++ b/src/Test/Cleveland/Lorentz.hs @@ -23,6 +23,9 @@ , chNiceParameterEvi , chNiceStorageEvi + , ToContractAddress (..) + , ToL1Address (..) + , ToL1TAddress (..) , ToStorageType (..) -- * Conversions diff --git a/src/Test/Cleveland/Lorentz/Ticketer.hs b/src/Test/Cleveland/Lorentz/Ticketer.hs --- a/src/Test/Cleveland/Lorentz/Ticketer.hs +++ b/src/Test/Cleveland/Lorentz/Ticketer.hs @@ -12,6 +12,7 @@ import Prelude (HasCallStack) import Test.Cleveland +import Test.Cleveland.Internal.Actions.Transfer -- | A contract that emits the desired tickets. -- @@ -47,14 +48,14 @@ -- | Run a contract indirectly via calling the given ticketer contract. -- --- The target contract will recieve a ticket and some payload. The exact +-- The target contract will receive a ticket and some payload. The exact -- structure of the passed argument is determined by the ticketer contract. callViaTicketer :: forall targetArg payload td targetAddr ticketerParam ticketerAddr m. ( HasCallStack - , MonadOps m + , MonadTransfer m , ticketerParam ~ View_ (payload, (Natural, td)) targetArg - , ToTAddress ticketerParam () ticketerAddr + , ToL1TAddress ticketerParam () ticketerAddr , ToContractRef targetArg targetAddr , NiceParameterFull ticketerParam ) @@ -65,5 +66,5 @@ -> payload -- ^ Main argument passed to the ticketer -> m () callViaTicketer ticketer ticketAmount ticketData target payload = - call @ticketerParam @() ticketer CallDefault - (mkView_ (payload, (ticketAmount, ticketData)) target) + transfer (toL1TAddress @ticketerParam @() ticketer) $ calling def $ + mkView_ (payload, (ticketAmount, ticketData)) target 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 @@ -6,7 +6,11 @@ ( ContractHandle (..) , chNiceParameterEvi , chNiceStorageEvi + , L1TAddress (..) + , ToContractAddress (..) + , ToL1Address (..) + , ToL1TAddress (..) , ToStorageType (..) , NiceParameter @@ -28,6 +32,8 @@ import Lorentz.Address import Lorentz.Constraints import Morley.Michelson.Typed qualified as T +import Morley.Tezos.Address +import Morley.Tezos.Address.Alias -- | Handle to a contract. -- @@ -40,8 +46,8 @@ data ContractHandle (cp :: Type) (st :: Type) (vd :: Type) = (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) => ContractHandle - { chContractName :: Text - , chAddress :: Address + { chContractName :: ContractAlias + , chAddress :: ContractAddress } deriving stock instance Show (ContractHandle cp st vd) @@ -51,7 +57,7 @@ "" instance ToAddress (ContractHandle cp st vd) where - toAddress = chAddress + toAddress = MkAddress . chAddress -- TODO [#577]: simplify this instance once fundep in ToTAddress is added instance (cp' ~ cp, vd ~ vd') => ToTAddress cp' vd' (ContractHandle cp st vd) where @@ -70,15 +76,59 @@ chNiceStorageEvi :: forall param st vd. ContractHandle param st vd -> Dict (T.StorageScope $ T.ToT st) chNiceStorageEvi ContractHandle{} = mapDict (niceStorageEvi @st) Dict +class ToContractAddress addr where + toContractAddress :: addr -> ContractAddress + +instance ToContractAddress ContractAddress where + toContractAddress = id + +instance ToContractAddress (ContractHandle cp st vd) where + toContractAddress = chAddress + +class ToL1Address addr where + toL1Address :: addr -> L1Address + +instance ToL1Address (L1TAddress cp vd) where + toL1Address = unL1TAddress + +instance ToL1Address L1Address where + toL1Address = id + +instance L1AddressKind kind => ToL1Address (KindedAddress kind) where + toL1Address = MkConstrainedAddress + +instance ToL1Address (ContractHandle cp st vd) where + toL1Address = MkConstrainedAddress . chAddress + +-- | Counterpart of 'TAddress' that contains 'L1Address' instead of 'Address'. +newtype L1TAddress cp vd = L1TAddress { unL1TAddress :: L1Address } + +instance (cp ~ cp', vd ~ vd') => ToTAddress cp' vd' (L1TAddress cp vd) where + toTAddress = toTAddress . toAddress . unL1TAddress + +-- | Counterpart of 'ToTAddress' that converts to 'L1TAddress' rather than +-- 'TAddress'. +class (ToTAddress cp vd addr, ToL1Address addr) + => ToL1TAddress cp vd addr where + toL1TAddress :: addr -> L1TAddress cp vd +instance (ToTAddress cp vd addr, ToL1Address addr) + => ToL1TAddress cp vd addr where + toL1TAddress = L1TAddress . toL1Address + +-- NB: We declare ToL1TAddress as a typeclass for two reasons: +-- one, it defines a constraint synonym, and two, if we were to define +-- toL1Address as a simple function, GHC would complain about +-- ToTAddress being redundant -- it's not though, it constrains the types. + -- | Declares that @addr@ points to an entity with a storage. -- -- @addr@ may fix storage type or may not - in the latter case the caller -- has to specify the storage type explicitly via type annotation. -class ToAddress addr => ToStorageType st addr where +class ToContractAddress addr => ToStorageType st addr where -- | Pick proof of that storage type is valid. pickNiceStorage :: addr -> Dict (NiceStorage st) -instance NiceStorage st => ToStorageType st Address where +instance NiceStorage st => ToStorageType st ContractAddress where pickNiceStorage _ = Dict instance (st ~ st') => ToStorageType st' (ContractHandle cp st vd) where 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 @@ -1,6 +1,5 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA -{-# LANGUAGE InstanceSigs #-} -- | This module is the internal implementation of "Test.Cleveland.Tasty". module Test.Cleveland.Tasty.Internal @@ -53,10 +52,10 @@ import Morley.Client (MorleyClientConfig(..), mceTezosClientL, mkMorleyClientEnv) import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) -import Test.Cleveland.Internal.Client as Client - (ClientM, NetworkEnv(..), neMorleyClientEnvL, runClevelandT) +import Test.Cleveland.Internal.Abstract (NetworkEnv(..), neMorleyClientEnvL) +import Test.Cleveland.Internal.Client as Client (ClientM, runNetworkT) import Test.Cleveland.Internal.Exceptions (WithCallStack(WithCallStack)) -import Test.Cleveland.Internal.Pure as Pure (PureM, runClevelandT, runEmulatedT) +import Test.Cleveland.Internal.Pure as Pure (PureM, runEmulatedT) import Test.Cleveland.Internal.Scenario import Test.Cleveland.Tasty.Internal.Options (ContextLinesOpt(..), DataDirOpt(..), EndpointOpt(..), MoneybagAliasOpt(..), PathOpt(..), @@ -80,11 +79,11 @@ -- -- If a 'TestTree' contains many tests scheduled to run on a real Tezos network, -- those tests will be run sequentially. -testScenario :: TestName -> (forall m. MonadFail m => Scenario m) -> TestTree -testScenario testName scenario' = +testScenario :: TestName -> (forall m. Scenario m) -> TestTree +testScenario testName scenario_ = testGroup testName - [ singleTest "On emulator" (RunOnEmulator scenario') - , singleTest onNetworkTag (RunOnNetwork scenario') + [ singleTest "On emulator" (RunOnEmulator scenario_) + , singleTest onNetworkTag (RunOnNetwork scenario_) ] -- | Create a tasty test case from an emulated 'Scenario'. @@ -92,29 +91,27 @@ -- This will create a test tree with 1 test, -- which will run the 'Scenario' on the "Morley.Michelson.Runtime" emulator. testScenarioOnEmulator :: TestName -> Scenario PureM -> TestTree -testScenarioOnEmulator testname scenario' = +testScenarioOnEmulator testname scenario_ = testGroup testname - [ singleTest "On emulator" (RunOnEmulator scenario') ] + [ singleTest "On emulator" (RunOnEmulator scenario_) ] -- | Create a tasty test case from a 'Scenario'. -- -- This will create a test tree with 1 test, -- which will run the 'Scenario' on real Tezos network. testScenarioOnNetwork :: TestName -> Scenario ClientM -> TestTree -testScenarioOnNetwork testname scenario' = +testScenarioOnNetwork testname scenario_ = testGroup testname - [ singleTest onNetworkTag (RunOnNetwork scenario') ] + [ singleTest onNetworkTag (RunOnNetwork scenario_) ] newtype RunOnEmulator = RunOnEmulator (Scenario PureM) instance IsTest RunOnEmulator where run :: OptionSet -> RunOnEmulator -> (Progress -> IO ()) -> IO Result - run opts (RunOnEmulator scenario') _ = do + run opts (RunOnEmulator (ScenarioEmulated emulatedT)) _ = do let MoneybagAliasOpt moneybagAlias = lookupOption opts - io = case scenario' of - ScenarioCleveland s -> Pure.runClevelandT moneybagAlias s - ScenarioEmulated s -> Pure.runEmulatedT moneybagAlias s + io = Pure.runEmulatedT moneybagAlias emulatedT (io $> testPassed "") `catch` printFormattedException opts testOptions = Tagged clevelandOptions @@ -123,11 +120,11 @@ instance IsTest RunOnNetwork where run :: OptionSet -> RunOnNetwork -> (Progress -> IO ()) -> IO Result - run opts (RunOnNetwork (ScenarioCleveland clevelandT)) _ = do + run opts (RunOnNetwork (ScenarioNetwork clevelandT)) _ = do let tastyEnv = tastyEnvFromOpts opts useNetworkEnv tastyEnv $ \networkEnv -> do - let io = Client.runClevelandT networkEnv clevelandT + let io = Client.runNetworkT networkEnv clevelandT (io $> testPassed "") `catch` printFormattedException opts -- If a 'RunOnNetwork' test is created somewhere in a suite, 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 @@ -25,7 +25,7 @@ import Test.Tasty.Options as Tasty (IsOption(..), OptionDescription(Option), safeRead) import Morley.Client.Parser (baseUrlReader) -import Morley.Tezos.Address.Alias (Alias(..)) +import Morley.Tezos.Address.Alias import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.CLI (HasCLReader(getMetavar, getReader)) @@ -134,16 +134,16 @@ parseValue = mkParseValue (SecretKeyOpt . Just) optionCLParser = mkOptionParser (SecretKeyOpt . Just) Nothing -newtype MoneybagAliasOpt = MoneybagAliasOpt Alias +newtype MoneybagAliasOpt = MoneybagAliasOpt ImplicitAlias deriving stock (Show, Eq) instance IsOption MoneybagAliasOpt where - defaultValue = MoneybagAliasOpt $ Alias "moneybag" + defaultValue = MoneybagAliasOpt $ ImplicitAlias "moneybag" optionName = "cleveland-moneybag-alias" optionHelp = "[Test.Cleveland] Alias of the account to be used to execute all transfers/originations " <> "(unless overriden with `withSender`) and fund new accounts (unless overriden with `withMoneybag`)." - parseValue = Just . MoneybagAliasOpt . Alias . fromString + parseValue = Just . MoneybagAliasOpt . ImplicitAlias . fromString data RunModeOpt = RunAllMode diff --git a/src/Test/Cleveland/Util.hs b/src/Test/Cleveland/Util.hs --- a/src/Test/Cleveland/Util.hs +++ b/src/Test/Cleveland/Util.hs @@ -92,7 +92,7 @@ import Morley.Michelson.Doc (DocItem, docItemPosition) import Morley.Michelson.Typed (SingI, SomeConstrainedValue(..)) import Morley.Michelson.Typed qualified as T -import Morley.Tezos.Address (Address, parseAddressRaw) +import Morley.Tezos.Address import Test.Cleveland.Instances () diff --git a/test/TestSuite/Cleveland/AddressRevealing.hs b/test/TestSuite/Cleveland/AddressRevealing.hs --- a/test/TestSuite/Cleveland/AddressRevealing.hs +++ b/test/TestSuite/Cleveland/AddressRevealing.hs @@ -15,6 +15,6 @@ test <- newAddress auto test2 <- newFreshAddress auto - transferMoney test 1000 + transfer test [tz|1000u|] comment "new key address is revealed" - withSender test $ transferMoney test2 1 + withSender test $ transfer test2 [tz|1u|] diff --git a/test/TestSuite/Cleveland/BadAddressReuse.hs b/test/TestSuite/Cleveland/BadAddressReuse.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/BadAddressReuse.hs @@ -0,0 +1,21 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module TestSuite.Cleveland.BadAddressReuse (test_badAddressReuse) where + +import Lorentz qualified as L + +import Test.Tasty (TestTree) + +import Test.Cleveland +import TestSuite.Util + +test_badAddressReuse :: TestTree +test_badAddressReuse = + testScenario "Bad smart contract address reuse (#729 regression test)" $ scenario do + _ <- originate "abcdefgh" () $ idContract @() @() + + addr <- newAddress "abcdefgh" + + target <- newAddress "target" + withSender addr $ transfer target [L.tz|0.1|] 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,7 @@ import Test.Tasty (TestTree) -import Morley.Tezos.Address (Address) +import Morley.Tezos.Address import Morley.Util.SizedList qualified as SL import Morley.Util.SizedList.Types import Test.Cleveland @@ -16,10 +16,10 @@ test_BalanceCheck :: TestTree test_BalanceCheck = testScenario "An address's balance can be checked" $ scenario do - test :: Address <- newFreshAddress auto + test :: ImplicitAddress <- newFreshAddress auto comment "balance is updated after transfer" - transferMoney test 100 + transfer test [tz|100u|] getBalance test @@== 100 test_EmptyBalanceCheck :: TestTree @@ -28,5 +28,5 @@ test ::< dummy ::< Nil' <- traverse newFreshAddress $ SL.replicateT auto -- Doing something in order not to get "validating empty scenario" error - transferMoney dummy 1 + transfer dummy [tz|1u|] getBalance test @@== 0 diff --git a/test/TestSuite/Cleveland/BatchOperation.hs b/test/TestSuite/Cleveland/BatchOperation.hs --- a/test/TestSuite/Cleveland/BatchOperation.hs +++ b/test/TestSuite/Cleveland/BatchOperation.hs @@ -7,7 +7,7 @@ import Test.Tasty (TestTree) -import Morley.Tezos.Core (Mutez, mkMutez) +import Morley.Tezos.Core (mkMutez) import Morley.Util.SizedList qualified as SL import Test.Cleveland import Test.Cleveland.Lorentz.Consumer @@ -21,13 +21,13 @@ test1 <- newFreshAddress auto contract1 <- inBatch $ do - contract1 <- originateSimple "c" ([] :: [()]) contractConsumer - transferMoney test1 100 + contract1 <- originate "c" ([] :: [()]) contractConsumer + transfer test1 [tz|100u|] return contract1 getBalance test1 @@== 100 - transferMoney contract1 200 + transfer contract1 [tz|200u|] getBalance contract1 @@== 200 @@ -35,16 +35,15 @@ addresses <- traverse newFreshAddress $ SL.replicateT @5 auto let balances = SL.generate $ \i -> unsafeMkMutez' $ (i + 1) * 100 - inBatch $ do - for_ (SL.zip addresses balances) $ uncurry transferMoney + inBatch $ for_ (SL.zip addresses balances) $ uncurry transfer traverse getBalance addresses @@== balances , testScenario "Can return multiple values from a batch" $ scenario do (_contract1, _contract2) <- inBatch $ do - contract1 <- originateSimple "c1" ([] :: [Integer]) contractConsumer - contract2 <- originateSimple "c2" ([] :: [Integer]) contractConsumer + contract1 <- originate "c1" ([] :: [Integer]) contractConsumer + contract2 <- originate "c2" ([] :: [Integer]) contractConsumer return (contract1, contract2) return () diff --git a/test/TestSuite/Cleveland/BatchTransferCheck.hs b/test/TestSuite/Cleveland/BatchTransferCheck.hs --- a/test/TestSuite/Cleveland/BatchTransferCheck.hs +++ b/test/TestSuite/Cleveland/BatchTransferCheck.hs @@ -23,8 +23,8 @@ comment "balance is updated after batch transfer" inBatch $ do - for_ [100, 200] $ transferMoney test1 - transferMoney test2 300 + for_ [100 :: Mutez, 200] $ transfer test1 + transfer test2 [tz|300u|] return () traverse getBalance addrs @@== 300 :< 300 :< Nil @@ -56,12 +56,12 @@ test_BatchTransferLeapingCosts :: TestTree test_BatchTransferLeapingCosts = testScenario "Check fees evaluation correctness for leaping transfer costs" $ scenario do - contract <- originateSimple "contract" [] (leapingContract @L.MText) + contract <- originate "contract" [] (leapingContract @L.MText) comment "Perform batch transfer, second transaction should have much \ \higher cost with respect to the first one" inBatch $ - for_ ["a", "b"] $ call contract CallDefault + for_ ["a", "b"] $ transfer contract . calling def comment "Sanity check on storage" getStorage contract @@== diff --git a/test/TestSuite/Cleveland/BytesSigning.hs b/test/TestSuite/Cleveland/BytesSigning.hs --- a/test/TestSuite/Cleveland/BytesSigning.hs +++ b/test/TestSuite/Cleveland/BytesSigning.hs @@ -25,7 +25,7 @@ testScenario "Bytestrings can be signed" $ scenario do dummy :< signer :< Nil <- traverse newFreshAddress $ "user" :< "signer" :< Nil - helper <- originateSimple "helper" () checkSignatureContract + helper <- originate "helper" () checkSignatureContract let bytes = "some bytestring" @@ -34,5 +34,5 @@ dummyPK <- getPublicKey dummy expectFailedWith [L.mt|Invalid signature|] $ - call helper CallDefault (dummyPK, (sig, bytes)) - call helper CallDefault (signerPK, (sig, bytes)) + transfer helper $ calling def (dummyPK, (sig, bytes)) + transfer helper $ calling def (signerPK, (sig, bytes)) 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 @@ -30,8 +30,8 @@ import Morley.Client (TezosClientError(EConnreset), mceClientEnvL, mceTezosClientL) import Morley.Client.TezosClient (tceEndpointUrlL) import Morley.Michelson.Typed (convertContract, untypeValue) -import Morley.Tezos.Address (ta) -import Morley.Util.Interpolate (lit) +import Morley.Tezos.Address +import Morley.Util.Interpolate (it, lit) import Morley.Util.SizedList.Types import Test.Cleveland import Test.Cleveland.Internal.Client (neMorleyClientEnvL) @@ -159,94 +159,63 @@ do void $ signBinary @ByteString "" invalidAddr - , testFailureIncludesCallStack "callstack points to originateUntyped" - [lit| - void $ originateUntyped UntypedOriginateData - { uodName = "" - , uodBalance = 0 - , uodStorage = untypeValue $ toVal @Natural 3 - , uodContract = convertContract $ toMichelsonContract @() @() idContract - } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - |] - do - -- force a failure by using a storage of the wrong type - void $ originateUntyped UntypedOriginateData - { uodName = "" - , uodBalance = 0 - , uodStorage = untypeValue $ toVal @Natural 3 - , uodContract = convertContract $ toMichelsonContract @() @() idContract - } - - , testFailureIncludesCallStack "callstack points to originateUntypedSimple" + , testFailureIncludesCallStack "callstack points to originate with untyped" [lit| - void $ originateUntypedSimple "" + void $ originate "" (untypeValue $ toVal @Natural 3) (convertContract $ toMichelsonContract @() @() idContract) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by using a storage of the wrong type - void $ originateUntypedSimple "" + void $ originate "" (untypeValue $ toVal @Natural 3) (convertContract $ toMichelsonContract @() @() idContract) - , testFailureIncludesCallStack "callstack points to originate" + , testFailureIncludesCallStack "callstack points to originate with lorentz" [lit| - void $ originate OriginateData - { odName = "" - , odBalance = maxBound - , odStorage = () - , odContract = idContract @() @() - } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + void $ originate + "" + () + (idContract @() @()) + (maxBound :: Mutez) + ^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by transfering `maxBound` mutez - void $ originate OriginateData - { odName = "" - , odBalance = maxBound - , odStorage = () - , odContract = idContract @() @() - } + void $ originate + "" + () + (idContract @() @()) + (maxBound :: Mutez) , testFailureIncludesCallStack "callstack points to transfer" [lit| - transfer TransferData - { tdTo = invalidAddr - , tdAmount = 0 - , tdEntrypoint = DefEpName - , tdParameter = () - } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + transfer invalidAddr + ^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by transfering from an unknown alias - transfer TransferData - { tdTo = invalidAddr - , tdAmount = 0 - , tdEntrypoint = DefEpName - , tdParameter = () - } + transfer invalidAddr , testFailureIncludesCallStack "callstack points to transferMoney" - [lit| - transferMoney invalidAddr 1 - ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + [it| + transfer invalidAddr [tz|1u|\&] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by transfering from an unknown address - transferMoney invalidAddr 1 + transfer invalidAddr [tz|1u|] & withSender invalidAddr , testFailureIncludesCallStack "callstack points to call" [lit| - call invalidTAddr CallDefault () - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + transfer invalidTAddr + ^^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by transfering to an unknown address - call invalidTAddr CallDefault () + transfer invalidTAddr , testFailureIncludesCallStack "callstack points to inBatch for batched transfers" [lit| @@ -256,8 +225,8 @@ do -- force a failure by transfering to an unknown address inBatch $ do - call (TAddress @() invalidAddr) CallDefault () - call (TAddress @() invalidAddr) CallDefault () + transfer invalidAddr + transfer invalidAddr return () , testFailureIncludesCallStack "callstack points to importUntypedContract" @@ -327,8 +296,8 @@ ^^^^^^^^^^^^^^^^^^^^^^^^ |] do - addr <- originateSimple "" () contractFailWith1 - err <- catchTransferFailure $ call addr CallDefault () + addr <- originate "" () contractFailWith1 + err <- catchTransferFailure $ transfer addr checkTransferFailure err $ failedWith (constant @Natural 2) , testGroup "expectTransferFailure" $ @@ -356,8 +325,8 @@ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do - addr <- originateSimple "" () contractFailWith1 - call addr CallDefault () + addr <- originate "" () contractFailWith1 + transfer addr & expectTransferFailure (failedWith (constant @Natural 2)) ] @@ -411,27 +380,27 @@ , testFailureIncludesCallStack "callstack points to getStorage" [lit| - void $ getStorage @() invalidAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^ + void $ getStorage @() invalidContractAddr + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do - void $ getStorage @() invalidAddr + void $ getStorage @() invalidContractAddr , testFailureIncludesCallStackOnEmulator "callstack points to getFullStorage on emulator" [lit| - void $ getFullStorage @() invalidAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + void $ getFullStorage @() invalidContractAddr + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do - void $ getFullStorage @() invalidAddr + void $ getFullStorage @() invalidContractAddr , testFailureIncludesCallStackOnEmulator "callstack points to getSomeStorage on emulator" [lit| - void $ getSomeStorage invalidAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^ + void $ getSomeStorage invalidContractAddr + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do - void $ getSomeStorage invalidAddr + void $ getSomeStorage invalidContractAddr , sabotageNetworkEnv $ testFailureIncludesCallStackOnNetwork "callstack points to getBigMapValueMaybe" @@ -504,8 +473,8 @@ void $ runCode RunCode { rcContract = L.defaultContract @() @() $ L.failUsing @MText "Contract should fail" - , rcStorage = NotRPC () - , rcParameter = NotRPC () + , rcStorage = untypeValue $ toVal () + , rcParameter = untypeValue $ toVal () , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing @@ -518,8 +487,8 @@ void $ runCode RunCode { rcContract = L.defaultContract @() @() $ L.failUsing @MText "Contract should fail" - , rcStorage = NotRPC () - , rcParameter = NotRPC () + , rcStorage = untypeValue $ toVal () + , rcParameter = untypeValue $ toVal () , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing @@ -529,16 +498,16 @@ , testFailureIncludesCallStackOnEmulator "when a branchout branch throws, the callstack points to the function inside the branch" [lit| - getStorage @() invalidAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^ + getStorage @() invalidContractAddr + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | In 'a' branch: - | Unknown address provided: tz1fsFpWk691ncq1xwS62dbotECB67B13gfC + | Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye |] do branchout [ "a" ?- void $ - getStorage @() invalidAddr + getStorage @() invalidContractAddr ] , testFailureIncludesCallStackOnEmulator "when a branchout branch throws ANY exception, the exception raised is printed in a right way" @@ -558,16 +527,16 @@ , testFailureIncludesCallStackOnEmulator "when offshoot throws, the callstack points to the function inside offshoot" [lit| - getStorage @() invalidAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^ + getStorage @() invalidContractAddr + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | In 'a' branch: - | Unknown address provided: tz1fsFpWk691ncq1xwS62dbotECB67B13gfC + | Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye |] do offshoot "a" $ void $ - getStorage @() invalidAddr + getStorage @() invalidContractAddr , testFailureIncludesCallStack "callstack points to failure" [lit| @@ -694,9 +663,11 @@ ] where + invalidAlias :: ContractAlias invalidAlias = "UnknownAlias" invalidAddr = [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|] - invalidTAddr = TAddress @() invalidAddr + invalidContractAddr = ContractAddress $ mkContractHashHack "asdf" + invalidTAddr = ContractHandle @() @() @() "asdf" invalidContractAddr test_callStack_property :: TestTree test_callStack_property = diff --git a/test/TestSuite/Cleveland/ChainIdGet.hs b/test/TestSuite/Cleveland/ChainIdGet.hs --- a/test/TestSuite/Cleveland/ChainIdGet.hs +++ b/test/TestSuite/Cleveland/ChainIdGet.hs @@ -22,8 +22,8 @@ test_ChainIdGet :: TestTree test_ChainIdGet = testScenario "ChainId is retrievable" $ scenario do - helperAddr <- originateSimple "helper" (#storage :! dummyChainId) checkChainIdContract + helperAddr <- originate "helper" (#storage :! dummyChainId) checkChainIdContract chainId <- getChainId - call helperAddr CallDefault () + transfer helperAddr getStorage helperAddr @@== #storage :! chainId diff --git a/test/TestSuite/Cleveland/ContractAllocation.hs b/test/TestSuite/Cleveland/ContractAllocation.hs --- a/test/TestSuite/Cleveland/ContractAllocation.hs +++ b/test/TestSuite/Cleveland/ContractAllocation.hs @@ -7,7 +7,7 @@ import Test.Tasty (TestTree) -import Morley.Tezos.Address (Address) +import Morley.Tezos.Address import Morley.Util.Named import Test.Cleveland @@ -16,15 +16,8 @@ test_ContractAllocation :: TestTree test_ContractAllocation = testScenario "Contracts can be allocated and called" $ scenario do - addresses :: [Address] <- replicateM 10 $ newFreshAddress auto - let - od = OriginateData - { odName = "allocator" - , odStorage = #storage :! (take 570 $ cycle addresses) - , odBalance = 25 - , odContract = allocatorContract - } - - allocatorAddr <- originate od + addresses :: [Address] <- replicateM 10 $ toAddress <$> newFreshAddress auto + let storage = #storage :! (take 570 $ cycle addresses) + allocatorAddr <- originate "allocator" storage allocatorContract [tz|25micro|] - call allocatorAddr CallDefault (take 25 $ cycle addresses) + transfer allocatorAddr $ calling def (take 25 $ cycle addresses) diff --git a/test/TestSuite/Cleveland/DFS.hs b/test/TestSuite/Cleveland/DFS.hs --- a/test/TestSuite/Cleveland/DFS.hs +++ b/test/TestSuite/Cleveland/DFS.hs @@ -10,7 +10,6 @@ import Lorentz.Address import Lorentz.Entrypoints import Morley.Michelson.Typed qualified as T -import Morley.Tezos.Core (Mutez) import Test.Cleveland import TestSuite.Util.Contracts (inContractsDir) @@ -51,16 +50,11 @@ -- balance [ testScenario "Operations are performed in DFS order" $ scenario do transferAllAddr <- - importContract (inContractsDir "transfer_all.tz") - >>= originateSimple @TransferAllParameter "transfer_all" () . noViews + importContract @TransferAllParameter (inContractsDir "transfer_all.tz") + >>= originate "transfer_all" () . noViews transferAllCallerAddr <- - importContract (inContractsDir "transfer_all_caller.tz") - >>= originateSimple @TransferAllCallerParameter "transfer_all_caller" () . noViews - transfer $ TransferData - { tdTo = transferAllAddr - , tdAmount = 100 - , tdEntrypoint = ep "receiveXtz" - , tdParameter = () - } -- transferAllAddr 100 - call transferAllCallerAddr (Call @"CallCPS") (toTAddress transferAllAddr) + importContract @TransferAllCallerParameter (inContractsDir "transfer_all_caller.tz") + >>= originate "transfer_all_caller" () . noViews + transfer transferAllAddr [tz|100u|] $ calling (ep @"ReceiveXtz") () + transfer transferAllCallerAddr $ calling (ep @"CallCPS") $ toTAddress transferAllAddr ] diff --git a/test/TestSuite/Cleveland/EmitMachinery.hs b/test/TestSuite/Cleveland/EmitMachinery.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/EmitMachinery.hs @@ -0,0 +1,62 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module TestSuite.Cleveland.EmitMachinery + ( test_SimpleEmit + , test_InferredEmit + , test_MultipleEmit + ) where + +import Fmt (pretty) +import Test.Tasty (TestTree) + +import Lorentz (Contract) +import Test.Cleveland +import Test.Cleveland.Lorentz (embedContract) +import TestSuite.Util.Contracts + +test_SimpleEmit :: TestTree +test_SimpleEmit = + testScenario "transferWithEmit works on simple emit" $ scenario do + simpleEmit <- originate "simple_emit" () contract + [ContractEvent{..}] <- transfer simpleEmit WithContractEvents $ calling def () + pretty cePayload @== ("Right \"right\" :: or (nat %int) (string %str)" :: Text) + toAddress ceSource @== toAddress simpleEmit + ceTag @== "notify_client" + where + contract :: Contract () () () + contract = $$(embedContract (inContractsDir "simple_emit.tz")) + +test_InferredEmit :: TestTree +test_InferredEmit = + testScenario " on WithContractEvents inferred emit" $ scenario do + inferredEmit <- originate "inferred_emit" () contract + [ContractEvent{..}] <- transfer inferredEmit WithContractEvents $ calling def () + pretty cePayload @== ("Right \"right\" :: or nat string" :: Text) + toAddress ceSource @== toAddress inferredEmit + ceTag @== "" + where + contract :: Contract () () () + contract = $$(embedContract (inContractsDir "inferred_emit.tz")) + +test_MultipleEmit :: TestTree +test_MultipleEmit = + testScenario "transferWithEmit works on multiple emit" $ scenario do + multipleEmit <- originate "multiple_emit" () contract + evs <- transfer multipleEmit WithContractEvents $ calling def () + length evs @== 4 + let expected = + [("one", Just "Right \"right\" :: or nat string") + ,("two", Just "Left 123 :: or nat string") + ,("three", Just "False :: bool") + ,("four", Nothing)] + check ContractEvent{..} (tag, ty) = do + pretty <$> cePayload @== (ty :: Maybe Text) + toAddress ceSource @== toAddress multipleEmit + ceTag @== tag + -- events are CONS'ed in the contract and hence end up reversed; + -- the expectation is reversed here to simplify reasoning a bit. + zipWithM_ check evs $ reverse expected + where + contract :: Contract () () () + contract = $$(embedContract (inContractsDir "multiple_emit.tz")) diff --git a/test/TestSuite/Cleveland/EmptyImplicitAddress.hs b/test/TestSuite/Cleveland/EmptyImplicitAddress.hs --- a/test/TestSuite/Cleveland/EmptyImplicitAddress.hs +++ b/test/TestSuite/Cleveland/EmptyImplicitAddress.hs @@ -17,8 +17,8 @@ test_EmptyImplicitAddressCalls = testScenario "Calling a contract with empty implicit address fails" $ scenario do addr <- newFreshAddress auto - contract <- originateSimple "contract" () $ idContract @() @() - call contract CallDefault () + contract <- originate "contract" () $ idContract @() @() + transfer contract (calling def ()) & withSender addr & shouldFailWithMessage "Empty implicit contract" @@ -27,6 +27,6 @@ testScenario "Transferring from empty implicit address fails" $ scenario do addr <- newFreshAddress auto recvr <- newAddress auto - transferMoney recvr 0 + transfer recvr [tz|0|] & withSender addr & shouldFailWithMessage "Empty implicit contract" 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 @@ -23,7 +23,7 @@ , testScenarioOnEmulator "fails if any branch fails" $ scenarioEmulated do addr <- newAddress auto - let branchA = "a" ?- transferMoney addr 0 + let branchA = "a" ?- transfer addr [tz|0u|] let branchB = "b" ?- pass branchout [branchA, branchB] & expectTransferFailure emptyTransaction branchout [branchB, branchA] & expectTransferFailure emptyTransaction @@ -33,10 +33,10 @@ initialBalance <- getBalance test branchout [ "a" ?- do - transferMoney test 2 + transfer test [tz|2u|] getBalance test @@== initialBalance + 2 , "b" ?- do - transferMoney test 3 + transfer test [tz|3u|] getBalance test @@== initialBalance + 3 ] @@ -44,26 +44,26 @@ test <- newAddress auto initialBalance <- getBalance test branchout - [ "a" ?- transferMoney test 3 ] + [ "a" ?- transfer test [tz|3u|] ] getBalance test @@== initialBalance , testScenarioOnEmulator "adds branch name to error" $ scenarioEmulated do branchout [ "" ?- void $ - signBytes "" (unsafe $ parseAddress "tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM") + signBytes "" [ta|tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM|] ] & shouldFailWithMessage "" ] , testGroup "offshoot" [ testScenarioOnEmulator "fails if inner scenario fails" $ scenarioEmulated do addr <- newAddress auto - offshoot "a" (transferMoney addr 0) + offshoot "a" (transfer addr [tz|0u|]) & expectTransferFailure emptyTransaction , testScenarioOnEmulator "offshoot's effects are discarded" $ scenarioEmulated do test <- newAddress auto initialBalance <- getBalance test - offshoot "a" $ transferMoney test 1 + offshoot "a" $ transfer test [tz|1u|] getBalance test @@== initialBalance ] ] diff --git a/test/TestSuite/Cleveland/ErrorMessages.hs b/test/TestSuite/Cleveland/ErrorMessages.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/ErrorMessages.hs @@ -0,0 +1,18 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module TestSuite.Cleveland.ErrorMessages + ( test_error_message_shows_contract_alias + ) where + +import Lorentz as L +import Test.Cleveland +import Test.Tasty (TestTree) +import TestSuite.Util (shouldFailWithMessage) + +test_error_message_shows_contract_alias :: TestTree +test_error_message_shows_contract_alias = + testScenarioOnEmulator "Error message shows contract alias" $ scenario do + ch <- originate "my-contract-alias" () $ L.defaultContract @() @() $ L.car # L.failWith + shouldFailWithMessage "(my-contract-alias) failed with: Unit" do + transfer ch 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 @@ -21,13 +21,13 @@ import Morley.Micheline (toExpression) import Morley.Michelson.Runtime.GState (genesisAddress1) -import Morley.Tezos.Address (parseAddress) +import Morley.Tezos.Address (ConstrainedAddress(..), ta) import Morley.Tezos.Core (parseChainId) import Morley.Util.Interpolate (i) import Test.Cleveland import Test.Cleveland.Internal.Abstract - (ExpressionOrTypedValue(..), FailedInBranch(..), GenericTestError(..), TransferFailure(..), - TransferFailureReason(..)) + (AddressAndAlias(..), ExpressionOrTypedValue(..), FailedInBranch(..), GenericTestError(..), + TransferFailure(..), TransferFailureReason(..)) import Test.Cleveland.Internal.Actions (TransferFailurePredicate(..)) import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) import Test.Cleveland.Internal.Pure (emptyScenarioBranch) @@ -38,93 +38,81 @@ test_CatchExceptions = testScenario "catches exceptions" $ scenario do validAddr <- newAddress auto - contractAddr <- originate OriginateData - { odName = "test catchTransferFailure" - , odStorage = () - , odBalance = 1 - , odContract = defaultContract testContractCode - } + contractAddr <- originate + "test catchTransferFailure" + () + (defaultContract testContractCode) + [tz|1u|] let (testContractWithNumericErrors, errorTagMap) = useNumericErrors testContractCode - contractNumericAddr <- originate OriginateData - { odName = "test catchTransferFailure numeric errors" - , odStorage = () - , odBalance = 1 - , odContract = defaultContract testContractWithNumericErrors - } + contractNumericAddr <- originate + "test catchTransferFailure numeric errors" + () + (defaultContract testContractWithNumericErrors) + [tz|1u|] - attempt (call contractAddr (Call @"TriggerFailWith") ()) >>= \case + attempt (transfer contractAddr $ calling (ep @"TriggerFailWith") ()) >>= \case Left err -> checkTransferFailure err $ failedWith (constant [mt|oops|]) Right _ -> failure "Expected contract to fail" catchTransferFailure $ - call contractAddr (Call @"TriggerFailWith") () + transfer contractAddr $ calling (ep @"TriggerFailWith") () expectTransferFailure (failedWith (constant [mt|oops|])) $ - call contractAddr (Call @"TriggerFailWith") () + transfer contractAddr $ calling (ep @"TriggerFailWith") () expectTransferFailure (failedWith (constant [mt|oops|]) && addressIs contractAddr) $ - call contractAddr (Call @"TriggerFailWith") () + transfer contractAddr $ calling (ep @"TriggerFailWith") () expectFailedWith [mt|oops|] $ - call contractAddr (Call @"TriggerFailWith") () + transfer contractAddr $ calling (ep @"TriggerFailWith") () expectError (VoidResult False) $ - call contractAddr (Call @"VoidEP") (mkVoid True) + transfer contractAddr $ calling (ep @"VoidEP") (mkVoid True) expectTransferFailure (failedWith $ constant (1 :: Natural, (2 :: Natural, 3 :: Natural))) $ - call contractAddr (Call @"TriggerFailWithRightCombedPair") () + transfer contractAddr $ calling (ep @"TriggerFailWithRightCombedPair") () -- Check that string and bytes forms of 'chain_id' are equal if they are -- used as error argument. let c = fromRight (error "impossible") $ parseChainId "NetXUdfLh6Gm88t" expectTransferFailure (failedWith (constant @ChainId c)) $ - call contractAddr (Call @"TriggerFailWithChainIdStr") () + transfer contractAddr $ calling (ep @"TriggerFailWithChainIdStr") () expectTransferFailure (failedWith (constant @ChainId c)) $ - call contractAddr (Call @"TriggerFailWithChainIdBytes") () + transfer contractAddr $ calling (ep @"TriggerFailWithChainIdBytes") () expectCustomError #customError 1 $ - call contractAddr (Call @"TriggerFailWithCustomError") () + transfer contractAddr $ calling (ep @"TriggerFailWithCustomError") () expectCustomError_ #customErrorUnit1 $ - call contractAddr (Call @"TriggerFailWithCustomErrorUnit1") () + transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit1") () expectCustomError_ #customErrorUnit2 $ - call contractAddr (Call @"TriggerFailWithCustomErrorUnit2") () + transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit2") () expectCustomErrorNoArg #customErrorNoArg $ - call contractAddr (Call @"TriggerFailWithCustomErrorNoArg") () + transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") () expectNumericError errorTagMap (VoidResult False) $ - call contractNumericAddr (Call @"VoidEP") (mkVoid True) + transfer contractNumericAddr $ calling (ep @"VoidEP") $ mkVoid True expectTransferFailure shiftOverflow $ - call contractAddr (Call @"TriggerShiftOverflow") () + transfer contractAddr $ calling (ep @"TriggerShiftOverflow") () expectTransferFailure gasExhaustion $ - call contractAddr (Call @"TriggerGasExhaustion") () + transfer contractAddr $ calling (ep @"TriggerGasExhaustion") () expectTransferFailure emptyTransaction $ - transferMoney validAddr 0 + transfer validAddr [tz|0u|] expectTransferFailure badParameter $ - transfer TransferData - { tdTo = contractAddr - , tdAmount = 0 - , tdEntrypoint = ep "expectAddress" - , tdParameter = [mt|aa|] - } + transfer contractAddr $ unsafeCalling #expectAddress [mt|aa|] expectTransferFailure badParameter $ - transfer TransferData - { tdTo = contractAddr - , tdAmount = 0 - , tdEntrypoint = ep "expectAddress" - , tdParameter = (1 :: Natural) - } + transfer contractAddr $ unsafeCalling #expectAddress @Natural 1 -- check that an action throws one of many errors. let expectedErrs = @@ -132,7 +120,7 @@ failedWith (constant @MText "oops") || failedWith (customError #customError 1) - call contractAddr (Call @"TriggerFailWithCustomError") () & + transfer contractAddr (calling (ep @"TriggerFailWithCustomError") ()) & expectTransferFailure expectedErrs test_FailsIfTheGivenActionDoesNotThrow :: TestTree @@ -150,7 +138,7 @@ FailedInBranch emptyScenarioBranch $ SomeException $ WithCallStack callStack $ SomeException $ FailedInBranch emptyScenarioBranch $ SomeException $ - TransferFailure (unsafe $ parseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC") BadParameter + TransferFailure (AddressAndAlias (MkAddress [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|]) Nothing) BadParameter res <- attempt @TransferFailure action @@ -314,12 +302,12 @@ impl_test_AndPredicate_succeeds_if_all_conditions_hold conv = testScenario "AndPredicate succeeds if all conditions hold" $ scenario do - let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing + let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing checkTransferFailure err $ failedWith (constant @Integer 1) && addressIs genesisAddress1 impl_test_OrPredicate_succeeds_if_any_condition_holds conv = testScenario "AndPredicate succeeds if any condition holds" $ scenario do - let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing + let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing checkTransferFailure err $ failedWith (constant @Integer 1) || failedWith (constant @Integer 2) || @@ -327,7 +315,7 @@ impl_test_AndPredicate_fails_if_any_condition_fails conv = testScenario "AndPredicate succeeds if all conditions hold" $ scenario do - let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing + let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing checkTransferFailure err ( failedWith (constant @Integer 1) && @@ -349,7 +337,7 @@ impl_test_OrPredicate_fails_if_all_conditions_fail conv = testScenario "AndPredicate succeeds if all conditions hold" $ scenario do - let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing + let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing checkTransferFailure err ( failedWith (constant @Integer 2) || @@ -373,7 +361,7 @@ impl_test_checkTransferFailure_shows_only_failing_predicates conv = testScenario "checkTransferFailure shows only failing predicates" $ scenario do - let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing + let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing checkTransferFailure err ( (failedWith (constant @Integer 1) && failedWith (constant @Integer 2)) && diff --git a/test/TestSuite/Cleveland/FailureLogs.hs b/test/TestSuite/Cleveland/FailureLogs.hs --- a/test/TestSuite/Cleveland/FailureLogs.hs +++ b/test/TestSuite/Cleveland/FailureLogs.hs @@ -15,19 +15,19 @@ test_FailureLogs :: TestTree test_FailureLogs = testScenarioOnEmulator "Can get logs even on scenario failure" $ scenarioEmulated do - contractAddr <- originateSimple "test catchTransferFailure" () testContract + contractAddr <- originate "test catchTransferFailure" () testContract (logs1, result1) <- fmap (first collectLogs) . getMorleyLogs $ try @_ @SomeException do - call contractAddr L.CallDefault 0 - call contractAddr L.CallDefault 1 + transfer contractAddr $ calling def 0 + transfer contractAddr $ calling def 1 failure "some failure" assert (isLeft result1) "result1 should be Left" unMorleyLogs logs1 @== ["One", "Two", "Three", "Four", "One", "Two"] (logs2, result2) <- fmap (first collectLogs) . getMorleyLogs $ try @_ @SomeException do - call contractAddr L.CallDefault 0 + transfer contractAddr $ calling def 0 failure "some failure" - call contractAddr L.CallDefault 1 + transfer contractAddr $ calling def 1 assert (isLeft result2) "result2 should be Left" unMorleyLogs logs2 @== ["One", "Two", "Three", "Four"] diff --git a/test/TestSuite/Cleveland/Import.hs b/test/TestSuite/Cleveland/Import.hs --- a/test/TestSuite/Cleveland/Import.hs +++ b/test/TestSuite/Cleveland/Import.hs @@ -15,7 +15,7 @@ import Test.Tasty (TestTree) -import Lorentz.Value (Address, Mutez) +import Lorentz.Value (Address) import Morley.Tezos.Address (ta) import Test.Cleveland import Test.Cleveland.Lorentz (embedContract, embedValue, importValue) @@ -23,19 +23,19 @@ test_Import :: [TestTree] test_Import = [ testScenario "Can embed a contract" $ scenario do - contract <- originateSimple "basic1" [] + contract <- originate "basic1" [] $$(embedContract @() @[Integer] @() "../../contracts/basic1.tz") - call contract CallDefault () + transfer contract ] test_Embed :: [TestTree] test_Embed = [ testScenario "Can embed a contract" $ scenario do contractCode <- importContract @() @[Integer] @() "../../contracts/basic1.tz" - contract <- originateSimple "basic1" [] contractCode + contract <- originate "basic1" [] contractCode - call contract CallDefault () + transfer contract ] test_ImportInt :: [TestTree] @@ -59,7 +59,7 @@ [ testScenarioOnEmulator "Can import an address value" $ scenario do value <- runIO $ importValue @Address "./test/fixtures/addrValue.txt" - value @== [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|] + value @== toAddress [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|] ] test_EmbedAddress :: [TestTree] @@ -67,7 +67,7 @@ [ testScenarioOnEmulator "Can embed an address value" $ scenario do let value = $$(embedValue @Address "./test/fixtures/addrValue.txt") - value @== [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|] + value @== toAddress [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|] ] test_ImportMutez :: [TestTree] diff --git a/test/TestSuite/Cleveland/NetworkCaps.hs b/test/TestSuite/Cleveland/NetworkCaps.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/NetworkCaps.hs @@ -0,0 +1,18 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module TestSuite.Cleveland.NetworkCaps + ( test_network_caps + ) where + +import Test.Tasty (TestTree) + +import Morley.Client qualified as Client +import Test.Cleveland + +test_network_caps :: TestTree +test_network_caps = testScenarioOnNetwork "Network scenario can get NetworkEnv" $ scenarioNetwork do + env <- getMorleyClientEnv + chainID <- getChainId + chainID' <- runIO $ Client.runMorleyClientM env Client.getChainId + chainID @== chainID' diff --git a/test/TestSuite/Cleveland/NewAddressCheck.hs b/test/TestSuite/Cleveland/NewAddressCheck.hs --- a/test/TestSuite/Cleveland/NewAddressCheck.hs +++ b/test/TestSuite/Cleveland/NewAddressCheck.hs @@ -36,7 +36,7 @@ (toRemain, _) = balance `divModMutezInt` (5 :: Int) ?: error "Bad div" toSpend = balance - toRemain - transferMoney test2 toSpend + transfer test2 toSpend & withSender test balance2 <- getBalance test diff --git a/test/TestSuite/Cleveland/OperationReplay.hs b/test/TestSuite/Cleveland/OperationReplay.hs --- a/test/TestSuite/Cleveland/OperationReplay.hs +++ b/test/TestSuite/Cleveland/OperationReplay.hs @@ -16,16 +16,16 @@ test_replayTransfer_fails :: TestTree test_replayTransfer_fails = testScenarioOnEmulator "Transfer operation replay is prohibited" $ scenarioEmulated do - dummyAddress <- chAddress <$> originateSimple @() @() "dummy" () idContract + dummyAddress <- toAddress . chAddress <$> originate "dummy" () (idContract @() @()) contract <- importContract @Address @() @() (contractsDir "replay_transfer.tz") - replayTransfer <- originateSimple "replayTransfer" () contract - call replayTransfer CallDefault dummyAddress + replayTransfer <- originate "replayTransfer" () contract + transfer replayTransfer (calling def dummyAddress) & shouldFailWithMessage "Operation replay attempt" test_replayOrigination_fails :: TestTree test_replayOrigination_fails = testScenarioOnEmulator "Origination operation replay is prohibited" $ scenarioEmulated do contract <- importContract @() @() @() (contractsDir "replay_origination.tz") - replayOrigination <- originateSimple "replayOrigination" () contract - call replayOrigination CallDefault () + replayOrigination <- originate "replayOrigination" () contract + transfer replayOrigination & shouldFailWithMessage "Operation replay attempt" 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 @@ -16,10 +16,10 @@ test_PrettyFailWith :: TestTree test_PrettyFailWith = testScenarioOnEmulator "FailWith shows its argument using human-readable representation" $ scenarioEmulated do addr <- newFreshAddress auto - transferMoney addr 1 -- need at least some money to call + transfer addr [tz|1u|] -- need at least some money to call withSender addr do - cont <- originateSimple "failing" () failing - call cont CallDefault () & + cont <- originate "failing" () failing + transfer cont & shouldFailWithMessage (fmt $ "failed with: \"" +| addr |+ "\"") failing :: Contract () () () 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,6 +14,7 @@ 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(..)) @@ -33,16 +34,13 @@ testProperty "The address is calculated correctly from the given public key" $ withTests 200 $ property $ do alias <- fromString <$> (forAll $ Gen.string (Range.linear 0 100) Gen.unicode) - testScenarioProps $ scenario $ scenario' alias - -scenario' :: (MonadCleveland caps m) => Alias -> m () -scenario' alias = do - c <- originateSimple @PublicKey @(Maybe Address) "publicKeyToAddress" Nothing publicKeyToAddress + testScenarioProps $ scenario do + c <- originate "publicKeyToAddress" Nothing publicKeyToAddress - addr1 <- newAddress $ SpecificAlias alias - addr1pk <- getPublicKey addr1 + addr1 <- newAddress $ SpecificAlias alias + addr1pk <- getPublicKey addr1 - call c CallDefault addr1pk - addr2 <- Unsafe.fromJust <$> getStorage @(Maybe Address) c + transfer c $ calling def addr1pk + addr2 <- Unsafe.fromJust <$> getStorage @(Maybe Address) c - addr1 @== addr2 + MkAddress 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 @@ -27,7 +27,7 @@ balanceSender <- getBalance refillableAddr withSender refillableAddr do - transferMoney receiver (balanceSender + 1000) -- obviously more than sender has + transfer receiver (balanceSender + 1000) -- obviously more than sender has getBalance receiver @@== (balanceSender + 1000) , testScenario "A refillable address refills when transfer amount == balance - 1 μtz" $ scenario do @@ -37,7 +37,7 @@ balanceSender <- getBalance refillableAddr withSender refillableAddr do - transferMoney receiver (balanceSender - 1) -- also would fail without auto-refill, due to fees + transfer receiver (balanceSender - 1) -- also would fail without auto-refill, due to fees -- NOTE: the test crashes currently when transfer amount = balance; it seems like a -- bug in the local chain code. Theoretically, this test should work either way. @@ -48,12 +48,7 @@ -- storage burn should be at least >= 1 XTZ due to the contract size -- however, since 'refillableAddr' has at least 0.5 XTZ after 'refillable' -- we also transfer 0.5 XTZ to the contract; this ensures we're overbudget. - void $ withSender refillableAddr $ originate $ OriginateData - { odName = "so_big" - , odBalance = 0.5e6 - , odContract = soBigContract - , odStorage = () - } + void $ withSender refillableAddr $ originate "so_big" () soBigContract [tz|0.5|] ] test_AddressDoesntRefill :: [TestTree] @@ -72,17 +67,17 @@ nonRefillable ::< receiver ::< Nil' <- traverse newFreshAddress $ SL.replicateT auto -- needed to reveal `nonRefillable` - transferMoney nonRefillable 1 + transfer nonRefillable [tz|1u|] shouldFailWithMessage errorMsg $ - withSender nonRefillable $ transferMoney receiver 100 + withSender nonRefillable $ transfer receiver [tz|100u|] test_RefillFailure :: TestTree test_RefillFailure = testScenario "Refill should succeed even if moneybag can't make the call" $ scenario do owner <- refillable $ newFreshAddress "owner" - transferMoney owner 400 -- a little more than revelation fee to avoid empty_implicit_contract - contract <- originateSimple @() @L.Address @() "contract" owner $ L.defaultContract $ + transfer owner [tz|400u|] -- a little more than revelation fee to avoid empty_implicit_contract + contract <- originate "contract" (L.toAddress owner) $ L.defaultContract @() @L.Address $ L.cdr L.# L.dup L.# L.sender @@ -90,7 +85,7 @@ (L.nil L.# L.pair) (L.push @L.MText "Sender is not owner" L.# L.failWith) balance1 <- getBalance owner - withSender owner $ call contract CallDefault () + withSender owner $ transfer contract balance2 <- getBalance owner -- check that owner was in fact refilled checkCompares balance1 (<=) balance2 diff --git a/test/TestSuite/Cleveland/ResolveAddress.hs b/test/TestSuite/Cleveland/ResolveAddress.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/ResolveAddress.hs @@ -0,0 +1,28 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +module TestSuite.Cleveland.ResolveAddress + ( test_resolves_address_of_contract + , test_resolves_address_of_implicit_account + ) where + +import Test.Tasty (TestTree) + +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 +test_resolves_address_of_contract = + testScenario "Resolves address of contract" $ scenario do + let alias = "contract-test-1" + expectedAddress <- toContractAddress <$> originate alias () (idContract @() @()) + resolveAddress alias @@== expectedAddress + +test_resolves_address_of_implicit_account :: TestTree +test_resolves_address_of_implicit_account = + testScenario "Resolves address of implicit account" $ scenario do + let alias = "contract-test-1" + expectedAddress <- newAddress $ SpecificAlias alias + resolveAddress alias @@== 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 @@ -4,12 +4,13 @@ -- Disable the warning generated by the `L.source` instruction. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE OverloadedLists #-} + module TestSuite.Cleveland.RunCode ( test_runs_code , test_emulator_state_is_not_modified , test_other_operations_are_not_executed - , test_handles_bigmap - , test_handles_bigmap_ids + , test_handles_mix_of_bigmaps_and_bigmap_ids , test_env_vars_can_be_observed , test_can_observe_existing_onchain_contracts_and_accounts , test_self_address_does_not_exist_onchain @@ -23,7 +24,10 @@ import Lorentz qualified as L import Lorentz.Base import Lorentz.Value -import Morley.Michelson.Runtime.GState (gsAddressesL) +import Morley.Michelson.Runtime.GState (gsContractAddressesL) +import Morley.Michelson.Typed (untypeValue) +import Morley.Michelson.Untyped (Elt(..), Value'(..)) +import Morley.Tezos.Address import Morley.Tezos.Core (Timestamp(..)) import Test.Cleveland import Test.Cleveland.Internal.Pure (psGState) @@ -34,8 +38,8 @@ testScenario "runs the given contract's code" $ scenario do runCode RunCode { rcContract = increment - , rcStorage = NotRPC 5 - , rcParameter = NotRPC 3 + , rcStorage = untypeValue $ toVal @Integer 5 + , rcParameter = untypeValue $ toVal @Integer 3 , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing @@ -55,8 +59,8 @@ before <- get runCode RunCode { rcContract = transferToSender - , rcStorage = NotRPC () - , rcParameter = NotRPC () + , rcStorage = untypeValue $ toVal () + , rcParameter = untypeValue $ toVal () , rcAmount = 900 , rcBalance = 900 , rcSource = Nothing @@ -88,8 +92,8 @@ -- then the counter should only be increased to 1 and then stop. runCode RunCode { rcContract = unboundRecursion - , rcStorage = NotRPC 0 - , rcParameter = NotRPC () + , rcStorage = untypeValue $ toVal @Integer 0 + , rcParameter = untypeValue $ toVal () , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing @@ -97,7 +101,7 @@ , rcLevel = Nothing } @@== 1 where - -- | A contract that calls itself forever, increment the counter in its storage by 1 on every call. + -- A contract that calls itself forever, increment the counter in its storage by 1 on every call. unboundRecursion :: Contract () Integer () unboundRecursion = L.defaultContract $ L.cdr @@ -109,36 +113,30 @@ # L.dip L.nil # L.cons # L.pair -test_handles_bigmap :: TestTree -test_handles_bigmap = - testScenario "handles bigmaps in parameter/storage" $ scenario do - (total, bigMapId) <- runCode RunCode - { rcContract = lookupBigMapKey - , rcStorage = NotRPC ((0, 0), one ("key", 50)) - , rcParameter = NotRPC ("key", one ("key", 20)) - , rcAmount = 0 - , rcBalance = 0 - , rcSource = Nothing - , rcNow = Nothing - , rcLevel = Nothing - } - - total @== (50, 20) - -- Check that the bigmap was not actually created on-chain. - getBigMapValueMaybe bigMapId "key" @@== Nothing - -test_handles_bigmap_ids :: TestTree -test_handles_bigmap_ids = - testScenario "handles bigmap IDs in parameter/storage" $ scenario do +test_handles_mix_of_bigmaps_and_bigmap_ids :: TestTree +test_handles_mix_of_bigmaps_and_bigmap_ids = + testScenario "handles a mix of bigmaps and bigmap IDs in parameter/storage" $ scenario do -- Originate a contract with a big_map in its storage -- in order to actually create a valid on-chain bigmap ID. - handle <- originateSimple @() @(BigMap MText Integer) @() "bigmap" (one ("key", 30)) idContract + handle <- originate "bigmap" (one ("key", 20)) $ idContract @() @(BigMap MText Integer) bigMapId <- getStorage handle - (total, _) <- runCode RunCode + (_, results) <- runCode RunCode { rcContract = lookupBigMapKey - , rcStorage = IsRPC ((0, 0), bigMapId) - , rcParameter = IsRPC ("key", bigMapId) + , rcParameter = + -- a list with a big_map ID and a big_map value + ValueSeq + [ untypeValue $ toVal bigMapId + , ValueMap [Elt (ValueString "key") (ValueInt 30)] + ] + , rcStorage = + ValuePair + (ValueSeq + [ untypeValue $ toVal bigMapId + , ValueMap [Elt (ValueString "key") (ValueInt 40)] + ] + ) + (ValueNil) , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing @@ -146,7 +144,7 @@ , rcLevel = Nothing } - total @== (30, 30) + results @== [40, 20, 30, 20] test_env_vars_can_be_observed :: TestTree test_env_vars_can_be_observed = @@ -156,8 +154,8 @@ envVars <- withSender sender $ runCode RunCode { rcContract = readEnvVars - , rcStorage = NotRPC Nothing - , rcParameter = NotRPC () + , rcStorage = untypeValue $ toVal $ Nothing @EnvVars + , rcParameter = untypeValue $ toVal () , rcAmount = 456 , rcBalance = 123 , rcSource = Just source @@ -168,8 +166,8 @@ envLevel envVars @== 29 envNow envVars @== Timestamp 8 getChainId @@== envChainId envVars - envSender envVars @== sender - envSource envVars @== source + envSender envVars @== toAddress sender + envSource envVars @== toAddress source envAmount envVars @== 456 envBalance envVars @== 123 where @@ -204,13 +202,7 @@ test_can_observe_existing_onchain_contracts_and_accounts :: TestTree test_can_observe_existing_onchain_contracts_and_accounts = testScenario "existing onchain contracts/acounts can be observed" $ scenario do - contractAddress <- toAddress <$> originate OriginateData - { odName = "contract" - , odBalance = 123 - , odStorage = () - , odContract = idContract @Integer @() - } - + contractAddress <- toAddress <$> originate "contract" () (idContract @Integer @()) [tz|123u|] let checkContractExists :: Contract () (Maybe Address) () checkContractExists = L.defaultContract $ @@ -224,8 +216,8 @@ runCode RunCode { rcContract = checkContractExists - , rcStorage = IsRPC Nothing - , rcParameter = IsRPC () + , rcStorage = untypeValue $ toVal $ Nothing @Address + , rcParameter = untypeValue $ toVal () , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing @@ -249,10 +241,10 @@ # L.assertSome @MText "Expected to find a contract with parameter `Integer`." # L.address # L.some # L.nil # L.pair - selfAddr <- runCode RunCode + MkAddress selfAddr@ContractAddress{} <- runCode RunCode { rcContract = returnSelf - , rcStorage = IsRPC Nothing - , rcParameter = IsRPC 0 + , rcStorage = untypeValue $ toVal $ Nothing @Address + , rcParameter = untypeValue $ toVal @Integer 0 , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing @@ -260,41 +252,51 @@ , rcLevel = Nothing } >>= evalJust "Expected contract to return a `Some`" - emulatorState ^. gsAddressesL . at selfAddr @== Nothing + emulatorState ^. gsContractAddressesL . at selfAddr @== Nothing ---------------------------------------------------------------------------- -- Helpers ---------------------------------------------------------------------------- --- | Looks up an integer in: --- --- * The big_map given in the parameter --- * The big_map in the storage +-- | This contracts has a list of big_maps in its storage, and takes an additional +-- list of big_maps in its parameter. -- --- ... and stores both results in the storage. -lookupBigMapKey :: Contract (MText, BigMap MText Integer) ((Integer, Integer), BigMap MText Integer) () +-- When called, it looks up the key "key" in all big_maps, and stores +-- all results in a @[Integer]@ in the storage. +lookupBigMapKey + :: Contract [BigMap MText Integer] + ([BigMap MText Integer], [Integer]) + () lookupBigMapKey = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $ + -- Unpair everything L.unpair - # L.dip L.cdr - # L.unpair - # L.stackType @'[MText, BigMap MText Integer, BigMap MText Integer] - - # L.dup - # L.dip L.swap - # L.stackType @'[MText, BigMap MText Integer, MText, BigMap MText Integer] + # L.dip L.unpair + # L.stackType @'[[BigMap MText Integer], [BigMap MText Integer], [Integer]] - -- Make a copy of the bigmap in the storage - # L.dupN @4 - # L.dug @4 - # L.stackType @'[MText, BigMap MText Integer, MText, BigMap MText Integer, BigMap MText Integer] + -- Discard the `[Integer]` in the storage + # L.dipN @2 L.drop + # L.stackType @'[[BigMap MText Integer], [BigMap MText Integer]] - -- Retrieve keys - # L.get - # L.assertSome @MText "Expected Some, found None." - # L.dug @2 - # L.get - # L.assertSome @MText "Expected Some, found None." + -- Get the value at key "key" from all big_maps + # L.nil @Integer + # L.swap + # getValues + # L.stackType @'[[Integer], [BigMap MText Integer]] + # L.swap + # getValues + # L.stackType @'[[Integer]] - # L.pair + # L.nil # L.pair # L.nil @Operation # L.pair + where + -- Get the value at key "key" from all big_maps + getValues :: [BigMap MText Integer] ': [Integer] ': s :-> [Integer] ': s + getValues = + L.iter + ( + L.push @MText "key" + # L.get + # L.assertSome @MText "Expected Some, found None." + # L.cons + ) 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 (embedContract) +import Test.Cleveland.Lorentz (ToContractAddress, embedContract) import TestSuite.Util (BigMapInStorage(..), idContract, saveInStorageContract) import TestSuite.Util.Contracts (contractsDir) @@ -39,7 +39,7 @@ test_GetStorage :: TestTree test_GetStorage = testScenario "getStorage returns the contract's storage" $ scenario do - addr <- originateSimple + addr <- originate "save parameter in storage" (1 :: Natural) saveInStorageContract @@ -47,12 +47,7 @@ comment "checking initial storage" getStorage addr @@== 1 - transfer TransferData - { tdTo = addr - , tdAmount = 100 - , tdEntrypoint = DefEpName - , tdParameter = 2 :: Natural - } + transfer addr [tz|100u|] $ calling def 2 comment "storage is updated after transfer" getStorage addr @@== 2 @@ -68,7 +63,7 @@ , (2, "b") ] } - addr <- originateSimple @() @Storage "test" initialStorage idContract + addr <- originate "test" initialStorage $ idContract @() @Storage getFullStorage addr @@== initialStorage test_GetFullStorageConditional :: TestTree @@ -82,14 +77,14 @@ , (2, "b") ] } - addr <- originateSimple @() @Storage "test" initialStorage idContract + addr <- originate "test" initialStorage $ idContract @() @Storage ifEmulation (getFullStorage addr @@== initialStorage) (_stField1RPC <$> getStorage addr @@== 23) test_GetSomeStorage :: TestTree test_GetSomeStorage = testScenario "getSomeStorage is consistent with getStorage" $ scenario do - addr <- originateSimple @() @Storage "test" (Storage 1 [(2, "a")]) idContract + addr <- originate "test" (Storage 1 [(2, "a")]) $ idContract @() @Storage storage <- getStorage addr someStorage <- getSomeStorage addr @@ -100,25 +95,27 @@ [ testScenario "importUntypedContract" $ scenario do contract <- importUntypedContract $ contractsDir "big_map_in_storage.tz" let initialStorage = (one (101, 102), 103) :: (BigMap Integer Integer, Natural) - addr <- originateUntypedSimple "contract" (T.untypeValue $ T.toVal initialStorage) contract + addr <- originate "contract" (T.untypeValue $ T.toVal initialStorage) contract checkAnnotationsArePreserved addr , testScenario "importContract" $ scenario do contract <- importContract @Integer @(BigMap Integer Integer, Natural) @() $ contractsDir "big_map_in_storage.tz" let initialStorage = (one (101, 102), 103) - originateSimple "contract" initialStorage contract >>= checkAnnotationsArePreserved + originate "contract" initialStorage contract >>= checkAnnotationsArePreserved , testScenario "importContract with a user-defined storage" $ scenario do contract <- importContract @Integer @BigMapInStorage @() $ contractsDir "big_map_in_storage.tz" let initialStorage = BigMapInStorage (one (101, 102)) 103 - addr <- originateSimple "contract" initialStorage contract + addr <- originate "contract" initialStorage contract checkAnnotationsArePreserved addr , testScenario "embedContract" $ scenario do let contract = $$(embedContract @Integer @BigMapInStorage @() $ contractsDir "big_map_in_storage.tz") let initialStorage = BigMapInStorage (one (101, 102)) 103 - addr <- originateSimple "contract" initialStorage contract + addr <- originate "contract" initialStorage contract checkAnnotationsArePreserved addr ] where - checkAnnotationsArePreserved :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m () + checkAnnotationsArePreserved + :: (HasCallStack, MonadCleveland caps m, ToContractAddress addr) + => addr -> m () checkAnnotationsArePreserved addr = do storage <- getSomeStorage addr storage ^? field "field2" . castTo @Natural . value @== Just 103 diff --git a/test/TestSuite/Cleveland/StorageWithBigMaps.hs b/test/TestSuite/Cleveland/StorageWithBigMaps.hs --- a/test/TestSuite/Cleveland/StorageWithBigMaps.hs +++ b/test/TestSuite/Cleveland/StorageWithBigMaps.hs @@ -106,9 +106,9 @@ test_EMPTY_BIG_MAP = testScenario "EMPTY_BIG_MAP always creates a new ID" $ scenario do forM_ contracts \c -> do - addr <- originateSimple "contract" [("a", 1)] c + addr <- originate "contract" [("a", 1)] c id0 <- getStorage addr - call addr CallDefault () + transfer addr unBigMapId <$> getStorage addr @@/= unBigMapId id0 where contracts :: [Contract () (BigMap MText Integer) ()] @@ -133,9 +133,9 @@ test_UPDATE :: TestTree test_UPDATE = testScenario "UPDATE never creates a new ID" $ scenario do - addr <- originateSimple "contract" [("12", 12)] updateBigMap + addr <- originate "contract" [("12", 12)] updateBigMap id0 <- getStorage addr - call addr CallDefault () + transfer addr unBigMapId <$> getStorage addr @@== unBigMapId id0 where updateBigMap :: Contract () (BigMap MText Integer) () @@ -163,10 +163,10 @@ -- This test is here as a means of documentation. testGroup "DUP" [ testScenario "BigMap ID may be reused when old BigMap is discarded" $ scenario do - addr <- originateSimple "contract" [("a", 1)] dupAndDiscardOld + addr <- originate "contract" [("a", 1)] dupAndDiscardOld originalId <- getStorage addr - call addr CallDefault () + transfer addr dupId <- getStorage addr ifEmulation @() @@ -176,10 +176,10 @@ (do unBigMapId dupId @== unBigMapId originalId) , testScenario "A new BigMap ID is generated when the old BigMap is not discarded" $ scenario do - addr <- originateSimple "contract" ([("a", 1)], [("a", 1)]) dupAndKeepBoth + addr <- originate "contract" ([("a", 1)], [("a", 1)]) dupAndKeepBoth (id0, _) <- getStorage addr - call addr CallDefault () + transfer addr (id1, dupId) <- getStorage addr -- The original bigmap's ID did not change @@ -224,9 +224,9 @@ -- Originate the contract. -- Call the contract twice, to make sure the BigMapCounter is incremented -- inbetween operations. - addr <- originateSimple "create-big-maps" bigMaps createBigMaps - call addr CallDefault bigMaps - call addr CallDefault bigMaps + addr <- originate "create-big-maps" bigMaps createBigMaps + transfer addr $ calling def bigMaps + transfer addr $ calling def bigMaps finalStorage <- getStorage addr let bigMapIds = finalStorage ^.. biplate @_ @(BigMapId Natural Natural) . to unBigMapId @@ -247,14 +247,14 @@ test_GetBigMapValue :: TestTree test_GetBigMapValue = testScenario "getBigMapValue retrieves the correct value" $ scenario do - contract1 <- originateSimple @() @(BigMap Integer MText, BigMap Integer MText) + contract1 <- originate "contract1" ([(1, "a"), (2, "b")], [(1, "c"), (2, "d")]) - idContract - contract2 <- originateSimple @() @(BigMap Integer MText, BigMap Integer MText) + $ idContract @() @(BigMap Integer MText, BigMap Integer MText) + contract2 <- originate "contract1" ([(1, "e"), (2, "f")], [(1, "g"), (2, "h")]) - idContract + $ idContract @() @(BigMap Integer MText, BigMap Integer MText) (bigMap1, bigMap2) <- getStorage contract1 (bigMap3, bigMap4) <- getStorage contract2 @@ -274,7 +274,7 @@ let bmList = sampleList ++ [(5, "d")] expectedSize = Unsafe.fromIntegral @Int @Natural $ length bmList - c <- originateSimple @() @(BigMap Integer MText) "contract" (mkBigMap bmList) idContract + c <- originate "contract" (mkBigMap bmList) $ idContract @() @(BigMap Integer MText) bigMapId <- getStorage c bmSize <- getBigMapSize bigMapId @@ -285,7 +285,7 @@ test_getAllBigMapValues = testScenario "getAllBigMapValues retrieves the correct values" $ scenario do let bmValues = snd <$> sampleList - c <- originateSimple @() @(BigMap Integer MText) "contract" (mkBigMap sampleList) idContract + c <- originate "contract" (mkBigMap sampleList) $ idContract @() @(BigMap Integer MText) bigMapId <- getStorage c vs <- getAllBigMapValues bigMapId @@ -295,10 +295,10 @@ test_getAllBigMapValues_ConsistentWith_getBigMapValue :: TestTree test_getAllBigMapValues_ConsistentWith_getBigMapValue = testScenario "results of 'getAllBigMapValues' and 'getBigMapValue' are consistent" $ scenario do - c <- originateSimple @() @(BigMap Integer MText) + c <- originate "contract" (mkBigMap sampleList) - idContract + $ idContract @() @(BigMap Integer MText) bigMapId <- getStorage c @@ -317,10 +317,10 @@ test_GetBigMapValueMaybe_InvalidKey :: TestTree test_GetBigMapValueMaybe_InvalidKey = testScenario "getBigMapValueMaybe returns 'Nothing' when key is invalid" $ scenario do - addr <- originateSimple @() @(BigMap Integer MText, BigMap Integer MText) + addr <- originate "contract1" ([(1, "a"), (2, "b")], [(2, "c"), (3, "d")]) - idContract + $ idContract @() @(BigMap Integer MText, BigMap Integer MText) (bigMap1, bigMap2) <- getStorage addr @@ -330,16 +330,16 @@ test_ID_BecomesInvalid :: TestTree test_ID_BecomesInvalid = testScenario "big_map IDs become invalid once the big_map is removed from the storage" $ scenario do - addr <- originateSimple @(BigMap Integer MText) + addr <- originate "contract1" [(1, "a")] - saveInStorageContract + $ saveInStorageContract @(BigMap Integer MText) bigMapId <- getStorage addr getBigMapValueMaybe bigMapId 1 @@== Just "a" -- Replace the big_map in the contract's storage with a new big_map (with same contents). - call addr CallDefault [(1, "a")] + transfer addr $ calling def [(1, "a")] -- The old big_map ID should now be invalid. getBigMapValueMaybe bigMapId 1 @@== Nothing diff --git a/test/TestSuite/Cleveland/Tasty/Report.hs b/test/TestSuite/Cleveland/Tasty/Report.hs --- a/test/TestSuite/Cleveland/Tasty/Report.hs +++ b/test/TestSuite/Cleveland/Tasty/Report.hs @@ -29,8 +29,8 @@ fmap checkResultDescription reportExamples checkResultDescription :: (TestName, EmulatedT PureM (), Text) -> TestTree -checkResultDescription (testName, scenario', expectedErr) = - runViaTastyOnEmulator testName (singleOption (ContextLinesOpt 1)) scenario' \tastyResult -> do +checkResultDescription (testName, scenario_, expectedErr) = + runViaTastyOnEmulator testName (singleOption (ContextLinesOpt 1)) scenario_ \tastyResult -> do let -- Some error lines might have trailing whitespace, we can ignore it here. strippedErr = 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 :: Address -unknownAddr = unsafe $ parseAddress "tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z" +unknownAddr :: ImplicitAddress +unknownAddr = [ta|tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z|] reportExamples :: [(String, EmulatedT PureM (), Text)] reportExamples = diff --git a/test/TestSuite/Cleveland/TransferCheck.hs b/test/TestSuite/Cleveland/TransferCheck.hs --- a/test/TestSuite/Cleveland/TransferCheck.hs +++ b/test/TestSuite/Cleveland/TransferCheck.hs @@ -17,61 +17,18 @@ test_TransferFromContract :: TestTree test_TransferFromContract = testGroup "Transfers from contract" - [ testScenarioOnEmulator "Forbid transfers to implicit accounts (#440)" $ scenarioEmulated do - testRevealContract morleyMessage - , testScenarioOnNetwork "Forbid transfers to implicit accounts (#440)" $ scenario do - testRevealContract rpcMessage - - , testScenarioOnEmulator "Forbid transfers to empty implicit accounts (#440)" $ scenario do - testEmptyImplicitAccount morleyMessage - , testScenarioOnNetwork "Forbid transfers to empty implicit accounts (#440)" $ scenario do - testEmptyImplicitAccount rpcMessage - , testScenario "Fails transfering 0tz to plain account" $ scenario + [ testScenario "Fails transfering 0tz to plain account" $ scenario $ testZeroTransactionFails , testScenario "Success transfering 0tz to a contract" $ scenario $ testZeroTransactionSuccess , testScenario "Allow transferring 0ꜩ from TRANSFER_TOKENS (#440)" $ scenario testEmptyTransfer ] where - morleyMessage :: String - morleyMessage = "Global transaction of funds (200 μꜩ) from an originated contract" - - rpcMessage :: String - rpcMessage = "Contracts (rx) cannot be revealed" - - testRevealContract :: MonadCleveland caps m => String -> m () - testRevealContract expectedErrorMsg = do - addr <- newAddress auto - contractAddr <- originateSimple @() @() "rx" () idContract - - comment "give some funds to the originated contract" - transferMoney contractAddr 200 - - comment "fail when transferring from contract" - transferMoney addr 200 - & withSender (toAddress contractAddr) - & shouldFailWithMessage expectedErrorMsg - - testEmptyImplicitAccount :: MonadCleveland caps m => String -> m () - testEmptyImplicitAccount expectedErrorMsg = do - testAddr <- newFreshAddress auto - contractAddr <- originate OriginateData - { odName = "rx" - , odStorage = () - , odBalance = 500 - , odContract = idContract @() @() - } - - comment "fail when transferring from contract" - transferMoney testAddr 200 - & withSender (toAddress contractAddr) - & shouldFailWithMessage expectedErrorMsg - testEmptyTransfer :: MonadCleveland caps m => m () testEmptyTransfer = do - addr1 <- originateSimple "test1" () zeroTransferContract - addr2 <- originateSimple "test2" () idContract - call addr1 L.CallDefault (toTAddress addr2) + addr1 <- originate "test1" () zeroTransferContract + addr2 <- originate "test2" () idContract + transfer addr1 $ calling def (toTAddress addr2) zeroTransferContract :: L.Contract (L.TAddress () ()) () () zeroTransferContract = L.defaultContract $ @@ -90,36 +47,16 @@ test_nonUnitParamToImplicitAccount_fails = testScenario "`transfer` fails when param for an implicit account is not Unit" $ scenario do addr <- newFreshAddress "alias" - transfer TransferData - { tdTo = addr - , tdAmount = 2 - , tdEntrypoint = DefEpName - , tdParameter = (2 :: Natural) - } + transfer addr [tz|2u|] (unsafeCalling def (2 :: Natural)) & shouldFailWithMessage "Bad contract parameter for: " testZeroTransactionFails :: MonadCleveland caps m => m () testZeroTransactionFails = do wallet <- newAddress "wallet" - let - transferData = TransferData - { tdTo = wallet - , tdAmount = 0 - , tdEntrypoint = DefEpName - , tdParameter = () - } - - expectTransferFailure emptyTransaction (transfer transferData) + expectTransferFailure emptyTransaction (transfer wallet) testZeroTransactionSuccess :: MonadCleveland caps m => m () testZeroTransactionSuccess = do - address <- originateSimple @MText "test0tzContract" True idContract - let - transferData = TransferData - { tdTo = address - , tdAmount = 0 - , tdEntrypoint = DefEpName - , tdParameter = "aaa" :: MText - } + address <- originate "test0tzContract" True $ idContract @MText - transfer transferData + transfer address $ calling def "aaa" diff --git a/test/TestSuite/Cleveland/VotingPower.hs b/test/TestSuite/Cleveland/VotingPower.hs --- a/test/TestSuite/Cleveland/VotingPower.hs +++ b/test/TestSuite/Cleveland/VotingPower.hs @@ -17,16 +17,16 @@ test_VotingPowers = [ testScenario "Can pick voting power of some address" $ scenario do contract - <- originateSimple "vp contract" 0 + <- originate "vp contract" 0 =<< importContract @KeyHash @Natural @() ("../../contracts/voting_power.tz") let keyHash = unsafe $ parseHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" - call contract CallDefault keyHash + transfer contract $ calling def keyHash getStorage contract @@== 0 , testScenarioOnEmulator "Can set voting powers in test scenario" $ scenarioEmulated do contract - <- originateSimple "vp contract" (0, 0) + <- originate "vp contract" (0, 0) =<< importContract @KeyHash @(Natural, Natural) @() ("../../contracts/voting_powers.tz") comment "Setting custom voting powers to access them later" @@ -34,6 +34,6 @@ let keyHash2 = unsafe $ parseHash "tz1hvYBbHRJhT3dQ8bEjc34xm3rjJJmTcuqs" setVotingPowers (mkVotingPowers [(keyHash, 123), (keyHash2, 57)]) - call contract CallDefault keyHash + transfer contract $ calling def keyHash getStorage contract @@== (123, 180) ] diff --git a/test/TestSuite/Cleveland/WithMoneybag.hs b/test/TestSuite/Cleveland/WithMoneybag.hs --- a/test/TestSuite/Cleveland/WithMoneybag.hs +++ b/test/TestSuite/Cleveland/WithMoneybag.hs @@ -13,7 +13,7 @@ test_withMoneybag = testScenario "withMoneybag overrides the funder of new accounts" $ scenario do newMoneybag <- newFreshAddress "newMoneybag" - transferMoney newMoneybag 4_e6 + transfer newMoneybag [tz|4|] -- At the end of this test, we want to check that `newAddress` transfers funds from "newMoneybag" to "testAccount". -- However, this will only happen if: diff --git a/test/TestSuite/Cleveland/WithSender.hs b/test/TestSuite/Cleveland/WithSender.hs --- a/test/TestSuite/Cleveland/WithSender.hs +++ b/test/TestSuite/Cleveland/WithSender.hs @@ -19,12 +19,12 @@ user <- newAddress auto balance1 <- getBalance user - withSender user $ originateSimple @() @() "contract" () idContract + withSender user $ originate "contract" () $ idContract @() @() balance2 <- getBalance user checkCompares balance2 (<) balance1 balance3 <- getBalance user - withSender user $ inBatch $ originateSimple @() @() "contract" () idContract + withSender user $ inBatch $ originate "contract" () $ idContract @() @() balance4 <- getBalance user checkCompares balance4 (<) balance3 @@ -33,12 +33,12 @@ testScenario "Transfer is made from the sender's address" $ scenario do user <- newAddress auto - contract <- originateSimple "contract" [] saveSender + contract <- originate "contract" [] saveSender withSender user do - transfer (TransferData contract 0 (ep "") ()) - transferMoney contract 0 - call contract CallDefault () - inBatch $ call contract CallDefault () + transfer contract + transfer contract [tz|0u|] + transfer contract + inBatch $ transfer contract - getStorage contract @@== replicate 4 user + getStorage contract @@== toAddress <$> replicate 4 user