diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,32 @@ +0.2.0 +===== +* [!1172](https://gitlab.com/morley-framework/morley/-/merge_requests/1172) + Add `withChainId` and `withMinBlockTime` functions to set emulator constants. +* [!1123](https://gitlab.com/morley-framework/morley/-/merge_requests/1123) + Remove deprecated exports +* [!1161](https://gitlab.com/morley-framework/morley/-/merge_requests/1161) + Remove support for `AliasHint` +* [!1169](https://gitlab.com/morley-framework/morley/-/merge_requests/1169) + Support MIN_BLOCK_TIME instruction + + Add `getMinBlockTime` utility to get minimal block delay in seconds as + `Natural` +* [!1164](https://gitlab.com/morley-framework/morley/-/merge_requests/1164) + Add `now` and `level` params to the `/run_code` +* [!1162](https://gitlab.com/morley-framework/morley/-/merge_requests/1162) + Implement instruction to batch-create accounts +* [!1114](https://gitlab.com/morley-framework/morley/-/merge_requests/1114) + Update to ghc-9.0.2 +* [!1108](https://gitlab.com/morley-framework/morley/-/merge_requests/1108) + Remove support for the deprecated morley extensions +* [!1127](https://gitlab.com/morley-framework/morley/-/merge_requests/1127) + Create tempdir in Cleveland if datadir is unspecified + + Instead of mangling user's default tezos-client data directory, when + a Cleveland test-suite invocation doesn't specify a datadir, use a + new temporary directory by default. + 0.1.2 ===== * [!1050](https://gitlab.com/morley-framework/morley/-/merge_requests/1050) 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.1.2 +version: 0.2.0 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 @@ -72,11 +72,9 @@ Test.Cleveland.Lorentz.Ticketer Test.Cleveland.Lorentz.Types Test.Cleveland.Michelson - Test.Cleveland.Michelson.Dummy Test.Cleveland.Michelson.Entrypoints Test.Cleveland.Michelson.Import Test.Cleveland.Michelson.Internal.Entrypoints - Test.Cleveland.Michelson.Unit Test.Cleveland.Tasty Test.Cleveland.Tasty.Internal Test.Cleveland.Tasty.Internal.Options @@ -157,8 +155,6 @@ , fmt , hedgehog >=1.0.3 , hex-text - , hspec - , hspec-expectations , lens , lorentz , morley @@ -171,6 +167,7 @@ , safe-exceptions , servant-client-core , singletons + , singletons-base , statistics , tagged , tasty >=1.4 @@ -178,6 +175,7 @@ , tasty-hedgehog , tasty-hunit-compat , template-haskell + , temporary , text , time , with-utf8 @@ -198,6 +196,7 @@ TestSuite.Cleveland.ChainIdGet TestSuite.Cleveland.ContractAllocation TestSuite.Cleveland.DFS + TestSuite.Cleveland.EmptyImplicitAddress TestSuite.Cleveland.Emulated TestSuite.Cleveland.Entrypoints TestSuite.Cleveland.ExpectFailure @@ -210,7 +209,6 @@ TestSuite.Cleveland.MismatchError TestSuite.Cleveland.NewAddressCheck TestSuite.Cleveland.OperationReplay - TestSuite.Cleveland.PrefixNetworkScenario TestSuite.Cleveland.PrettyFailWith TestSuite.Cleveland.PublicKeyToAddress TestSuite.Cleveland.RefillableAddress @@ -305,7 +303,6 @@ , tasty , tasty-hedgehog , tasty-hunit-compat - , temporary , text , time default-language: Haskell2010 diff --git a/src/Hedgehog/Gen/Michelson.hs b/src/Hedgehog/Gen/Michelson.hs --- a/src/Hedgehog/Gen/Michelson.hs +++ b/src/Hedgehog/Gen/Michelson.hs @@ -2,8 +2,7 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Michelson - ( genInstrCallStack - , genLetName + ( genErrorSrcPos , genSrcPos , genPos , genMText @@ -11,26 +10,15 @@ import Hedgehog (MonadGen) import Hedgehog.Gen qualified as Gen -import Hedgehog.Range (Range) import Hedgehog.Range qualified as Range -import Morley.Michelson.ErrorPos (InstrCallStack(..), LetName(..), Pos(..), SrcPos(..)) +import Morley.Michelson.ErrorPos (ErrorSrcPos(..), Pos(..), SrcPos(..)) import Morley.Michelson.Text (MText, maxBoundMChar, minBoundMChar, mkMText) import Hedgehog.Range.Defaults -genInstrCallStack :: MonadGen m => m InstrCallStack -genInstrCallStack = InstrCallStack <$> genLetCallStack <*> genSrcPos - where - genLetCallStack = Gen.frequency - [ (80, pure []) - , (18, Gen.list (Range.singleton 1) $ genLetName def) - , (2, Gen.list (Range.singleton 2) $ genLetName def) - ] - -genLetName :: MonadGen m => Range TinyLength -> m LetName -genLetName lenRange = - LetName <$> Gen.text (unTinyLength <$> lenRange) Gen.unicodeAll +genErrorSrcPos :: MonadGen m => m ErrorSrcPos +genErrorSrcPos = ErrorSrcPos <$> genSrcPos genSrcPos :: MonadGen m => m SrcPos genSrcPos = SrcPos <$> genPos def <*> genPos def 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 @@ -40,12 +40,14 @@ import Hedgehog.Gen.Tezos.Crypto.BLS12381 (genBls12381Fr, genBls12381G1, genBls12381G2) import Morley.Michelson.Text (mkMText) import Morley.Michelson.Typed - (Instr(DROP, FAILWITH, PUSH, SWAP, Seq, UNIT), SingT(..), T(..), Value'(..), toVal) + (Instr(DROP, FAILWITH, PUSH, SWAP, Seq, UNIT), SingT(..), T(..), Value'(..), mkVLam, toVal) import Morley.Michelson.Typed.Entrypoints (EpAddress(..), unsafeSepcCallRoot) 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.Core (Mutez, Timestamp) +import Morley.Tezos.Crypto (parseHash) import Morley.Tezos.Crypto.BLS12381 qualified as BLS import Hedgehog.Gen.Tezos.Crypto.Timelock (genChestAndKey) @@ -182,7 +184,7 @@ ] -- It's quite hard to generate proper lambda of given type, so it always returns FAILWITH. -- Such implementation is sufficient for now. - STLambda{} -> pure $ VLam $ RfAlwaysFails $ Seq UNIT FAILWITH + STLambda{} -> pure $ mkVLam $ RfAlwaysFails $ Seq UNIT FAILWITH STMap k v -> genValueMap def (genNoOpValue k) (genNoOpValue v) STBigMap k v -> genValueBigMap def (genNoOpValue k) (genNoOpValue v) STInt -> genValueInt def @@ -191,6 +193,23 @@ STBytes -> genValueBytes def STMutez -> genValueMutez def STKeyHash -> genValueKeyHash + STTxRollupL2Address -> + VTxRollupL2Address . TxRollupL2Address + . unsafe . parseHash <$> Gen.element + -- TODO [#839]: implement BLS public key generation + [ "tz4UJqedFMBS7FjAqvZojJMPNd59MLm2hkuc" + , "tz4Y7kRVfDH2XGQtjc19ppJqejL4CBVmxHED" + , "tz4LVHYD4P4T5NHCuwJbxQvwVURF62seE3Qa" + , "tz4MwL5iRbyHvVxH9N69GCeDmYCqbQtewr7R" + , "tz4AZhg8GuahEs2Uo7dFZxVZwEgNKirtYMhY" + , "tz4D77UuwdqbmDd7Xh9VNbFRjDiqWbBeWqud" + , "tz4SYR9zvak9GohAEENUjPk7zAQo46wo6vNE" + , "tz4UWDSphLswG5xtBwGnodCGL7FBzN21EKSQ" + , "tz49e42Nbrc15PuT7RgkGqC6Xi3w5jEzEzH1" + , "tz4F1Nd91Fc3BUCxTCnFaccjnn2hH4W3Bd8X" + , "tz4MVuy2j5GCjPZQg7cxadPiNWq2nsRA392Y" + , "tz4StvWhTeDnVpGspXKbfuhuVXhZ1jkAp7Yq" + ] STBls12381Fr -> VBls12381Fr <$> genBls12381Fr STBls12381G1 -> VBls12381G1 <$> genBls12381G1 STBls12381G2 -> VBls12381G2 <$> genBls12381G2 @@ -202,7 +221,7 @@ STChestKey -> VChestKey . snd <$> genChestAndKey STNever -> Gen.discard STSaplingState _ -> error "genValue': Cannot generate `sapling_state` value." - STSaplingTransaction _ -> error "genValue': Cannot generate `sapling_instruction` value." + STSaplingTransaction _ -> error "genValue': Cannot generate `sapling_transaction` value." where genNoOpValue :: (MonadGen m, GenBase m ~ Identity, WellTyped t') diff --git a/src/Hedgehog/Gen/Michelson/Untyped.hs b/src/Hedgehog/Gen/Michelson/Untyped.hs --- a/src/Hedgehog/Gen/Michelson/Untyped.hs +++ b/src/Hedgehog/Gen/Michelson/Untyped.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - module Hedgehog.Gen.Michelson.Untyped ( genInternalByteString , genVar @@ -13,7 +10,6 @@ , genPrintComment , genStackRef , genTestAssert - , genStackFn , genStackTypePattern , genInstrAbstract , genContract @@ -38,7 +34,7 @@ import Morley.Michelson.Untyped -import Hedgehog.Gen.Michelson (genInstrCallStack, genMText) +import Hedgehog.Gen.Michelson (genErrorSrcPos, genMText) import Hedgehog.Range.Defaults genInternalByteString :: MonadGen m => Range Length -> m InternalByteString @@ -61,13 +57,12 @@ -- recursive constructors [ PrimEx <$> genInstrAbstract genExpandedOp , SeqEx <$> genSmallList genExpandedOp - , Gen.subtermM genExpandedOp $ \expandedOp -> WithSrcEx <$> genInstrCallStack <*> pure expandedOp + , Gen.subtermM genExpandedOp $ \expandedOp -> WithSrcEx <$> genErrorSrcPos <*> pure expandedOp ] genExtInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (ExtInstrAbstract op) genExtInstrAbstract genOp = Gen.choice [ STACKTYPE <$> genStackTypePattern - , FN <$> genSmallText <*> genStackFn <*> genSmallList genOp , UTEST_ASSERT <$> genTestAssert genOp , UPRINT <$> genPrintComment def , UCOMMENT <$> genSmallText @@ -83,12 +78,6 @@ genTestAssert :: MonadGen m => m op -> m (TestAssert op) genTestAssert genOp = TestAssert <$> genSmallText <*> genPrintComment def <*> genSmallList genOp - -genStackFn :: (MonadGen m, GenBase m ~ Identity) => m StackFn -genStackFn = StackFn - <$> Gen.maybe (Gen.set smallCollectionRange genVar) - <*> genStackTypePattern - <*> genStackTypePattern genStackTypePattern :: (MonadGen m, GenBase m ~ Identity) => m StackTypePattern genStackTypePattern = Gen.recursive Gen.choice diff --git a/src/Hedgehog/Gen/Morley/Micheline.hs b/src/Hedgehog/Gen/Morley/Micheline.hs --- a/src/Hedgehog/Gen/Morley/Micheline.hs +++ b/src/Hedgehog/Gen/Morley/Micheline.hs @@ -2,12 +2,21 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA module Hedgehog.Gen.Morley.Micheline - ( genExpression + ( -- * 'Expression' generators + genExpression , genExpressionInt , genExpressionString , genExpressionBytes , genExpressionSeq , genExpressionPrim + + -- * Generic 'Exp' generators + , genExp + , genExpInt + , genExpString + , genExpBytes + , genExpSeq + , genExpPrim , genMichelinePrimAp , genExprAnnotation ) where @@ -17,36 +26,91 @@ import Hedgehog.Range (Range) import Hedgehog.Gen.Michelson.Untyped (genAnnotation) +import Hedgehog.Range.Defaults import Morley.Micheline.Expression -import Hedgehog.Range.Defaults +---------------------------------------------------------------------------- +-- Expression generators +---------------------------------------------------------------------------- genExpression :: forall m. (MonadGen m, GenBase m ~ Identity) => m Expression -genExpression = Gen.recursive @m Gen.choice - [genExpressionInt def, genExpressionString def, genExpressionBytes def] - [genExpressionSeq def, genExpressionPrim] +genExpression = genExp Nothing Nothing (mkUniformExpExtras Gen.enumBounded) -genExpressionInt :: MonadGen f => Range ExpressionInt -> f Expression -genExpressionInt range = ExpressionInt <$> Gen.integral (unExpressionInt <$> range) +genExpressionInt :: MonadGen m => Range ExpressionInt -> m Expression +genExpressionInt = genExpInt (pure ()) -genExpressionString :: MonadGen f => Range SmallLength -> f Expression -genExpressionString rangeLen = - ExpressionString <$> (Gen.text (unSmallLength <$> rangeLen) Gen.unicodeAll) +genExpressionString :: MonadGen m => Range SmallLength -> m Expression +genExpressionString = genExpString (pure ()) -genExpressionBytes :: MonadGen f => Range Length -> f Expression -genExpressionBytes rangeLen = ExpressionBytes <$> Gen.bytes (unLength <$> rangeLen) +genExpressionBytes :: MonadGen m => Range Length -> m Expression +genExpressionBytes = genExpBytes (pure ()) genExpressionSeq :: (MonadGen m, GenBase m ~ Identity) => Range SmallLength -> m Expression -genExpressionSeq = fmap ExpressionSeq . genSeq - -genSeq :: (MonadGen m, GenBase m ~ Identity) => Range SmallLength -> m [Expression] -genSeq rangeLen = Gen.list (unSmallLength <$> rangeLen) genExpression +genExpressionSeq = genExpSeq genExpression (pure ()) genExpressionPrim :: (MonadGen m, GenBase m ~ Identity) => m Expression -genExpressionPrim = ExpressionPrim <$> genMichelinePrimAp +genExpressionPrim = genExpPrim genExpression (pure ()) -genMichelinePrimAp :: (MonadGen m, GenBase m ~ Identity) => m MichelinePrimAp -genMichelinePrimAp = MichelinePrimAp <$> genMichelinePrimitive <*> genSeq def <*> genAnnots +---------------------------------------------------------------------------- +-- Generic Exp generators +---------------------------------------------------------------------------- + +-- | Generate extended expression given the generators for all the extension +-- points. +-- +-- In case your expression has no extra constructors, avoid supplying +-- @Just 'Gen.discard'@ as that would cause the generator to give up +-- periodically (supply 'Nothing' instead). +genExp + :: forall x m. (MonadGen m, GenBase m ~ Identity) + => Maybe (m (XExp x)) + -- ^ Non-recursive extra constructors + -> Maybe (m (XExp x)) + -- ^ Recursive extra constructors (that can generate @Exp@ inside) + -> ExpExtras m x + -> m (Exp x) +genExp mGenXCon mGenXConRec xGens = Gen.recursive Gen.choice + ( maybe id (:) (ExpX <<$>> mGenXCon) + [ genExpInt (eeInt xGens) def + , genExpString (eeString xGens) def + , genExpBytes (eeBytes xGens) def + ] + ) + ( maybe id (:) (ExpX <<$>> mGenXConRec) + [genExpSeq runRec (eeSeq xGens) def, genExpPrim runRec (eePrim xGens)] + ) + where + runRec = Gen.subterm (genExp mGenXCon mGenXConRec xGens) id + +genExpInt :: MonadGen m => m (XExpInt x) -> Range ExpressionInt -> m (Exp x) +genExpInt genX range = + ExpInt <$> genX <*> Gen.integral (unExpressionInt <$> range) + +genExpString :: MonadGen m => m (XExpString x) -> Range SmallLength -> m (Exp x) +genExpString genX rangeLen = + ExpString <$> genX <*> (Gen.text (unSmallLength <$> rangeLen) Gen.unicodeAll) + +genExpBytes :: MonadGen m => m (XExpBytes x) -> Range Length -> m (Exp x) +genExpBytes genX rangeLen = + ExpBytes <$> genX <*> Gen.bytes (unLength <$> rangeLen) + +genExpSeq + :: MonadGen m + => m (Exp x) -> m (XExpSeq x) -> Range SmallLength -> m (Exp x) +genExpSeq doGenExp genX rangeLen = + ExpSeq <$> genX <*> Gen.list (unSmallLength <$> rangeLen) doGenExp + +genExpPrim + :: (MonadGen m, GenBase m ~ Identity) + => m (Exp x) -> m (XExpPrim x) -> m (Exp x) +genExpPrim doGenExp genX = ExpPrim <$> genX <*> genMichelinePrimAp doGenExp + +genMichelinePrimAp :: forall x m. (MonadGen m, GenBase m ~ Identity) => m (Exp x) -> m (MichelinePrimAp x) +genMichelinePrimAp doGenExp = + MichelinePrimAp + <$> genMichelinePrimitive + <*> Gen.list (unSmallLength <$> def) doGenExp + <*> genAnnots where genMichelinePrimitive = MichelinePrimitive <$> (Gen.element $ toList michelsonPrimitive) genAnnots = Gen.list (unSmallLength <$> def) genExprAnnotation diff --git a/src/Hedgehog/Gen/SizedList.hs b/src/Hedgehog/Gen/SizedList.hs --- a/src/Hedgehog/Gen/SizedList.hs +++ b/src/Hedgehog/Gen/SizedList.hs @@ -11,7 +11,6 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import Morley.Util.SizedList qualified as SL import Morley.Util.SizedList.Types genSizedList @@ -22,4 +21,4 @@ genSomeSizedList :: forall m a. (MonadGen m) => Range.Range Int -> m a -> m (SomeSizedList a) -genSomeSizedList len el = SL.fromList <$> Gen.list len el +genSomeSizedList len el = fromList <$> Gen.list len el 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,7 +14,8 @@ import Hedgehog.Range qualified as Range import Hedgehog.Gen.Tezos.Crypto (genKeyHash) -import Morley.Tezos.Address (Address(..), ContractHash(..)) +import Morley.Tezos.Address (Address(..)) +import Morley.Tezos.Crypto genAddress :: MonadGen m => m Address genAddress = Gen.choice [genKeyAddress, genContractAddress] @@ -23,4 +24,4 @@ genKeyAddress = KeyAddress <$> genKeyHash genContractAddress :: MonadGen m => m Address -genContractAddress = ContractAddress . ContractHash <$> Gen.bytes (Range.singleton 20) +genContractAddress = ContractAddress . Hash HashContract <$> Gen.bytes (Range.singleton 20) diff --git a/src/Hedgehog/Gen/Tezos/Crypto.hs b/src/Hedgehog/Gen/Tezos/Crypto.hs --- a/src/Hedgehog/Gen/Tezos/Crypto.hs +++ b/src/Hedgehog/Gen/Tezos/Crypto.hs @@ -14,8 +14,8 @@ import Hedgehog.Range qualified as Range import Morley.Tezos.Crypto - (KeyHash, KeyHashTag, PublicKey, SecretKey(..), Signature(..), hashKey, signatureLengthBytes, - toPublic) + (KeyHash, KeyHashTag, PublicKey, SecretKey(..), Signature(..), allHashTags, hashKey, + signatureLengthBytes, toPublic) import Hedgehog.Gen.Tezos.Crypto.Ed25519 qualified as Ed25519 import Hedgehog.Gen.Tezos.Crypto.P256 qualified as P256 @@ -40,7 +40,7 @@ ] genKeyHashTag :: MonadGen m => m KeyHashTag -genKeyHashTag = Gen.enumBounded +genKeyHashTag = Gen.element $ toList allHashTags genKeyHash :: MonadGen m => m KeyHash genKeyHash = hashKey <$> genPublicKey diff --git a/src/Hedgehog/Range/Defaults.hs b/src/Hedgehog/Range/Defaults.hs --- a/src/Hedgehog/Range/Defaults.hs +++ b/src/Hedgehog/Range/Defaults.hs @@ -48,7 +48,7 @@ -- | Newtype for the range of @ValueInt@ constructor of untyped @Value'@. newtype ValueInt = MkValueInt { unValueInt :: Integer } - deriving newtype (Eq, Ord, Enum, Integral, Real, Num) + deriving newtype (Eq, Ord, Enum, Real, Num) instance Default (Range ValueInt) where def = MkValueInt <$> @@ -58,7 +58,7 @@ -- | Newtype for the range of @ExpressionInt@ constructor of @Expression@. newtype ExpressionInt = MkExpressionInt { unExpressionInt :: Integer } - deriving newtype (Eq, Ord, Enum, Integral, Real, Num) + deriving newtype (Eq, Ord, Enum, Real, Num) instance Default (Range ExpressionInt) where def = MkExpressionInt <$> Range.linearFrom 0 -1000 1000 diff --git a/src/Lorentz/Test/DupableScan.hs b/src/Lorentz/Test/DupableScan.hs --- a/src/Lorentz/Test/DupableScan.hs +++ b/src/Lorentz/Test/DupableScan.hs @@ -11,10 +11,10 @@ , BadElement (..) ) where -import Data.Singletons.Prelude (demote) import Data.Typeable (TypeRep, typeRep) import Fmt (Buildable(..), pretty, (+|), (|+)) import GHC.Generics qualified as G +import Prelude.Singletons (demote) import Test.HUnit (assertFailure) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) diff --git a/src/Test/Cleveland.hs b/src/Test/Cleveland.hs --- a/src/Test/Cleveland.hs +++ b/src/Test/Cleveland.hs @@ -6,7 +6,7 @@ -- See the [documentation](https://gitlab.com/morley-framework/morley/-/blob/master/code/cleveland/testingEDSL.md) -- for usage instructions. module Test.Cleveland - ( AliasHint + ( Alias , ContractHandle (..) , OriginateData (..) , UntypedOriginateData (..) @@ -27,6 +27,8 @@ , scenarioEmulated , withInitialNow , withInitialLevel + , withMinBlockTime + , withChainId , collectLogs , logsForAddress @@ -42,8 +44,9 @@ , resolveAddress , refillable , newAddress + , newAddresses , newFreshAddress - , enumAliasHints + , enumAliases , signBytes , signBinary , originate @@ -84,6 +87,7 @@ , getNow , getLevel , getApproximateBlockInterval + , getMinBlockTime , RunCode(..) , AsRPC.MaybeRPC(..) , runCode 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 @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Test.Cleveland.Instances - ( HasInstrCallStack (..) + ( HasErrorSrcPos (..) ) where import Fmt (Buildable(..), eitherF, hexF, tupleF, (+|), (|+)) @@ -16,6 +16,7 @@ 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.Core (Mutez(..), mkMutez, unsafeAddMutez, unsafeMulMutez, unsafeSubMutez) instance IsString (Annotation tag) where @@ -93,41 +94,41 @@ instance Buildable ByteString where build bs = "0x" <> hexF bs instance Buildable LByteString where build bs = "0x" <> hexF bs --- | Class of types with t'Morley.Michelson.ErrorPos.InstrCallStack' allowing to remove it. --- Can be used in tests when we want to compare only values without callstack. -class HasInstrCallStack a where - withoutIcs :: a -> a +-- | Class of types with t'Morley.Michelson.ErrorPos.ErrorSrcPos' allowing to remove it. +-- Can be used in tests when we want to compare only values without source positions. +class HasErrorSrcPos a where + withoutEsp :: a -> a -withoutIcs' :: (Functor f, HasInstrCallStack a) => f a -> f a -withoutIcs' = fmap withoutIcs +withoutEsp' :: (Functor f, HasErrorSrcPos a) => f a -> f a +withoutEsp' = fmap withoutEsp -instance HasInstrCallStack U.ExpandedOp where - withoutIcs = \case - U.SeqEx ops' -> U.SeqEx $ withoutIcs' ops' - U.WithSrcEx _ op -> withoutIcs op - U.PrimEx instr -> U.PrimEx $ withoutIcs instr +instance HasErrorSrcPos U.ExpandedOp where + withoutEsp = \case + U.SeqEx ops' -> U.SeqEx $ withoutEsp' ops' + U.WithSrcEx _ op -> withoutEsp op + U.PrimEx instr -> U.PrimEx $ withoutEsp instr -instance HasInstrCallStack U.ExpandedInstr where - withoutIcs = \case - U.PUSH va ty v -> U.PUSH va ty $ withoutIcs v - U.IF_NONE ops1 ops2 -> U.IF_NONE (withoutIcs' ops1) (withoutIcs' ops2) - U.IF_LEFT ops1 ops2 -> U.IF_LEFT (withoutIcs' ops1) (withoutIcs' ops2) - U.IF_CONS ops1 ops2 -> U.IF_CONS (withoutIcs' ops1) (withoutIcs' ops2) - U.MAP va ops -> U.MAP va (withoutIcs' ops) - U.ITER ops -> U.ITER $ withoutIcs' ops - U.IF ops1 ops2 -> U.IF (withoutIcs' ops1) (withoutIcs' ops2) - U.LOOP ops -> U.LOOP $ withoutIcs' ops - U.LOOP_LEFT ops -> U.LOOP_LEFT $ withoutIcs' ops - U.LAMBDA va ty1 ty2 ops -> U.LAMBDA va ty1 ty2 (withoutIcs' ops) - U.DIP ops -> U.DIP $ withoutIcs' ops - U.DIPN n ops -> U.DIPN n (withoutIcs' ops) +instance HasErrorSrcPos U.ExpandedInstr where + withoutEsp = \case + U.PUSH va ty v -> U.PUSH va ty $ withoutEsp v + U.IF_NONE ops1 ops2 -> U.IF_NONE (withoutEsp' ops1) (withoutEsp' ops2) + U.IF_LEFT ops1 ops2 -> U.IF_LEFT (withoutEsp' ops1) (withoutEsp' ops2) + U.IF_CONS ops1 ops2 -> U.IF_CONS (withoutEsp' ops1) (withoutEsp' ops2) + U.MAP va ops -> U.MAP va (withoutEsp' ops) + U.ITER ops -> U.ITER $ withoutEsp' ops + U.IF ops1 ops2 -> U.IF (withoutEsp' ops1) (withoutEsp' ops2) + U.LOOP ops -> U.LOOP $ withoutEsp' ops + U.LOOP_LEFT ops -> U.LOOP_LEFT $ withoutEsp' ops + U.LAMBDA va ty1 ty2 ops -> U.LAMBDA va ty1 ty2 (withoutEsp' ops) + U.DIP ops -> U.DIP $ withoutEsp' ops + U.DIPN n ops -> U.DIPN n (withoutEsp' ops) U.CREATE_CONTRACT va1 va2 c -> - U.CREATE_CONTRACT va1 va2 (U.mapContractCode withoutIcs c) + U.CREATE_CONTRACT va1 va2 (U.mapContractCode withoutEsp c) i -> i -instance HasInstrCallStack U.Value where - withoutIcs = \case - U.ValueLambda ops -> U.ValueLambda $ withoutIcs' ops +instance HasErrorSrcPos U.Value where + withoutEsp = \case + U.ValueLambda ops -> U.ValueLambda $ withoutEsp' ops v -> v -- We don't want to depend on o-clock in morley-prelude, hence we're defining @@ -143,3 +144,6 @@ instance (Buildable a, Buildable b) => Buildable (Either a b) where build = eitherF + +instance IsString Alias where + fromString = Alias . 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 @@ -39,7 +39,7 @@ , ClevelandInput , DefaultAliasCounter (..) - , SpecificOrDefaultAliasHint (..) + , SpecificOrDefaultAlias (..) -- * Actions , ClevelandOpsImpl (..) @@ -71,7 +71,7 @@ , mkDefaultAlias -- * Morley client re-exports - , AliasHint + , Alias -- * Capability records , ClevelandCaps(..) @@ -110,10 +110,10 @@ import Lorentz (Contract(..)) import Lorentz.Constraints import Morley.AsRPC (HasRPCRepr(AsRPC), MaybeRPC) -import Morley.Client (AliasHint, Result) +import Morley.Client (Result) import Morley.Client.Types import Morley.Micheline (Expression, fromExpression) -import Morley.Michelson.ErrorPos (InstrCallStack) +import Morley.Michelson.ErrorPos (ErrorSrcPos) import Morley.Michelson.Interpret (MorleyLogs(..)) import Morley.Michelson.Runtime (VotingPowers) import Morley.Michelson.Typed (BigMapId) @@ -123,6 +123,7 @@ 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.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto import Morley.Tezos.Crypto qualified as Crypto @@ -134,7 +135,7 @@ data OriginateData param st vd = OriginateData - { odName :: AliasHint + { odName :: Alias -- ^ Alias for the originated contract. , odBalance :: Mutez -- ^ Initial balance. @@ -151,7 +152,7 @@ -- | Untyped version of OriginateData. It can be used for interaction with raw -- Michelson contracts data UntypedOriginateData = UntypedOriginateData - { uodName :: AliasHint + { uodName :: Alias -- ^ Alias for the originated contract. , uodBalance :: Mutez -- ^ Initial balance. @@ -213,30 +214,30 @@ -- undesired and unexpected to the user. newtype Moneybag = Moneybag { unMoneybag :: Address } --- | An alias hint with default value that can be used to define unique alias +-- | An alias with default value that can be used to define unique alias -- automatically. -data SpecificOrDefaultAliasHint - = SpecificAliasHint AliasHint - | DefaultAliasHint +data SpecificOrDefaultAlias + = SpecificAlias Alias + | DefaultAlias deriving stock (Show) -instance IsString SpecificOrDefaultAliasHint where - fromString = SpecificAliasHint . fromString +instance IsString SpecificOrDefaultAlias where + fromString = SpecificAlias . Alias . fromString -instance Default SpecificOrDefaultAliasHint where - def = DefaultAliasHint +instance Default SpecificOrDefaultAlias where + def = DefaultAlias -mkDefaultAlias :: Natural -> AliasHint +mkDefaultAlias :: Natural -> Alias mkDefaultAlias counter = - fromString $ ("default_cleveland_alias" <> show counter) + Alias . fromString $ ("default_cleveland_alias" <> show counter) -- | Helper to use automatically determined unique alias. -auto :: SpecificOrDefaultAliasHint +auto :: SpecificOrDefaultAlias auto = def -- | Counter which is used to provide different default aliases. newtype DefaultAliasCounter = DefaultAliasCounter {unDefaultAliasCounter :: Natural} - deriving stock Show + deriving stock (Eq, Show) -- | A record data type with operations creating primitives. data ClevelandOpsImpl m = ClevelandOpsImpl @@ -249,13 +250,13 @@ data ClevelandMiscImpl m = ClevelandMiscImpl { cmiRunIO :: forall res. HasCallStack => IO res -> m res -- ^ Runs an 'IO' action. - , cmiResolveAddress :: HasCallStack => AliasHint -> m Address + , cmiResolveAddress :: HasCallStack => Alias -> m Address -- ^ Get the address of the implicit account / contract associated with the given alias. - , cmiGenKey :: HasCallStack => SpecificOrDefaultAliasHint -> m Address + , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m Address -- ^ 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 => SpecificOrDefaultAliasHint -> m Address + , cmiGenFreshKey :: HasCallStack => SpecificOrDefaultAlias -> m Address -- ^ Generate a secret key and store it with given alias. -- Unlike 'cmiGenKey' this function overwrites the existing key when -- given alias is already stored. @@ -336,6 +337,10 @@ , rcParameter :: MaybeRPC cp , rcAmount :: Mutez -- ^ The value that will be returned by the @AMOUNT@ instruction. + , rcLevel :: Maybe Natural + -- ^ The value that will be returned by the @LEVEL@ instruction. + , rcNow :: Maybe Timestamp + -- ^ 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 @@ -524,7 +529,7 @@ } deriving stock (Show, Eq) data TransferFailureReason - = FailedWith ExpressionOrTypedValue (Maybe InstrCallStack) + = FailedWith ExpressionOrTypedValue (Maybe ErrorSrcPos) -- ^ Expect that interpretation of contract with the given address ended -- with @FAILWITH@. | EmptyTransaction @@ -636,8 +641,8 @@ { cmiRunIO = \action -> f $ cmiRunIO action , cmiResolveAddress = \address -> f $ cmiResolveAddress address , cmiSignBytes = \bs alias -> f $ cmiSignBytes bs alias - , cmiGenKey = \aliasHint -> f $ cmiGenKey aliasHint - , cmiGenFreshKey = \aliasHint -> f $ cmiGenFreshKey aliasHint + , cmiGenKey = \alias -> f $ cmiGenKey alias + , cmiGenFreshKey = \alias -> f $ cmiGenFreshKey alias , cmiOriginateLargeUntyped = \sender uodata -> f $ cmiOriginateLargeUntyped sender uodata , cmiComment = \t -> f $ cmiComment t , cmiGetBalance = \addr -> f $ cmiGetBalance addr 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 @@ -10,8 +10,9 @@ , resolveAddress , refillable , newAddress + , newAddresses , newFreshAddress - , enumAliasHints + , enumAliases , signBytes , signBinary , originate @@ -51,6 +52,7 @@ , getNow , getLevel , getApproximateBlockInterval + , getMinBlockTime , runCode , branchout , offshoot @@ -110,7 +112,7 @@ 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) +import Time (KnownDivRat, Second, Time, toNum) import Unsafe qualified (fromIntegral) import Lorentz @@ -122,7 +124,7 @@ import Lorentz.Constraints import Morley.AsRPC (HasRPCRepr(..)) import Morley.Client (OperationInfo(..)) -import Morley.Micheline (Expression, FromExpression(..), toExpression) +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 @@ -132,6 +134,7 @@ 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 @@ -195,10 +198,10 @@ runIO io = do withCap getMiscCap \cap -> cmiRunIO cap io --- | Get the address of the implicit account / contract associated with the given alias hint. +-- | Get the address of the implicit account / contract associated with the given alias. resolveAddress :: (HasCallStack, MonadCleveland caps m) - => AliasHint -> m Address + => Alias -> m Address resolveAddress alias = do withCap getMiscCap \cap -> cmiResolveAddress cap alias @@ -224,25 +227,40 @@ -- * 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'. --- * Beware that if an "alias prefix" is set, it'll be prepended to the given alias hint. --- 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 <- newAddress "alias" -- > addr2 <- resolveAddress $ mkAlias "prefix.alias" -- > addr1 @== addr2 -newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAliasHint -> m Address +newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m Address newAddress alias = do - addr <- withCap getMiscCap \cap -> cmiGenKey cap alias + 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 - -- The address may exist from previous scenarios runs and have sufficient + -- Addresses may exist from previous scenarios runs and have sufficient -- balance for the sake of testing; if so, we can save some time - balance <- getBalance addr + 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 - withSender moneybag do - transferMoney addr 0.9_e6 -- 0.9 XTZ - pure addr + 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 @@ -257,26 +275,26 @@ -- > addr1 <- newFreshAddress "alias" -- > addr2 <- resolveAddress $ mkAlias "prefix.alias" -- > addr1 @== addr2 -newFreshAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAliasHint -> m Address -newFreshAddress aliasHint = do - withCap getMiscCap \cap -> cmiGenFreshKey cap aliasHint +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 'SpecificAliasHint's. +-- | Create a list of similarly named 'SpecificAlias'es. -- -- For example, -- --- >>> enumAliasHints @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil +-- >>> enumAliases @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil -- True -enumAliasHints +enumAliases :: forall n n'. (SingIPeano n, IsoNatPeano n n') - => AliasHint -> SizedList n SpecificOrDefaultAliasHint -enumAliasHints pfx = SpecificAliasHint <$> SL.generate @n (\n -> pfx <> "-" <> show 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) @@ -292,7 +310,7 @@ -- | A simplified version of the originateUntyped command. -- The contract will have 0 balance. originateUntypedSimple - :: (HasCallStack, MonadOps m) => AliasHint -> U.Value -> U.Contract -> m Address + :: (HasCallStack, MonadOps m) => Alias -> U.Value -> U.Contract -> m Address originateUntypedSimple uodName uodStorage uodContract = do let uodBalance = zeroMutez originateUntyped UntypedOriginateData{..} @@ -317,7 +335,7 @@ ( HasCallStack , MonadOps m ) - => AliasHint + => Alias -> st -> Contract cp st vd -> m (ContractHandle cp st vd) @@ -333,7 +351,7 @@ , MonadOps m , NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd ) - => AliasHint -> st -> T.Contract (T.ToT cp) (T.ToT st) -> m (ContractHandle cp st 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 @@ -352,7 +370,7 @@ -- The contract will have 0 balance. originateLargeUntypedSimple :: (HasCallStack, MonadCleveland caps m) - => AliasHint -> U.Value -> U.Contract -> m Address + => Alias -> U.Value -> U.Contract -> m Address originateLargeUntypedSimple uodName uodStorage uodContract = do let uodBalance = zeroMutez originateLargeUntyped UntypedOriginateData{..} @@ -373,7 +391,7 @@ ( HasCallStack , MonadCleveland caps m ) - => AliasHint + => Alias -> st -> Contract param st vd -> m (ContractHandle param st vd) @@ -674,6 +692,14 @@ 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. 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 @@ -27,6 +27,7 @@ , neMorleyClientEnvL , neSecretKeyL , neMoneybagAliasL + , neExplicitDataDirL -- * Error types , InternalNetworkScenarioError(..) @@ -48,9 +49,7 @@ import Lorentz qualified as L import Lorentz.Constraints.Scopes (NiceUnpackedValue, niceParameterEvi) import Morley.AsRPC (AsRPC, HasRPCRepr(..), MaybeRPC(..), TAsRPC, notesAsRPC, rpcSingIEvi) -import Morley.Client - (AddressOrAlias(..), Alias, MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, - runMorleyClientM) +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 @@ -61,16 +60,17 @@ (AppliedResult(..), BlockConstants(bcHeader), BlockHeaderNoHash(bhnhLevel, bhnhTimestamp), BlockId(..), OperationHash, OriginationScript(..), ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize)) -import Morley.Client.TezosClient.Impl qualified as Client (prefixNameM) +import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) import Morley.Client.Util qualified as Client import Morley.Micheline - (Expression, FromExpression(fromExpression), MichelinePrimitive(..), StringEncode(..), TezosInt64, - TezosMutez(..), _ExpressionPrim, _ExpressionSeq, mpaArgsL, mpaPrimL) + (Expression, MichelinePrimitive(..), StringEncode(..), TezosInt64, TezosMutez(..), + _ExpressionPrim, _ExpressionSeq, fromExpression, mpaArgsL, mpaPrimL) 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.Core as Tezos (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMulMutez, unsafeSubMutez) @@ -87,6 +87,7 @@ { neMorleyClientEnv :: MorleyClientEnv , neSecretKey :: Maybe Crypto.SecretKey , neMoneybagAlias :: Alias + , neExplicitDataDir :: Bool } makeLensesWith postfixLFields ''NetworkEnv @@ -183,17 +184,32 @@ -- | Initialize @moneybag@ address by given 'NetworkEnv' setupMoneybagAddress :: NetworkEnv -> IO Moneybag -setupMoneybagAddress (NetworkEnv env envKey envAlias) = do - storageAddress <- runMorleyClientM env $ - Client.resolveAddressMaybe (AddressAlias envAlias) - Moneybag <$> case (envKey, storageAddress) of - (Nothing, Just addr) -> pure addr - (Nothing, Nothing) -> throwM $ NoMoneybagAddress envAlias +setupMoneybagAddress NetworkEnv{..} = do + let setupEnv = neMorleyClientEnv & + if neExplicitDataDir + then id + else Client.mceTezosClientL . tceMbTezosClientDataDirL .~ Nothing + storageAddress <- runMorleyClientM setupEnv $ + Client.resolveAddressMaybe (AddressAlias neMoneybagAlias) + Moneybag <$> case (neSecretKey, storageAddress) of + (Nothing, Just addr) -> do + unless neExplicitDataDir do + ek <- runMorleyClientM setupEnv $ + Client.getSecretKey (AddressAlias neMoneybagAlias) + void $ runMorleyClientM neMorleyClientEnv $ + Client.importKey False neMoneybagAlias ek + pure addr + (Nothing, Nothing) -> throwM $ NoMoneybagAddress neMoneybagAlias (Just ek, Just sa) - | mkKeyAddress (toPublic ek) == sa -> pure sa - | otherwise -> throwM $ TwoMoneybagKeys envAlias ek sa + | mkKeyAddress (toPublic ek) == sa -> do + unless neExplicitDataDir $ void $ + runMorleyClientM neMorleyClientEnv $ + Client.importKey False neMoneybagAlias ek + pure sa + | otherwise -> throwM $ TwoMoneybagKeys neMoneybagAlias ek sa (Just ek, Nothing) -> do - runMorleyClientM env (Client.importKey False (Client.AnAlias envAlias) ek) + runMorleyClientM neMorleyClientEnv $ + Client.importKey False neMoneybagAlias ek return $ mkKeyAddress (toPublic ek) -- | Implementation that works with real network and uses @tezos-node@ @@ -222,13 +238,13 @@ -- We don't use password protected accounts in cleveland tests Client.signBytes (AddressResolved signer) Nothing hash - , cmiGenKey = \alias -> do - aliasHint <- resolveSpecificOrDefaultAliasHint alias - liftIO $ runMorleyClientM env . Client.genKey $ Client.AnAliasHint aliasHint + , cmiGenKey = \sodAlias -> do + alias <- resolveSpecificOrDefaultAlias sodAlias + liftIO $ runMorleyClientM env $ Client.genKey alias - , cmiGenFreshKey = \alias -> do - aliasHint <- resolveSpecificOrDefaultAliasHint alias - liftIO $ runMorleyClientM env . Client.genFreshKey $ Client.AnAliasHint aliasHint + , cmiGenFreshKey = \sodAlias -> do + alias <- resolveSpecificOrDefaultAlias sodAlias + liftIO $ runMorleyClientM env $ Client.genFreshKey alias , cmiGetBalance = getBalanceHelper , cmiGetChainId = liftIO $ runMorleyClientM env Client.getChainId @@ -236,8 +252,8 @@ , cmiThrow = throwM , cmiMarkAddressRefillable = setAddressRefillable , cmiRegisterDelegate = \addr -> liftIO $ runMorleyClientM env $ do - alias <- Client.getAlias (Client.AddressResolved addr) - Client.registerDelegate (Client.AnAlias alias) Nothing + alias <- Client.getAlias (AddressResolved addr) + Client.registerDelegate alias Nothing , cmiComment = comment , cmiEmulatedImpl = pure Nothing , .. @@ -300,10 +316,8 @@ , indentF 2 $ build err ] - cmiResolveAddress :: Client.AliasHint -> ClientM Address - cmiResolveAddress = liftIO . runMorleyClientM env . - (Client.resolveAddress . AddressAlias <=< Client.prefixNameM) . - Client.AnAliasHint + cmiResolveAddress :: Alias -> ClientM Address + cmiResolveAddress = liftIO . runMorleyClientM env . Client.resolveAddress . AddressAlias cmiGetPublicKey :: Address -> ClientM PublicKey cmiGetPublicKey = liftIO . runMorleyClientM env . Client.getPublicKey . AddressResolved @@ -372,7 +386,7 @@ 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 rcBalance rcSource) = + cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcLevel rcNow rcBalance rcSource) = liftIO $ runMorleyClientM env do -- Pattern match on the contract constructor to reveal -- a proof of `NiceParameter cp` and `NiceStorage st` @@ -390,6 +404,8 @@ , rcpAmount = rcAmount , rcpBalance = rcBalance , rcpSource = rcSource + , rcpLevel = rcLevel + , rcpNow = rcNow , rcpSender = Just sender } \\ L.niceParameterEvi @cp @@ -569,7 +585,7 @@ :: MorleyClientEnv -> Sender -> ( Bool - -> AliasHint + -> Alias -> AddressOrAlias -> Mutez -> U.Contract @@ -590,14 +606,13 @@ revealKeyUnlessRevealed env sender runMorleyClientM env originationScenario -resolveSpecificOrDefaultAliasHint :: SpecificOrDefaultAliasHint -> ClientM AliasHint -resolveSpecificOrDefaultAliasHint (SpecificAliasHint aliasHint) = - return aliasHint -resolveSpecificOrDefaultAliasHint (DefaultAliasHint) = do +resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM Alias +resolveSpecificOrDefaultAlias (SpecificAlias alias) = pure alias +resolveSpecificOrDefaultAlias (DefaultAlias) = do stateRef <- ask ist@ClientState{csDefaultAliasCounter=DefaultAliasCounter counter} <- readIORef stateRef writeIORef stateRef ist{ csDefaultAliasCounter = DefaultAliasCounter $ counter + 1 } - return $ mkDefaultAlias counter + pure $ mkDefaultAlias counter setAddressRefillable :: Address -> ClientM () setAddressRefillable addr = do 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 @@ -28,17 +28,20 @@ , psRefillableAddresses , psNow , psLevel + , psMinBlockTime , psGState , psContractsNames ) where import Control.Lens (assign, at, 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)) @@ -50,13 +53,13 @@ import Lorentz.Entrypoints (HasEntrypointArg, TrustEpName(..), useHasEntrypointArg) import Morley.AsRPC (HasRPCRepr(AsRPC), MaybeRPC(..), notesAsRPC, replaceBigMapIds, rpcStorageScopeEvi, valueAsRPC) -import Morley.Client (Alias, OperationInfo(..), mkAlias) -import Morley.Client.TezosClient.Types (unsafeCoerceAliasHintToAlias, unsafeGetAliasHintText) +import Morley.Client (OperationInfo(..)) import Morley.Michelson.Interpret (InterpretError(..), InterpretResult(..), MichelsonFailed(..), MichelsonFailureWithStack(..)) import Morley.Michelson.Runtime hiding (ExecutorOp(..), transfer) import Morley.Michelson.Runtime qualified as Runtime (ExecutorOp(..)) -import Morley.Michelson.Runtime.Dummy (dummyLevel, dummyMaxSteps, dummyNow, dummyOrigination) +import Morley.Michelson.Runtime.Dummy + (dummyLevel, dummyMaxSteps, dummyMinBlockTime, dummyNow, dummyOrigination) import Morley.Michelson.Runtime.GState (GState(..), asBalance, genesisAddress, genesisSecretKey, gsAddressesL, gsChainIdL, gsCounterL, gsVotingPowersL, initGState) @@ -68,6 +71,7 @@ import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..)) import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address (Address, detGenKeyAddress) +import Morley.Tezos.Address.Alias (Alias(..)) import Morley.Tezos.Core (Timestamp, timestampPlusSeconds, unsafeSubMutez, zeroMutez) import Morley.Tezos.Crypto (SecretKey(..), detSecretKey, sign, toPublic) import Morley.Util.MismatchError @@ -84,11 +88,12 @@ , _psRefillableAddresses :: Set Address , _psNow :: Timestamp , _psLevel :: Natural + , _psMinBlockTime :: Natural , _psGState :: GState , _psContractsNames :: Map Address Text -- ^ Map from contracts addresses to human-readable names. } - deriving stock Show + deriving stock (Eq, Show) instance MonadState PureState PureM where get = ask >>= readIORef @@ -110,7 +115,7 @@ { adAddress :: Address , adMbSecretKey :: Maybe SecretKey } - deriving stock Show + deriving stock (Eq, Show) data TestError = UnexpectedTypeCheckError TCError @@ -140,13 +145,8 @@ instance Exception TestError where displayException = pretty --- In this implementation we do not prefix aliases, so 'Alias' and 'AliasHint' --- are identical and conversions between them are safe. -hintToAlias :: AliasHint -> Alias -hintToAlias = unsafeCoerceAliasHintToAlias - moneybagAlias :: Alias -moneybagAlias = mkAlias "moneybag" +moneybagAlias = Alias "moneybag" runEmulatedT :: Alias -> EmulatedT PureM a -> IO a runEmulatedT moneybagAlias' scenario = @@ -235,16 +235,16 @@ "Given address doesn't have known associated secret key: " <> build alias Just sk -> liftIO $ sign sk bs - , cmiGenKey = \alias -> do - aliasHint <- resolveSpecificOrDefaultAliasHint alias - smartGenKey Nothing aliasHint + , cmiGenKey = \sodAlias -> do + alias <- resolveSpecificOrDefaultAlias sodAlias + smartGenKey Nothing alias , cmiGenFreshKey = - \alias -> do - aliasHint <- resolveSpecificOrDefaultAliasHint alias + \sodAlias -> do + alias <- resolveSpecificOrDefaultAlias sodAlias aliases <- use psAliases - let mbSk = Map.lookup (hintToAlias aliasHint) aliases - smartGenKey (adAddress <$> mbSk) aliasHint + let mbSk = Map.lookup alias aliases + smartGenKey (adAddress <$> mbSk) alias , cmiOriginateLargeUntyped = originateUntyped @@ -274,7 +274,7 @@ , cmiGetNow = use psNow , cmiGetLevel = use psLevel - , cmiGetApproximateBlockInterval = pure $ sec 1 + , cmiGetApproximateBlockInterval = sec . (% 1) <$> use psMinBlockTime , cmiAttempt = try , cmiThrow = throwM , cmiMarkAddressRefillable = setAddressRefillable @@ -358,8 +358,8 @@ (\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) + Refl <- requireEq @k' @k (Ap . Left . UnexpectedBigMapKeyType) + Refl <- requireEq @v' @v (Ap . Left . UnexpectedBigMapValueType) pure [v] _ -> Ap $ Right [] ) @@ -393,17 +393,17 @@ -- 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 -> AliasHint -> PureM Address - smartGenKey existingAddr aliasHint@(unsafeGetAliasHintText -> aliasTxt) = + smartGenKey :: Maybe Address -> Alias -> PureM Address + smartGenKey existingAddr alias@(Alias aliasTxt) = let seed = maybe aliasTxt (mappend aliasTxt . pretty) existingAddr sk = detSecretKey (encodeUtf8 seed) addr = detGenKeyAddress (encodeUtf8 seed) - in saveAlias aliasHint addr $ Just sk + in saveAlias alias addr $ Just sk - resolveSpecificOrDefaultAliasHint (SpecificAliasHint aliasHint) = - return aliasHint - resolveSpecificOrDefaultAliasHint (DefaultAliasHint) = do + resolveSpecificOrDefaultAlias (SpecificAlias alias) = + return alias + resolveSpecificOrDefaultAlias DefaultAlias = do DefaultAliasCounter counter <- use psDefaultAliasesCounter psDefaultAliasesCounter %= \(DefaultAliasCounter i) -> DefaultAliasCounter $ i + 1 return $ mkDefaultAlias counter @@ -411,13 +411,15 @@ 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 rcBalance rcSource) = do + cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter 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 - + (now, level) <- use $ psNow `lensProduct` psLevel + psNow %= maybe id const rcNow + psLevel %= maybe id const rcLevel res <- interpret do counter0 <- use $ esGState . gsCounterL contractAddr <- @@ -441,6 +443,8 @@ } } pure contractAddr + psNow .= now + psLevel .= level case res of Left executorError -> throwEE executorError Right (executorRes, contractAddr) -> do @@ -467,9 +471,9 @@ GState{..} <- use psGState return $ maybe zeroMutez asBalance $ Map.lookup addr gsAddresses -saveAlias :: AliasHint -> Address -> Maybe SecretKey -> PureM Address +saveAlias :: Alias -> Address -> Maybe SecretKey -> PureM Address saveAlias name addr mbSk = do - psAliases %= Map.insert (hintToAlias name) (AliasData addr mbSk) + psAliases %= Map.insert name (AliasData addr mbSk) pure addr exceptionHandler :: PureM a -> PureM a @@ -484,7 +488,7 @@ EEUnexpectedParameterType addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter EEInterpreterFailed addr (InterpretError (MichelsonFailureWithStack{..}, _)) -> case mfwsFailed of - MichelsonFailedWith val -> return $ TransferFailure (addrNameToAddr addr) $ FailedWith (EOTVTypedValue val) (Just mfwsInstrCallStack) + 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 @@ -516,8 +520,8 @@ "Expected address to be contract with storage, but it's a simple address: " <> pretty addr Nothing -> unknownAddress addr -resolve :: AliasHint -> PureM Address -resolve (hintToAlias -> name) = do +resolve :: Alias -> PureM Address +resolve name = do aliases <- use psAliases let maybeAddress = Map.lookup name aliases maybe (unknownAlias name) (pure . adAddress) maybeAddress @@ -560,6 +564,7 @@ , _psNow = dummyNow , _psLevel = dummyLevel , _psGState = initGState + , _psMinBlockTime = dummyMinBlockTime , _psContractsNames = Map.empty } @@ -645,7 +650,8 @@ now <- use psNow level <- use psLevel gState <- use psGState - pure $ runExecutorM now level dummyMaxSteps gState action + minBlockTime <- use psMinBlockTime + pure $ runExecutorM now level minBlockTime dummyMaxSteps gState action addrToAddrName :: Address -> PureState -> AddressName addrToAddrName addr iState = 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 @@ -7,8 +7,11 @@ , scenarioEmulated , withInitialNow , withInitialLevel + , withMinBlockTime + , withChainId ) where +import Morley.Michelson.Runtime.GState (gsChainIdL) import Morley.Tezos.Core qualified as TC import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Pure @@ -39,8 +42,8 @@ -- | Use with an emulated 'Scenario' to configure the initial @now@ value in tests. -- -- Example : --- > withInitialNow (Timestamp 10000000) $ testScenarioOnEmulator "Testname" $ scenarioEmulated $ tests --- > withInitialNow (Timestamp 10000000) $ testScenarioOnEmulator "Testname" $ scenario $ tests +-- > testScenarioOnEmulator "Testname" $ withInitialNow (Timestamp 10000000) $ scenarioEmulated $ tests +-- > testScenarioOnEmulator "Testname" $ withInitialNow (Timestamp 10000000) $ scenario $ tests withInitialNow :: TC.Timestamp -> Scenario PureM @@ -53,3 +56,17 @@ -> 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 +withMinBlockTime = withModifiedState . set psMinBlockTime + +-- | Similar to 'withInitialNow' but for the chain id +withChainId + :: TC.ChainId + -> 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 @@ -1,14 +1,9 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA -{-# OPTIONS_GHC -Wno-deprecations #-} - module Test.Cleveland.Lorentz ( -- * Importing a contract - specWithContract - , specWithTypedContract - , specWithUntypedContract - , importContract + importContract , embedContract , embedContractM @@ -18,10 +13,6 @@ , embedValueM -- * Unit testing - , Michelson.ContractReturn - , Michelson.ContractPropValidator - , Michelson.contractProp - , Michelson.contractPropVal , testContractCoversEntrypointsT , testContractMatchesEntrypointsT , testContractCoversEntrypoints @@ -56,9 +47,6 @@ -- 'meanTimeUpperBoundProp' and 'meanTimeUpperBoundPropNF'. , mcs, ms, sec, minute - -- * Dummy values - , dummyContractEnv - -- * Special contracts for testing , contractConsumer ) where @@ -68,8 +56,4 @@ import Test.Cleveland.Lorentz.Entrypoints import Test.Cleveland.Lorentz.Import import Test.Cleveland.Lorentz.Types -import Test.Cleveland.Michelson.Dummy -import Test.Cleveland.Michelson.Import - (specWithContract, specWithTypedContract, specWithUntypedContract) -import Test.Cleveland.Michelson.Unit qualified as Michelson import Test.Cleveland.Util diff --git a/src/Test/Cleveland/Lorentz/Import.hs b/src/Test/Cleveland/Lorentz/Import.hs --- a/src/Test/Cleveland/Lorentz/Import.hs +++ b/src/Test/Cleveland/Lorentz/Import.hs @@ -1,14 +1,10 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Functions to import contracts to be used in tests. module Test.Cleveland.Lorentz.Import ( -- * Read, parse, typecheck contracts importContract - , importContractExt , embedContract , embedContractM , M.ContractReadError (..) @@ -31,7 +27,6 @@ import Lorentz.Constraints import Lorentz.ViewBase import Morley.Michelson.Parser.Types (MichelsonSource(..)) -import Morley.Michelson.Runtime.Import qualified as MR import Morley.Michelson.Typed qualified as T import Morley.Util.Markdown import Test.Cleveland.Michelson.Import qualified as M @@ -43,7 +38,7 @@ -> T.Contract (T.ToT cp) (T.ToT st) -> Either L.ViewInterfaceMatchError (Contract cp st vd) mkImportedContract path cMichelsonContract = verifyingViews Contract - { cDocumentedCode = + { cDocumentedCode = L.ContractCode $ L.fakeCoercing $ L.docGroup "Imported contract" $ L.doc $ L.DDescription $ "Read from " <> mdTicked (build path) @@ -67,21 +62,6 @@ importContract file = either throwM pure . mkImportedContract file =<< M.importContract file --- | Import contract from a given 'FilePath', with deprecated Morley extensions. --- --- In this and similar functions, parameter and storage types must exactly match --- the ones in the contract, while for views this is not necessary. Only --- make sure that all views beyond @vd@ type are present in the contract; @()@ --- always works as views descriptor of the contract. -importContractExt - :: forall cp st vd. - (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) - => FilePath -> IO (Contract cp st vd) -importContractExt file = - either throwM pure . mkImportedContract file =<< MR.importUsing MR.readContractExt file - -{-# DEPRECATED importContractExt "Morley extensions are deprecated" #-} - {- | Import a contract at compile time assuming its expected type is known. Use it like: @@ -98,7 +78,7 @@ embedContract :: forall cp st vd. (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) - => FilePath -> TH.TExpQ (Contract cp st vd) + => FilePath -> TH.Code TH.Q (Contract cp st vd) embedContract path = embedContractM (pure path) -- | Version of 'embedContract' that accepts a filepath constructor in IO. @@ -110,8 +90,8 @@ embedContractM :: forall cp st vd. (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd, DemoteViewsDescriptor vd) - => IO FilePath -> TH.TExpQ (Contract cp st vd) -embedContractM pathM = do + => IO FilePath -> TH.Code TH.Q (Contract cp st vd) +embedContractM pathM = TH.Code do path <- TH.runIO pathM contract <- M.embedTextFile path case M.readContract @(T.ToT cp) @(T.ToT st) (MSFile path) contract of @@ -123,7 +103,8 @@ -- Emit a compiler error if there are issues with constructing contract fail (pretty e) -- Emit a haskell expression that reads the contract. - Right _ -> [|| + Right _ -> TH.examineCode + [|| -- Note: it's ok to use `unsafe` here, because we just proved that the contract -- can be parsed+typechecked. contract @@ -144,7 +125,7 @@ See also the note in "Test.Cleveland.Lorentz.Import#embedDepends" -} -embedValue :: forall a . T.IsoValue a => FilePath -> TH.TExpQ a +embedValue :: forall a . T.IsoValue a => FilePath -> TH.Code TH.Q a embedValue = embedValueM . pure -- | A variant of 'embedValue' that accepts 'FilePath' in 'IO'. @@ -152,13 +133,13 @@ -- Can be useful when 'FilePath' depends on the environment. -- -- See also the note in "Test.Cleveland.Lorentz.Import#embedDepends" -embedValueM :: forall a . T.IsoValue a => IO FilePath -> TH.TExpQ a -embedValueM pathM = do +embedValueM :: forall a . T.IsoValue a => IO FilePath -> TH.Code TH.Q a +embedValueM pathM = TH.Code do path <- TH.runIO pathM rawValue <- M.embedTextFile path case M.readValue @(T.ToT a) (MSFile path) rawValue of Left e -> fail (pretty e) - Right _ -> + Right _ -> TH.examineCode [|| -- Note: it's ok to use `error` here, because we just proved that the value -- can be parsed+typechecked. diff --git a/src/Test/Cleveland/Michelson.hs b/src/Test/Cleveland/Michelson.hs --- a/src/Test/Cleveland/Michelson.hs +++ b/src/Test/Cleveland/Michelson.hs @@ -1,8 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Module containing some utilities for testing Michelson contracts using -- Haskell testing frameworks. -- It's Morley testing EDSL. @@ -13,10 +11,7 @@ module Test.Cleveland.Michelson ( -- * Importing a contract - specWithContract - , specWithTypedContract - , specWithUntypedContract - , testTreesWithContract + testTreesWithContract , testTreesWithUntypedContract , testTreesWithTypedContract , concatTestTrees @@ -25,13 +20,6 @@ , importUntypedContract -- * Unit testing - , ContractReturn - , ContractPropValidator - , contractProp - , contractPropVal - , validateSuccess - , validateStorageIs - , validateMichelsonFailsWith , testContractCoversEntrypoints , testContractMatchesEntrypoints @@ -53,14 +41,9 @@ , runDocTests , testDocBasic , excludeDocTests - - -- * Dummy values - , dummyContractEnv ) where import Test.Cleveland.Doc.Michelson -import Test.Cleveland.Michelson.Dummy import Test.Cleveland.Michelson.Entrypoints import Test.Cleveland.Michelson.Import -import Test.Cleveland.Michelson.Unit import Test.Cleveland.Util diff --git a/src/Test/Cleveland/Michelson/Dummy.hs b/src/Test/Cleveland/Michelson/Dummy.hs deleted file mode 100644 --- a/src/Test/Cleveland/Michelson/Dummy.hs +++ /dev/null @@ -1,19 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - --- | Dummy data to be used in tests where it's not essential. - -module Test.Cleveland.Michelson.Dummy - {-# DEPRECATED "Use Morley.Michelson.Runtime.Dummy or Morley.Tezos.Core directly instead" #-} - ( dummyNow - , dummyLevel - , dummyMaxSteps - , dummyBigMapCounter - , dummyContractEnv - , dummyGlobalCounter - , dummyOrigination - , dummyChainId - ) where - -import Morley.Michelson.Runtime.Dummy -import Morley.Tezos.Core diff --git a/src/Test/Cleveland/Michelson/Import.hs b/src/Test/Cleveland/Michelson/Import.hs --- a/src/Test/Cleveland/Michelson/Import.hs +++ b/src/Test/Cleveland/Michelson/Import.hs @@ -1,9 +1,6 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- TODO [#712]: Remove this next major release -{-# OPTIONS_GHC -Wno-deprecations #-} - -- | Functions to import contracts to be used in tests. module Test.Cleveland.Michelson.Import @@ -30,15 +27,8 @@ , testTreesWithContract , testTreesWithTypedContract , testTreesWithUntypedContract - , testTreesWithUntypedContractExt - , testTreesWithTypedContractExt , concatTestTrees - -- * HSpec helpers - , specWithContract - , specWithTypedContract - , specWithUntypedContract - -- * Helpers , embedTextFile ) where @@ -50,7 +40,6 @@ import Language.Haskell.TH qualified as TH import Language.Haskell.TH.Syntax (qAddDependentFile) import Test.HUnit (assertFailure) -import Test.Hspec (Spec, describe, expectationFailure, it, runIO) import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase) @@ -58,21 +47,6 @@ import Morley.Michelson.Typed (Contract, SingI) import Morley.Michelson.Untyped qualified as U -{-# DEPRECATED - specWithContract - , specWithTypedContract - , specWithUntypedContract - - "Use testTreesWithContract &c. instead" - #-} - -{-# DEPRECATED - testTreesWithUntypedContractExt - , testTreesWithTypedContractExt - - "Morley extensions are deprecated" - #-} - ---------------------------------------------------------------------------- -- tasty helpers ---------------------------------------------------------------------------- @@ -95,14 +69,6 @@ testTreesWithUntypedContract = testTreesWithContractImpl importUntypedContract --- | Like 'testTreesWithContract' but supplies only untyped contract --- with Morley extensions (deprecated). -testTreesWithUntypedContractExt - :: HasCallStack - => FilePath -> (U.Contract -> IO [TestTree]) -> IO [TestTree] -testTreesWithUntypedContractExt = - testTreesWithContractImpl (importUsing readUntypedContractExt) - -- | Like 'testTreesWithContract' but supplies only typed contract. testTreesWithTypedContract :: (Each '[SingI] [cp, st], HasCallStack) @@ -110,14 +76,6 @@ testTreesWithTypedContract = testTreesWithContractImpl importContract --- | Like 'testTreesWithContract' but supplies only typed contract --- with Morley extensions (deprecated). -testTreesWithTypedContractExt - :: (Each '[SingI] [cp, st], HasCallStack) - => FilePath -> (Contract cp st -> IO [TestTree]) -> IO [TestTree] -testTreesWithTypedContractExt = - testTreesWithContractImpl (importUsing readContractExt) - testTreesWithContractImpl :: HasCallStack => (FilePath -> IO contract) @@ -136,40 +94,6 @@ concatTestTrees = fmap concat . sequence ---------------------------------------------------------------------------- --- hspec helpers ----------------------------------------------------------------------------- - --- | Import contract and use it in the spec. Both versions of contract are --- passed to the callback function (untyped and typed). --- --- If contract's import fails, a spec with single failing expectation --- will be generated (so tests will likely run unexceptionally, but a failing --- result will notify about problem). -specWithContract - :: (Each '[SingI] [cp, st], HasCallStack) - => FilePath -> (Contract cp st -> Spec) -> Spec -specWithContract = specWithContractImpl importContract - --- | A version of 'specWithContract' which passes only the typed --- representation of the contract. -specWithTypedContract - :: (Each '[SingI] [cp, st], HasCallStack) - => FilePath -> (Contract cp st -> Spec) -> Spec -specWithTypedContract = specWithContractImpl importContract - -specWithUntypedContract :: FilePath -> (U.Contract -> Spec) -> Spec -specWithUntypedContract = specWithContractImpl importUntypedContract - -specWithContractImpl - :: HasCallStack - => (FilePath -> IO contract) -> FilePath -> (contract -> Spec) -> Spec -specWithContractImpl doImport file execSpec = - either errorSpec (describe ("Test contract " <> file) . execSpec) - =<< runIO (saferImport doImport file) - where - errorSpec = it ("Import contract " <> file) . expectationFailure - ----------------------------------------------------------------------------- -- Helpers ---------------------------------------------------------------------------- @@ -208,7 +132,7 @@ -} embedContract :: forall cp st. (SingI cp, SingI st) - => FilePath -> TH.TExpQ (Contract cp st) + => FilePath -> TH.Code TH.Q (Contract cp st) embedContract path = embedContractM (pure path) -- | Version of 'embedContract' that accepts a filepath constructor in IO. @@ -217,15 +141,15 @@ -- user input. embedContractM :: forall cp st. (SingI cp, SingI st) - => IO FilePath -> TH.TExpQ (Contract cp st) -embedContractM pathM = do + => IO FilePath -> TH.Code TH.Q (Contract cp st) +embedContractM pathM = TH.Code do path <- TH.runIO pathM contract <- embedTextFile path case readContract @cp @st (MSFile path) contract of Left e -> -- Emit a compiler error if the contract cannot be read. fail (pretty e) - Right _ -> + Right _ -> TH.examineCode -- Emit a haskell expression that reads the contract. [|| -- Note: it's ok to use `unsafe` here, because we just proved that the contrPact diff --git a/src/Test/Cleveland/Michelson/Unit.hs b/src/Test/Cleveland/Michelson/Unit.hs deleted file mode 100644 --- a/src/Test/Cleveland/Michelson/Unit.hs +++ /dev/null @@ -1,108 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | Utility functions for unit testing. - -module Test.Cleveland.Michelson.Unit - {-# DEPRECATED "Use the new Test.Cleveland interface instead. Entrypoint utilities\ - \ are moved to Test.Cleveland.Michelson.Entrypoints" #-} - ( ContractReturn - , ContractPropValidator - , EPMismatch - , contractProp - , contractPropVal - , validateSuccess - , validateStorageIs - , validateMichelsonFailsWith - ) where - -import Data.Constraint ((\\)) -import Fmt ((+|), (|+)) -import Test.HUnit (Assertion, assertFailure, (@?=)) -import Test.Hspec.Expectations (Expectation, shouldBe, shouldSatisfy) - -import Lorentz.Constraints.Scopes (NiceConstant, niceConstantEvi) -import Morley.Michelson.Interpret - (ContractEnv, ContractReturn, MichelsonFailed(..), MichelsonFailureWithStack(..), interpret) -import Morley.Michelson.Typed (Contract, IsoValue(..), ToT) -import Morley.Michelson.Typed qualified as T -import Test.Cleveland.Michelson.Dummy (dummyBigMapCounter, dummyGlobalCounter) -import Test.Cleveland.Michelson.Internal.Entrypoints - --- | Type for contract execution validation. --- --- It's a function which is supplied with contract execution output --- (failure or new storage with operation list). --- --- Function returns a property which type is designated by type variable @prop@ --- and might be @Test.QuickCheck.Property@ or 'Expectation' --- or anything else relevant. -type ContractPropValidator st prop = ContractReturn st -> prop - --- | ContractCode's property tester against given input. --- Takes contract environment, initial storage and parameter, --- interprets contract on this input and invokes validation function. -contractProp - :: ( IsoValue param, IsoValue storage - , ToT param ~ cp, ToT storage ~ st - , T.ParameterScope cp - ) - => Contract cp st - -> ContractPropValidator st prop - -> ContractEnv - -> param - -> storage - -> prop -contractProp instr check env param initSt = - contractPropVal instr check env (toVal param) (toVal initSt) - --- | Version of 'contractProp' which takes 'T.Value' as arguments instead --- of regular Haskell values. --- --- This function assumes that contract has no explicit default entrypoints --- and you always have to construct parameter manually; if you need to test --- contract calling specific entrypoints, use integrational testing defined --- by "Test.Cleveland.Michelson.Integrational" module. -contractPropVal - :: (T.ParameterScope cp) - => Contract cp st - -> ContractPropValidator st prop - -> ContractEnv - -> T.Value cp - -> T.Value st - -> prop -contractPropVal instr check env param initSt = - check $ interpret instr T.unsafeEpcCallRoot param initSt dummyGlobalCounter dummyBigMapCounter env - ----------------------------------------------------------------------------- --- Validators ----------------------------------------------------------------------------- - --- | 'ContractPropValidator' that expects a successful termination. -validateSuccess :: HasCallStack => ContractPropValidator st Expectation -validateSuccess (res, _) = res `shouldSatisfy` isRight - --- | 'ContractPropValidator' that expects contract execution to --- succeed and update storage to a particular constant value. -validateStorageIs - :: IsoValue st - => st -> ContractPropValidator (ToT st) Assertion -validateStorageIs expected (res, _) = - case res of - Left err -> - assertFailure $ "Unexpected interpretation failure: " +| err |+ "" - Right (_ops, got) -> - got @?= toVal expected - --- | 'ContractPropValidator' that expects a given failure. -validateMichelsonFailsWith - :: forall v st. NiceConstant v - => v -> ContractPropValidator st Expectation -validateMichelsonFailsWith v (res, _) = case res of - Right _ -> assertFailure $ - "contract was expected to fail with " +| expected |+ " but didn't." - Left MichelsonFailureWithStack{..} -> mfwsFailed `shouldBe` expected - where - expected = MichelsonFailedWith (toVal v) \\ niceConstantEvi @v diff --git a/src/Test/Cleveland/Tasty.hs b/src/Test/Cleveland/Tasty.hs --- a/src/Test/Cleveland/Tasty.hs +++ b/src/Test/Cleveland/Tasty.hs @@ -57,7 +57,6 @@ -- * Reading/setting options , modifyNetworkEnv - , setAliasPrefix ) where import Test.Cleveland.Tasty.Internal 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 @@ -20,7 +20,6 @@ -- * Reading/setting options , modifyNetworkEnv - , setAliasPrefix -- * Internals , RunOnNetwork(..) @@ -39,11 +38,13 @@ import Data.Char qualified as C import Data.Tagged (Tagged(Tagged)) import Fmt (pretty) +import System.Directory (removeDirectoryRecursive) import System.Environment (lookupEnv) +import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) import System.IO.Unsafe qualified as Unsafe import Test.Tasty (TestName, adjustOption, askOption, defaultIngredients, defaultMainWithIngredients, - includingOptions, localOption, testGroup) + includingOptions, localOption, testGroup, withResource) import Test.Tasty.Ingredients (Ingredient) import Test.Tasty.Options (IsOption(..), OptionSet, lookupOption) import Test.Tasty.Patterns.Types as Tasty (Expr(..)) @@ -51,15 +52,15 @@ import Test.Tasty.Runners (Result(..), TestPattern(..), TestTree(AskOptions)) import Morley.Client (MorleyClientConfig(..), mceTezosClientL, mkMorleyClientEnv) -import Morley.Client.TezosClient.Types (tceAliasPrefixL) +import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) import Test.Cleveland.Internal.Client as Client (ClientM, NetworkEnv(..), neMorleyClientEnvL, runClevelandT) import Test.Cleveland.Internal.Exceptions (WithCallStack(WithCallStack)) import Test.Cleveland.Internal.Pure as Pure (PureM, runClevelandT, runEmulatedT) import Test.Cleveland.Internal.Scenario import Test.Cleveland.Tasty.Internal.Options - (AliasPrefixOpt(..), ContextLinesOpt(..), DataDirOpt(..), EndpointOpt(..), MoneybagAliasOpt(..), - PathOpt(..), RunModeOpt(..), SecretKeyOpt(..), VerboseOpt(..), clevelandOptions) + (ContextLinesOpt(..), DataDirOpt(..), EndpointOpt(..), MoneybagAliasOpt(..), PathOpt(..), + RunModeOpt(..), SecretKeyOpt(..), VerboseOpt(..), clevelandOptions) import Test.Cleveland.Tasty.Internal.Report (formatError) -- | A name that we use to tag all tests that run on the network. @@ -163,7 +164,8 @@ -- registers the necessary command line options/environment variables to configure -- "Test.Cleveland". clevelandMain :: TestTree -> IO () -clevelandMain = clevelandMainWithIngredients defaultIngredients . loadTastyEnv +clevelandMain = + clevelandMainWithIngredients defaultIngredients . loadTastyEnv -- | Similar to 'defaultMainWithIngredients', but also preloads 'TastyEnv' and -- registers the necessary command line options/environment variables to configure @@ -173,7 +175,7 @@ ciSwitch <- withinCI defaultMainWithIngredients (clevelandIngredients <> ingredients) - (loadOptionSwitcher ciSwitch . loadTastyEnv $ tree) + (loadOptionSwitcher ciSwitch . setupTempDatadirIfNeeded . loadTastyEnv $ tree) -- | A list with all the ingredients necessary to configure "Test.Cleveland". -- @@ -196,7 +198,6 @@ tastyEnvFromOpts :: OptionSet -> TastyEnv tastyEnvFromOpts optionSet = let - AliasPrefixOpt aliasPrefix = lookupOption optionSet EndpointOpt endpoint = lookupOption optionSet PathOpt path = lookupOption optionSet DataDirOpt dataDir = lookupOption optionSet @@ -210,8 +211,7 @@ -- Otherwise, load it. TastyEnvOpt Nothing -> mkTastyEnv $ do morleyClientEnv <- mkMorleyClientEnv MorleyClientConfig - { mccAliasPrefix = aliasPrefix - , mccEndpointUrl = endpoint + { mccEndpointUrl = endpoint , mccTezosClientPath = path , mccMbTezosClientDataDir = dataDir , mccVerbosity = verbosity @@ -221,6 +221,7 @@ { neMorleyClientEnv = morleyClientEnv , neSecretKey = sk , neMoneybagAlias = origAlias + , neExplicitDataDir = isJust dataDir } -- | Heuristics to check whether we are running within CI. @@ -262,13 +263,6 @@ in localOption (TastyEnvOpt $ Just (mapTastyEnv f tastyEnv)) $ tree --- | Overrides the alias prefix (parsed from @--cleveland-alias-prefix@ or @TASTY_CLEVELAND_ALIAS_PREFIX@) --- for all the tests in the given test tree. -setAliasPrefix :: Text -> TestTree -> TestTree -setAliasPrefix aliasPrefix tree = - modifyNetworkEnv (neMorleyClientEnvL.mceTezosClientL.tceAliasPrefixL .~ Just aliasPrefix) $ - tree - ---------------------------------------------------------------------------- -- Preload TastyEnv ---------------------------------------------------------------------------- @@ -334,7 +328,7 @@ mkTastyEnv mkEnv = TastyEnv { useNetworkEnv = \cont -> - withMVar lock $ \() -> do + withMVar lock $ const do env <- memoMkEnv cont env } @@ -345,6 +339,23 @@ -- -- We're only using it here to initialize an 'MVar', so it /should/ be safe 🤞 memoMkEnv = Unsafe.unsafePerformIO $ memoize mkEnv + +setupTempDatadirIfNeeded :: TestTree -> TestTree +setupTempDatadirIfNeeded tree = askOption \case + DataDirOpt Just{} -> tree + DataDirOpt Nothing -> + -- NB: 'withResource' memoizes the resource, so it's pretty safe to + -- 'unsafePerformIO' it -- it won't be created twice at least, and + -- will be freed after the test tree is done running. + withResource initTempDir removeDirectoryRecursive \iodir -> + modifyNetworkEnv (neMbTezosClientDataDirL .~ Just (Unsafe.unsafePerformIO iodir)) tree + where + initTempDir = do + tmpdir <- getCanonicalTemporaryDirectory + createTempDirectory tmpdir "cleveland" + neMbTezosClientDataDirL :: Lens' NetworkEnv (Maybe FilePath) + neMbTezosClientDataDirL = + neMorleyClientEnvL . mceTezosClientL . tceMbTezosClientDataDirL mapTastyEnv :: (NetworkEnv -> NetworkEnv) -> (TastyEnv -> TastyEnv) mapTastyEnv g (TastyEnv f) = 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 @@ -7,7 +7,6 @@ -- They're used to configure "Test.Cleveland". module Test.Cleveland.Tasty.Internal.Options ( clevelandOptions - , AliasPrefixOpt(..) , MoneybagAliasOpt(..) , EndpointOpt(..) , PathOpt(..) @@ -25,8 +24,8 @@ import Servant.Client.Core (BaseUrl(..)) import Test.Tasty.Options as Tasty (IsOption(..), OptionDescription(Option), safeRead) -import Morley.Client (Alias, mkAlias) import Morley.Client.Parser (baseUrlReader) +import Morley.Tezos.Address.Alias (Alias(..)) import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.CLI (HasCLReader(getMetavar, getReader)) @@ -49,8 +48,7 @@ -- | A list with all the options needed to configure "Test.Cleveland". clevelandOptions :: [OptionDescription] clevelandOptions = - [ Tasty.Option (Proxy @AliasPrefixOpt) - , Tasty.Option (Proxy @EndpointOpt) + [ Tasty.Option (Proxy @EndpointOpt) , Tasty.Option (Proxy @PathOpt) , Tasty.Option (Proxy @DataDirOpt) , Tasty.Option (Proxy @VerboseOpt) @@ -64,17 +62,6 @@ -- Morley Client options ---------------------------------------------------------------------------- -newtype AliasPrefixOpt = AliasPrefixOpt (Maybe Text) - deriving stock (Show, Eq) - -instance IsOption AliasPrefixOpt where - defaultValue = AliasPrefixOpt Nothing - optionName = "cleveland-alias-prefix" - optionHelp = "[Test.Cleveland] A prefix to prepend to every alias created " <> - "with 'newAddress' or 'newFreshAddress'." - parseValue = mkParseValue (AliasPrefixOpt . Just) - optionCLParser = mkOptionParser (AliasPrefixOpt . Just) Nothing - -- | Morley Client option specifying endpoint URL of the Tezos node. newtype EndpointOpt = EndpointOpt (Maybe BaseUrl) deriving stock (Show, Eq) @@ -152,11 +139,11 @@ instance IsOption MoneybagAliasOpt where - defaultValue = MoneybagAliasOpt $ mkAlias "moneybag" + defaultValue = MoneybagAliasOpt $ Alias "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 . mkAlias . fromString + parseValue = Just . MoneybagAliasOpt . Alias . fromString data RunModeOpt = RunAllMode 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 @@ -32,6 +32,7 @@ import Morley.Michelson.Typed (convertContract, untypeValue) import Morley.Tezos.Address (ta) import Morley.Util.Interpolate (lit) +import Morley.Util.SizedList.Types import Test.Cleveland import Test.Cleveland.Internal.Client (neMorleyClientEnvL) import Test.Cleveland.Internal.Pure (TestError(CustomTestError)) @@ -67,13 +68,13 @@ , testFailureIncludesCallStack "clarifyErrors properly works for equality tests" [lit| i @== 1 - ^^^^^^^ - | For i=2: - | Failed comparison - | ━━ Expected (rhs) ━━ - | 1 - | ━━ Got (lhs) ━━ - | 2 + ^^^ + | For i=2: + | Failed comparison + | ━━ Expected (rhs) ━━ + | 1 + | ━━ Got (lhs) ━━ + | 2 |] do for_ ([1..10] :: [Int]) \i -> @@ -82,14 +83,14 @@ , testFailureIncludesCallStack "clarifyErrors nests well" [lit| i @== j - ^^^^^^^ - | For i=1: - | For j=2: - | Failed comparison - | ━━ Expected (rhs) ━━ - | 2 - | ━━ Got (lhs) ━━ - | 1 + ^^^ + | For i=1: + | For j=2: + | Failed comparison + | ━━ Expected (rhs) ━━ + | 2 + | ━━ Got (lhs) ━━ + | 1 |] do for_ ([1..10] :: [Int]) \i -> @@ -131,6 +132,17 @@ withMoneybag addr $ void $ newAddress "b" + , testFailureIncludesCallStack "callstack points to newAddresses" + [lit| + void $ newAddresses $ "b" :< Nil + ^^^^^^^^^^^^ + |] + do + addr <- newFreshAddress "a" + -- force a failure by using an address without money as the donator + withMoneybag addr $ + void $ newAddresses $ "b" :< Nil + , testFailureIncludesCallStack "callstack points to signBytes" [lit| void $ signBytes "" invalidAddr @@ -239,10 +251,7 @@ , testFailureIncludesCallStack "callstack points to inBatch for batched transfers" [lit| inBatch $ do - call (TAddress @() invalidAddr) CallDefault () - call (TAddress @() invalidAddr) CallDefault () - return () - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^ |] do -- force a failure by transfering to an unknown address @@ -263,7 +272,8 @@ [ testFailureIncludesCallStack "when action throws an unexpected exception, callstack points to action" [lit| runIO $ throwM DummyException - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^ + | DummyException |] do void $ @@ -499,6 +509,8 @@ , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing + , rcNow = Nothing + , rcLevel = Nothing } ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] @@ -511,6 +523,8 @@ , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing + , rcNow = Nothing + , rcLevel = Nothing } , testFailureIncludesCallStackOnEmulator "when a branchout branch throws, the callstack points to the function inside the branch" @@ -530,7 +544,7 @@ "when a branchout branch throws ANY exception, the exception raised is printed in a right way" [lit| runIO $ throwM DummyException - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^ | In 'a' branch: | DummyException @@ -574,7 +588,7 @@ , testFailureIncludesCallStack "callstack points to @==" [lit| 1 @== (2 :: Int) - ^^^^^^^^^^^^^^^^ + ^^^ |] do 1 @== (2 :: Int) @@ -582,7 +596,7 @@ , testFailureIncludesCallStack "callstack points to @/=" [lit| 1 @/= (1 :: Int) - ^^^^^^^^^^^^^^^^ + ^^^ |] do 1 @/= (1 :: Int) @@ -590,7 +604,7 @@ , testFailureIncludesCallStack "callstack points to @@==" [lit| pure 1 @@== (2 :: Int) - ^^^^^^^^^^^^^^^^^^^^^^ + ^^^^ |] do pure 1 @@== (2 :: Int) @@ -598,7 +612,7 @@ , testFailureIncludesCallStack "callstack points to @@/=" [lit| pure 1 @@/= (1 :: Int) - ^^^^^^^^^^^^^^^^^^^^^^ + ^^^^ |] do pure 1 @@/= (1 :: Int) @@ -693,17 +707,17 @@ ^^^^^^^^^^^^^^^ |] dummyProp - , testFailureIncludesCallStackProperty "callstack points to the line where the pure error was thrown" - [lit| - error "Pure error" @== (1 :: Int) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - |] + , testFailureIncludesCallStackProperty "callstack does not point to internals when a pure error is thrown" + -- TODO [#818]: include the actual error message + -- NB: a single quote with two of these lines unindented causes tasty to output a different error message + (List.unlines + [ [lit|dummyPropWithPureError = property $ testScenarioProps $ scenario do|] + , [lit|^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^|]]) dummyPropWithPureError - , testFailureIncludesCallStackProperty "callstack points to the line where the nested pure error was thrown" - [lit| - (10 - 11 :: Mutez) @== 0 - ^^^^^^^^^^^^^^^^^^^^^^^^ - |] + , testFailureIncludesCallStackProperty "callstack does not point to internals when a nested pure error is thrown" + (List.unlines + [ [lit|dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do|] + , [lit|^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^|]]) dummyPropWithNestedPureError ] diff --git a/test/TestSuite/Cleveland/EmptyImplicitAddress.hs b/test/TestSuite/Cleveland/EmptyImplicitAddress.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite/Cleveland/EmptyImplicitAddress.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +-- | Calls from empty implicit addresses are disallowed +module TestSuite.Cleveland.EmptyImplicitAddress + ( test_EmptyImplicitAddressCalls + , test_EmptyImplicitAddressTransfers + ) where + +import Test.Tasty (TestTree) + +import Test.Cleveland + +import TestSuite.Util + +test_EmptyImplicitAddressCalls :: TestTree +test_EmptyImplicitAddressCalls = + testScenario "Calling a contract with empty implicit address fails" $ scenario do + addr <- newFreshAddress auto + contract <- originateSimple "contract" () $ idContract @() @() + call contract CallDefault () + & withSender addr + & shouldFailWithMessage "Empty implicit contract" + +test_EmptyImplicitAddressTransfers :: TestTree +test_EmptyImplicitAddressTransfers = + testScenario "Transferring from empty implicit address fails" $ scenario do + addr <- newFreshAddress auto + recvr <- newAddress auto + transferMoney recvr 0 + & withSender addr + & shouldFailWithMessage "Empty implicit contract" 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 @@ -193,7 +193,7 @@ -- | A contract that triggers a variety of error scenarios -- depending on the argument it's given. -testContractCode :: ContractCode Parameter () +testContractCode :: '[(Parameter, ())] :-> '[(List Operation, ())] testContractCode = car # entryCaseSimple @Parameter diff --git a/test/TestSuite/Cleveland/InitialState.hs b/test/TestSuite/Cleveland/InitialState.hs --- a/test/TestSuite/Cleveland/InitialState.hs +++ b/test/TestSuite/Cleveland/InitialState.hs @@ -11,7 +11,7 @@ import Test.Tasty (TestTree) import Test.Tasty.Hedgehog (testProperty) -import Morley.Tezos.Core (Timestamp(..)) +import Morley.Tezos.Core (ChainId(..), Timestamp(..)) import Test.Cleveland test_init :: IO [TestTree] @@ -39,4 +39,12 @@ $ scenarioEmulated $ do getLevel @@== expectedLevel getNow @@== expectedNow + + , testScenarioOnEmulator "Sets MINIMAL_BLOCK_DELAY" + $ withMinBlockTime 123 + $ scenarioEmulated $ getMinBlockTime @@== 123 + + , testScenarioOnEmulator "Sets CHAIN_ID" + $ withChainId (UnsafeChainId "\01\02\03\04") + $ scenarioEmulated $ getChainId @@== UnsafeChainId "\01\02\03\04" ] diff --git a/test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs b/test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs --- a/test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs +++ b/test/TestSuite/Cleveland/Lorentz/Contracts/ContractAllocator.hs @@ -10,12 +10,12 @@ import Test.Cleveland.Instances () allocatorContract :: Contract [Address] Storage () -allocatorContract = defaultContract allocatorContractLorentz +allocatorContract = mkContract allocatorContractLorentz type Storage = ("storage" :! [Address]) allocatorContractLorentz :: ContractCode [Address] Storage -allocatorContractLorentz = +allocatorContractLorentz = mkContractCode $ unpair # dip (nil @Operation) # iter ( diff --git a/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs b/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs --- a/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs +++ b/test/TestSuite/Cleveland/Lorentz/Entrypoints.hs @@ -12,8 +12,6 @@ , expectFailure ) where -import Lorentz qualified as L - import Data.List (isInfixOf) import Data.Text (strip) import Test.Tasty (testGroup) @@ -22,14 +20,13 @@ import Test.Tasty.Runners (FailureReason(..), Outcome(..), Result(..), TestTree(..)) import Lorentz.Annotation -import Lorentz.Constraints import Lorentz.Entrypoints -import Lorentz.Run import Lorentz.Value import Morley.Michelson.Untyped qualified as U import Morley.Util.Interpolate import Test.Cleveland.Lorentz.Entrypoints +import TestSuite.Util data MyEntrypoints1 = Do1 Integer @@ -58,10 +55,6 @@ instance ParameterHasEntrypoints MyEntrypoints2 where type ParameterEntrypointsDerivation MyEntrypoints2 = EpdPlain -dummyContract :: NiceParameterFull param => Contract param () () -dummyContract = L.defaultContract $ - L.drop L.# L.unit L.# L.nil L.# L.pair - epSpecPartial :: Map EpName U.Ty epSpecPartial = [ ( U.UnsafeEpName "do1", U.Ty (U.TInt) def ) @@ -107,14 +100,14 @@ test_ContractCoversEntrypoints = [ testContractCoversEntrypoints "testContractCoversEntrypoints works as expected" - (dummyContract @MyEntrypoints1) epSpecPartial + (idContract @MyEntrypoints1 @()) epSpecPartial , testContractCoversEntrypoints "testContractCoversEntrypoints fails on wrong type" - (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ] + (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ] & expectFailure "Expected: nat\nActual: int" , testContractCoversEntrypoints "testContractCoversEntrypoints fails on missing entrypoints" - (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ] + (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ] & expectFailure "Entrypoints do not match specification: \ \Missing entrypoints in the contract: do123: int" ] @@ -133,14 +126,14 @@ test_ContractMatchEntrypoints :: [TestTree] test_ContractMatchEntrypoints = [ testContractMatchesEntrypoints - "testContractMatchesEntrypoints works as expected" (dummyContract @MyEntrypoints1) epSpecFull + "testContractMatchesEntrypoints works as expected" (idContract @MyEntrypoints1 @()) epSpecFull , testContractMatchesEntrypoints "testContractMatchesEntrypoints fails on wrong type" - (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ] + (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ] & expectFailure "Expected: nat\nActual: int" , testContractMatchesEntrypoints "testContractMatchesEntrypoints fails on wrong nested type" - (dummyContract @MyEntrypoints1) [( U.UnsafeEpName "do4", genBigPair 6)] + (idContract @MyEntrypoints1 @()) [( U.UnsafeEpName "do4", genBigPair 6)] & expectFailure [it| pair (unit %param1) - (pair %param2 (unit %param1) @@ -154,11 +147,11 @@ |] , testContractMatchesEntrypoints "testContractMatchesEntrypoints fails on missing entrypoints" - (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ] + (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ] & expectFailure "Missing entrypoints in the contract: do123: int" , testContractMatchesEntrypoints "testContractMatchesEntrypoints fails on extraneous entrypoints" - (dummyContract @MyEntrypoints1) epSpecPartial + (idContract @MyEntrypoints1 @()) epSpecPartial & expectFailure "Entrypoints do not match specification:\ \ Extraneous entrypoints in the contract: do4: pair (unit %param1) (bytes %param2)" ] @@ -166,9 +159,9 @@ test_ContractMatchEntrypointsT :: [TestTree] test_ContractMatchEntrypointsT = [ testContractMatchesEntrypointsT @MyEntrypoints1 - "testContractMatchesEntrypointsT works as expected" (dummyContract @MyEntrypoints1) + "testContractMatchesEntrypointsT works as expected" (idContract @MyEntrypoints1 @()) , testContractMatchesEntrypointsT @MyEntrypoints2 - "testContractMatchesEntrypointsT fails on extra entrypoints" (dummyContract @MyEntrypoints1) + "testContractMatchesEntrypointsT fails on extra entrypoints" (idContract @MyEntrypoints1 @()) & expectFailure [it| Extraneous entrypoints in the contract: do1: int @@ -180,7 +173,7 @@ test_ContractCoverEntrypointsT :: [TestTree] test_ContractCoverEntrypointsT = [ testContractCoversEntrypointsT @MyEntrypoints2 - "testContractCoversEntrypointsT works on partial spec" (dummyContract @MyEntrypoints1) + "testContractCoversEntrypointsT works on partial spec" (idContract @MyEntrypoints1 @()) , testContractCoversEntrypointsT @MyEntrypoints1 - "testContractCoversEntrypointsT works on full spec" (dummyContract @MyEntrypoints1) + "testContractCoversEntrypointsT works on full spec" (idContract @MyEntrypoints1 @()) ] 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 @@ -20,14 +20,15 @@ -- If probability of generating the same address twice is low, then -- we better always blindly transfer some money to new addresses. testScenario "Address generation is deterministic" $ scenario do - addr1 ::< addr2 ::< Nil' <- traverse newAddress $ SL.replicateT "test" + addr1 ::< addr2 ::< Nil' <- newAddresses $ SL.replicateT "test" addr1 @== addr2 test_NewAddressCheck :: [TestTree] test_NewAddressCheck = [ testScenario "Newly created address gets money if it had low balance" $ scenario do - test :< test2 :< Nil <- traverse newAddress $ "test" :< "test2" :< Nil + let hints = enumAliases "test" + test ::< test2 ::< Nil' <- newAddresses hints balance <- getBalance test let @@ -43,7 +44,7 @@ "Sanity check failed. Something went wrong, is test broken?" -- creating the same address to check how balance replenishes - _ <- newAddress "test" + _ <- newAddress $ SL.head hints balance3 <- getBalance test checkCompares balance3 (>) toRemain diff --git a/test/TestSuite/Cleveland/PrefixNetworkScenario.hs b/test/TestSuite/Cleveland/PrefixNetworkScenario.hs deleted file mode 100644 --- a/test/TestSuite/Cleveland/PrefixNetworkScenario.hs +++ /dev/null @@ -1,67 +0,0 @@ --- SPDX-FileCopyrightText: 2021 Oxhead Alpha --- SPDX-License-Identifier: LicenseRef-MIT-OA - -module TestSuite.Cleveland.PrefixNetworkScenario - ( test_PrefixNetworkScenario - , test_newAddress_with_prefix - ) where - -import Data.Fixed (Nano) -import Data.Text (takeEnd) -import Data.Time.Clock.POSIX (getPOSIXTime) -import System.IO.Temp (withSystemTempDirectory) -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase, (@=?)) - -import Morley.Client qualified as Client -import Morley.Client.TezosClient.Types (tceAliasPrefixL, tceMbTezosClientDataDirL) -import Morley.Tezos.Crypto (SecretKey, detSecretKey) -import Test.Cleveland -import Test.Cleveland.Internal.Abstract (Moneybag(Moneybag), moneybagL) -import Test.Cleveland.Internal.Client - (neMoneybagAliasL, neMorleyClientEnvL, neSecretKeyL, runClevelandT) -import Test.Cleveland.Tasty (modifyNetworkEnv, setAliasPrefix, whenNetworkEnabled) - -aliasName :: Client.Alias -aliasName = Client.mkAlias "testMoneybagAlias" - -aliasPrefix :: Text -aliasPrefix = "testPrefix" - -mangleNetworkEnv :: SecretKey -> TestTree -> TestTree -mangleNetworkEnv sk = modifyNetworkEnv $ - (neMorleyClientEnvL . Client.mceTezosClientL . tceAliasPrefixL .~ Just aliasPrefix) - . (neSecretKeyL .~ Just sk) - . (neMoneybagAliasL .~ aliasName) - -setTmpDir :: FilePath -> NetworkEnv -> NetworkEnv -setTmpDir dir = neMorleyClientEnvL . Client.mceTezosClientL . tceMbTezosClientDataDirL .~ Just dir - -test_PrefixNetworkScenario :: IO TestTree -test_PrefixNetworkScenario = do - -- use 7 digits of the current POSIX time in nanoseconds to generate seed - -- this ensures we test for a fresh key more often than not - -- taking 7 digits ensures that we're generating Ed25519 key. - seed <- encodeUtf8 . takeEnd 7 . show @Text . realToFrac @_ @Nano <$> getPOSIXTime - let key = detSecretKey seed - pure $ mangleNetworkEnv key $ whenNetworkEnabled $ \withEnv -> - testCase "Moneybag alias is not affected by alias prefix" $ withEnv $ \env' -> - -- NB: we can't have 'withSystemTempDirectory' outside the test because - -- the outer IO action finishes before the test itself is run. - -- hence we have to change the tmpdir in env inside the test too - withSystemTempDirectory "tezos-client" \tmpdir -> do - let env = setTmpDir tmpdir env' - Moneybag moneybagAddress <- runClevelandT env $ view moneybagL - - actualAlias <- Client.runMorleyClientM (neMorleyClientEnv env) $ - Client.getAlias $ Client.AddressResolved moneybagAddress - actualAlias @=? aliasName - -test_newAddress_with_prefix :: TestTree -test_newAddress_with_prefix = - setAliasPrefix "prefix" $ - testScenario "`newAddress` prepends alias prefix to alias hint" $ scenario do - addr1 <- newAddress "alias" - addr2 <- resolveAddress "alias" - - addr1 @== addr2 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,6 +16,7 @@ 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 withSender addr do cont <- originateSimple "failing" () failing call cont CallDefault () & 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 @@ -16,7 +16,7 @@ import Lorentz as L hiding (comment) import Test.Cleveland import Test.Cleveland.Instances () -import Test.Cleveland.Internal.Abstract (SpecificOrDefaultAliasHint(..)) +import Test.Cleveland.Internal.Abstract (SpecificOrDefaultAlias(..)) publicKeyToAddress :: Contract PublicKey (Maybe Address) () publicKeyToAddress = defaultContract $ @@ -32,14 +32,14 @@ test_publicKeyToAddress = testProperty "The address is calculated correctly from the given public key" $ withTests 200 $ property $ do - aliasHint <- fromString <$> (forAll $ Gen.string (Range.linear 0 100) Gen.unicode) - testScenarioProps $ scenario $ scenario' aliasHint + alias <- fromString <$> (forAll $ Gen.string (Range.linear 0 100) Gen.unicode) + testScenarioProps $ scenario $ scenario' alias -scenario' :: (MonadCleveland caps m) => AliasHint -> m () -scenario' aliasHint = do +scenario' :: (MonadCleveland caps m) => Alias -> m () +scenario' alias = do c <- originateSimple @PublicKey @(Maybe Address) "publicKeyToAddress" Nothing publicKeyToAddress - addr1 <- newAddress $ SpecificAliasHint aliasHint + addr1 <- newAddress $ SpecificAlias alias addr1pk <- getPublicKey addr1 call c CallDefault addr1pk 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 @@ -24,6 +24,7 @@ import Lorentz.Base import Lorentz.Value import Morley.Michelson.Runtime.GState (gsAddressesL) +import Morley.Tezos.Core (Timestamp(..)) import Test.Cleveland import Test.Cleveland.Internal.Pure (psGState) import TestSuite.Util (idContract) @@ -38,6 +39,8 @@ , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing + , rcNow = Nothing + , rcLevel = Nothing } @@== 8 where increment :: Contract Integer Integer () @@ -49,7 +52,7 @@ test_emulator_state_is_not_modified :: TestTree test_emulator_state_is_not_modified = testScenarioOnEmulator "the emulator's state is not modified" $ scenario do - before <- use psGState + before <- get runCode RunCode { rcContract = transferToSender , rcStorage = NotRPC () @@ -57,8 +60,10 @@ , rcAmount = 900 , rcBalance = 900 , rcSource = Nothing + , rcNow = Just (Timestamp 1337) + , rcLevel = Just 42 } - after <- use psGState + after <- get checkComparesWith Debug.show before (==) Debug.show after where transferToSender :: Contract () () () @@ -88,6 +93,8 @@ , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing + , rcNow = Nothing + , rcLevel = Nothing } @@== 1 where -- | A contract that calls itself forever, increment the counter in its storage by 1 on every call. @@ -112,6 +119,8 @@ , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing + , rcNow = Nothing + , rcLevel = Nothing } total @== (50, 20) @@ -133,6 +142,8 @@ , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing + , rcNow = Nothing + , rcLevel = Nothing } total @== (30, 30) @@ -150,9 +161,12 @@ , rcAmount = 456 , rcBalance = 123 , rcSource = Just source + , rcNow = Just (Timestamp 8) + , rcLevel = Just 29 } >>= evalJust "Expected contract to return a `Some`" - getLevel @@== envLevel envVars + envLevel envVars @== 29 + envNow envVars @== Timestamp 8 getChainId @@== envChainId envVars envSender envVars @== sender envSource envVars @== source @@ -164,6 +178,7 @@ L.drop # L.constructT @EnvVars ( L.fieldCtor $ L.level + , L.fieldCtor $ L.now , L.fieldCtor $ L.chainId , L.fieldCtor $ L.sender , L.fieldCtor $ L.source @@ -174,6 +189,7 @@ data EnvVars = EnvVars { envLevel :: Natural + , envNow :: Timestamp , envChainId :: ChainId , envSender :: Address , envSource :: Address @@ -213,6 +229,8 @@ , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing + , rcNow = Nothing + , rcLevel = Nothing } @@== Just contractAddress test_self_address_does_not_exist_onchain :: TestTree @@ -238,6 +256,8 @@ , rcAmount = 0 , rcBalance = 0 , rcSource = Nothing + , rcNow = Nothing + , rcLevel = Nothing } >>= evalJust "Expected contract to return a `Some`" emulatorState ^. gsAddressesL . at selfAddr @== Nothing @@ -253,7 +273,7 @@ -- -- ... and stores both results in the storage. lookupBigMapKey :: Contract (MText, BigMap MText Integer) ((Integer, Integer), BigMap MText Integer) () -lookupBigMapKey = L.mkContractWith L.intactCompilationOptions $ +lookupBigMapKey = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $ L.unpair # L.dip L.cdr # L.unpair 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 @@ -115,13 +115,13 @@ contracts = [createEmptyBigMap, copyToEmptyBigMap] createEmptyBigMap :: Contract () (BigMap MText Integer) () - createEmptyBigMap = L.mkContractWith L.intactCompilationOptions $ + createEmptyBigMap = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $ L.drop # L.emptyBigMap # L.nil # L.pair copyToEmptyBigMap :: Contract () (BigMap MText Integer) () - copyToEmptyBigMap = L.mkContractWith L.intactCompilationOptions $ + copyToEmptyBigMap = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $ L.drop # L.emptyBigMap @MText @Integer # L.push @Integer 1 @@ -139,7 +139,7 @@ unBigMapId <$> getStorage addr @@== unBigMapId id0 where updateBigMap :: Contract () (BigMap MText Integer) () - updateBigMap = L.mkContractWith L.intactCompilationOptions $ + updateBigMap = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $ L.cdr # L.push 12 # L.some # L.push "12" @@ -190,7 +190,7 @@ where -- Duplicate an existing bigmap, save it in the storage, and discard the old bigmap. dupAndDiscardOld :: Contract () (BigMap MText Integer) () - dupAndDiscardOld = L.mkContractWith L.intactCompilationOptions $ + dupAndDiscardOld = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $ L.cdr # L.dup # L.dip L.drop @@ -198,7 +198,7 @@ -- Duplicate an existing bigmap, save both (the old and the new) bigmaps in the storage. dupAndKeepBoth :: Contract () (BigMap MText Integer, BigMap MText Integer) () - dupAndKeepBoth = L.mkContractWith L.intactCompilationOptions $ + dupAndKeepBoth = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $ L.cdr # L.car # L.stackType @'[ BigMap MText Integer ] 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 @@ -6,7 +6,7 @@ , test_nonUnitParamToImplicitAccount_fails ) where -import Test.Tasty (TestTree) +import Test.Tasty (TestTree, testGroup) import Lorentz ((#)) import Lorentz qualified as L @@ -15,16 +15,16 @@ import Test.Cleveland import TestSuite.Util (idContract, shouldFailWithMessage) -test_TransferFromContract :: [TestTree] -test_TransferFromContract = - [ testScenarioOnEmulator "Disallow transferring ꜩ when revealing a contract (#440)" $ scenarioEmulated do +test_TransferFromContract :: TestTree +test_TransferFromContract = testGroup "Transfers from contract" + [ testScenarioOnEmulator "Forbid transfers to implicit accounts (#440)" $ scenarioEmulated do testRevealContract morleyMessage - , testScenarioOnNetwork "Disallow transferring ꜩ when revealing a contract (#440)" $ scenario do + , testScenarioOnNetwork "Forbid transfers to implicit accounts (#440)" $ scenario do testRevealContract rpcMessage - , testScenarioOnEmulator "Disallow transferring ꜩ from an empty implicit account (#440)" $ scenario do + , testScenarioOnEmulator "Forbid transfers to empty implicit accounts (#440)" $ scenario do testEmptyImplicitAccount morleyMessage - , testScenarioOnNetwork "Disallow transferring ꜩ from an empty implicit account (#440)" $ scenario do + , testScenarioOnNetwork "Forbid transfers to empty implicit accounts (#440)" $ scenario do testEmptyImplicitAccount rpcMessage , testScenario "Fails transfering 0tz to plain account" $ scenario $ testZeroTransactionFails 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 @@ -20,7 +20,7 @@ <- originateSimple "vp contract" 0 =<< importContract @KeyHash @Natural @() ("../../contracts/voting_power.tz") - let keyHash = unsafe $ parseKeyHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" + let keyHash = unsafe $ parseHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" call contract CallDefault keyHash getStorage contract @@== 0 @@ -30,8 +30,8 @@ =<< importContract @KeyHash @(Natural, Natural) @() ("../../contracts/voting_powers.tz") comment "Setting custom voting powers to access them later" - let keyHash = unsafe $ parseKeyHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" - let keyHash2 = unsafe $ parseKeyHash "tz1hvYBbHRJhT3dQ8bEjc34xm3rjJJmTcuqs" + let keyHash = unsafe $ parseHash "tz1Yq4Hj9u2f9473wAKiFEm36Sp2GfB5aTGa" + let keyHash2 = unsafe $ parseHash "tz1hvYBbHRJhT3dQ8bEjc34xm3rjJJmTcuqs" setVotingPowers (mkVotingPowers [(keyHash, 123), (keyHash2, 57)]) call contract CallDefault keyHash