diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,31 +5,30 @@ ## I: A reimplementation of the Michelson Language in Haskell -- `Michelson.Untyped`: Simple data types representing Michelson smart - contracts and expresions. We use word `Untyped` to reflect that - Michelson type of corresponding Haskel values is not statically known - (e. g. there is a `Value` type which is basically dynamically typed). -- `Michelson.Typed`: These modules contain more advanced types comparing to - `Michelson.Untyped` with similar semantics. These types use `GADTs` GHC - extension and in this representation Michelson type of each value and - instruction is statically known. There are also some utilities to use this - advanced machinery. -- `Michelson.TypeCheck`: A typechecker that validates ADT's that conform to - Michelson's typing rules. -- `Michelson.Intepreter`: An intepreter for Michelson contracts which doesn't - perform any side effects. -- `Morley.Types`: Types for macros, syntactic sugar, and interpreter directives. -- `Morley.Parser` A parser to turn a `.tz` file into an ADT. -- `Morley.Runtime`: An interpreter that executes a well-typed Morley smart - contract in a sandbox. +It consists of the following parts: -## II: Testing tools (TBD) +- `Tezos.*` hierarchy is designed to implement cryptographic primitives, string and byte formats, and any other functionality specific to the Tezos protocol which is required for testing/execution of Michelson contracts, but is used not only by Michelson. +- `Michelson.Untyped` and `Michelson.Typed` hierarchies define Haskell data types that assemble a Michelson contract. See [michelsonTypes.md](/docs/michelsonTypes.md). +- `Michelson.TypeCheck`: A typechecker that validates Michelson contracts according to Michelson's typing rules. Essentially it performs conversion from untyped representation to the typed one. See [morleyTypechecker.md](/docs/morleyTypechecker.md). +- `Michelson.Intepreter`: An intepreter for Michelson contracts which doesn't perform any side effects. See [morleyInterpreter.md](/docs/morleyInterpreter.md). +- `Morley.Types`: Types for macros, syntactic sugar and other extensions described in the next chapter. +- `Morley.Parser` A parser to turn a `.tz` or `.mtz` file (`.mtz` is a Michelson contract with Morley extensions) into a Haskell ADT. +- `Morley.Runtime`: A high-level interface to Morley functionality, see [morleyRuntime.md](/docs/morleyRuntime.md). -- `Morley.REPL`: An interactive REPL with stack visualization. -- `Morley.QuickCheck`: QuickCheck generators for arbitary Michelson `Value`s, - `LAMBDA`s and `Contract`s. -- `Morley.Sandbox`: Simulating a more realistic network environment, multiple - smart contracts in the same sandbox. +## II: Morley extensions + +The Morley Language is a superset of the Michelson language, which means that each Michelson contract is also a valid Morley contract but not vice versa. +There are several extensions which make it more convenient to write Michelson contracts and test them. +See [the document](/docs/morleyLanguage.md) about these extensions. +Also there is a transpiler from Morley to Michelson. + +## III: Morley-to-Michelson transpiler + +Coming soon, see TM-58. + +## IV: Testing EDSL + +Coming soon, see TM-77. ## Issue Tracker diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -1,18 +1,18 @@ +cabal-version: 2.4 name: morley -version: 0.1.0.1 +version: 0.1.0.2 synopsis: Developer tools for the Michelson Language description: A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. homepage: https://gitlab.com/camlcase-dev/morley -license: AGPL-3 +license: AGPL-3.0-or-later license-file: LICENSE author: camlCase, Serokell maintainer: john@camlcase.io copyright: 2018 camlCase, 2019 Tocqueville Group category: Language build-type: Simple -cabal-version: >=1.18 bug-reports: https://issues.serokell.io/issues/TM extra-doc-files: CONTRIBUTING.md , README.md @@ -38,6 +38,7 @@ , Morley.Ext , Morley.Parser , Morley.Parser.Annotations + , Morley.Parser.Helpers , Morley.Runtime , Morley.Runtime.GState , Morley.Runtime.TxData @@ -75,6 +76,7 @@ build-depends: aeson , aeson-options + , aeson-pretty , base-noprelude >= 4.7 && < 5 , base16-bytestring , base58-bytestring @@ -151,6 +153,7 @@ executable morley hs-source-dirs: app main-is: Main.hs + autogen-modules: Paths_morley other-modules: Paths_morley default-language: Haskell2010 build-depends: base-noprelude >= 4.7 && < 5 @@ -221,6 +224,7 @@ , Test.Interpreter.CallSelf , Test.Interpreter.Compare , Test.Interpreter.Conditionals + , Test.Interpreter.EnvironmentSpec , Test.Interpreter.StringCaller , Test.Macro , Test.Ext diff --git a/src/Michelson/TypeCheck/Helpers.hs b/src/Michelson/TypeCheck/Helpers.hs --- a/src/Michelson/TypeCheck/Helpers.hs +++ b/src/Michelson/TypeCheck/Helpers.hs @@ -8,6 +8,7 @@ , convergeHSTEl , convergeHST + , ensureDistinctAsc , eqT' , assertEqT , checkEqT @@ -38,6 +39,7 @@ import Data.Singletons (SingI(sing)) import qualified Data.Text as T import Data.Typeable ((:~:)(..), eqT, typeRep) +import Fmt ((+||), (||+)) import Michelson.TypeCheck.Types import Michelson.Typed @@ -135,6 +137,16 @@ -------------------------------------------- -- Typechecker auxiliary -------------------------------------------- + +-- | Check whether elements go in strictly ascending order and +-- return the original list (to keep only one pass on the original list). +ensureDistinctAsc :: (Ord a, Show a) => [a] -> Either Text [a] +ensureDistinctAsc = \case + (e1 : e2 : l) -> + if e1 < e2 + then (e1 :) <$> ensureDistinctAsc (e2 : l) + else Left $ "Entries are unordered (" +|| e1 ||+ " >= " +|| e2 ||+ "" + l -> Right l checkEqT :: forall a b ts . (Typeable a, Typeable b, Typeable ts) diff --git a/src/Michelson/TypeCheck/Value.hs b/src/Michelson/TypeCheck/Value.hs --- a/src/Michelson/TypeCheck/Value.hs +++ b/src/Michelson/TypeCheck/Value.hs @@ -111,49 +111,72 @@ withSomeSingT vt $ \vst -> pure $ VOption Nothing :::: (STOption vst, NStar) -typeCheckValImpl tcDo (Un.ValueSeq mels) (TList vt) = +typeCheckValImpl _ Un.ValueNil (TList vt) = + withSomeSingT vt $ \vst -> + pure $ VList [] :::: (STList vst, mkNotes $ NTList def NStar) + +typeCheckValImpl tcDo (Un.ValueSeq (toList -> mels)) (TList vt) = withSomeSingT vt $ \vst -> do (els, ns) <- typeCheckValsImpl tcDo mels vt pure $ VList els :::: (STList vst, mkNotes $ NTList def ns) -typeCheckValImpl _ (Un.ValueSeq mels) (TSet vt) = +typeCheckValImpl _ Un.ValueNil (TSet vt) = + withSomeSingCT vt $ \vst -> + pure $ VSet S.empty :::: (STSet vst, NStar) + +typeCheckValImpl _ sq@(Un.ValueSeq (toList -> mels)) (TSet vt) = withSomeSingCT vt $ \vst -> do els <- liftEither $ typeCheckCVals mels vt `onLeft` \(cv, err) -> TCFailedOnValue cv (Tc vt) $ "wrong type of set element: " <> err - pure $ VSet (S.fromList els) :::: (STSet vst, NStar) + elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc els + `onLeft` TCFailedOnValue sq (Tc vt) + pure $ VSet elsS :::: (STSet vst, NStar) -typeCheckValImpl tcDo (Un.ValueMap mels) (TMap kt vt) = +typeCheckValImpl _ Un.ValueNil (TMap kt vt) = withSomeSingT vt $ \vst -> withSomeSingCT kt $ \kst -> do + let ns = mkNotes $ NTMap def def NStar + pure $ VMap M.empty :::: (STMap kst vst, ns) + +typeCheckValImpl tcDo sq@(Un.ValueMap (toList -> mels)) (TMap kt vt) = + withSomeSingT vt $ \vst -> + withSomeSingCT kt $ \kst -> do ks <- liftEither $ typeCheckCVals (map (\(Un.Elt k _) -> k) mels) kt `onLeft` \(cv, err) -> TCFailedOnValue cv (Tc kt) $ "wrong type of map key: " <> err (vals, vns) <- typeCheckValsImpl tcDo (map (\(Un.Elt _ v) -> v) mels) vt let ns = mkNotes $ NTMap def def vns - pure $ VMap (M.fromList $ zip ks vals) :::: (STMap kst vst, ns) + ksS <- liftEither $ ensureDistinctAsc ks + `onLeft` TCFailedOnValue sq (Tc kt) + pure $ VMap (M.fromDistinctAscList $ zip ksS vals) :::: (STMap kst vst, ns) -typeCheckValImpl tcDo v@(Un.ValueLambda (fmap Un.unOp -> mp)) t@(TLambda mi mo) = +typeCheckValImpl tcDo v t@(TLambda mi mo) = do + mp <- case v of + Un.ValueNil -> pure [] + Un.ValueLambda mp -> pure $ fmap Un.unOp (toList mp) + _ -> throwError $ TCFailedOnValue v t "" + withSomeSingT mi $ \(it :: Sing it) -> - withSomeSingT mo $ \(ot :: Sing ot) -> - typeCheckImpl tcDo mp (SomeHST $ (it, NStar, def) ::& SNil) >>= \case - SiFail -> pure $ VLam FAILWITH :::: (STLambda it ot, NStar) - lam ::: ((li :: HST li), (lo :: HST lo)) -> do - Refl <- liftEither $ eqT' @li @'[ it ] `onLeft` unexpectedErr - case (eqT' @'[ ot ] @lo, SomeHST lo, SomeHST li) of - (Right Refl, - SomeHST ((_, ons, _) ::& SNil :: HST lo'), - SomeHST ((_, ins, _) ::& SNil :: HST li')) -> do - Refl <- liftEither $ eqT' @lo @lo' `onLeft` unexpectedErr - Refl <- liftEither $ eqT' @li @li' `onLeft` unexpectedErr - let ns = mkNotes $ NTLambda def ins ons - pure $ VLam lam :::: (STLambda it ot, ns) - (Right _, _, _) -> - throwError $ TCFailedOnValue v t - "wrong output type of lambda's value (wrong stack size)" - (Left m, _, _) -> - throwError $ TCFailedOnValue v t $ - "wrong output type of lambda's value: " <> m + withSomeSingT mo $ \(ot :: Sing ot) -> + typeCheckImpl tcDo mp (SomeHST $ (it, NStar, def) ::& SNil) >>= \case + SiFail -> pure $ VLam FAILWITH :::: (STLambda it ot, NStar) + lam ::: ((li :: HST li), (lo :: HST lo)) -> do + Refl <- liftEither $ eqT' @li @'[ it ] `onLeft` unexpectedErr + case (eqT' @'[ ot ] @lo, SomeHST lo, SomeHST li) of + (Right Refl, + SomeHST ((_, ons, _) ::& SNil :: HST lo'), + SomeHST ((_, ins, _) ::& SNil :: HST li')) -> do + Refl <- liftEither $ eqT' @lo @lo' `onLeft` unexpectedErr + Refl <- liftEither $ eqT' @li @li' `onLeft` unexpectedErr + let ns = mkNotes $ NTLambda def ins ons + pure $ VLam lam :::: (STLambda it ot, ns) + (Right _, _, _) -> + throwError $ TCFailedOnValue v t + "wrong output type of lambda's value (wrong stack size)" + (Left m, _, _) -> + throwError $ TCFailedOnValue v t $ + "wrong output type of lambda's value: " <> m where unexpectedErr m = TCFailedOnValue v t ("unexpected " <> m) diff --git a/src/Michelson/Typed/Convert.hs b/src/Michelson/Typed/Convert.hs --- a/src/Michelson/Typed/Convert.hs +++ b/src/Michelson/Typed/Convert.hs @@ -62,20 +62,24 @@ VSignature b -> Just $ Un.ValueString $ formatSignature b VOption (Just x) -> Un.ValueSome <$> valToOpOrValue x VOption Nothing -> Just $ Un.ValueNone - VList l -> Un.ValueSeq <$> mapM valToOpOrValue l - VSet s -> Just $ Un.ValueSeq $ map cValToValue $ toList s + VList l -> valueList Un.ValueSeq <$> mapM valToOpOrValue l + VSet s -> Just $ valueList Un.ValueSeq $ map cValToValue $ toList s VOp _op -> Nothing VContract b -> Just $ Un.ValueString $ formatAddress b VPair (l, r) -> Un.ValuePair <$> valToOpOrValue l <*> valToOpOrValue r VOr (Left x) -> Un.ValueLeft <$> valToOpOrValue x VOr (Right x) -> Un.ValueRight <$> valToOpOrValue x - VLam ops -> Just $ Un.ValueLambda $ instrToOps ops + VLam ops -> + Just $ maybe Un.ValueNil Un.ValueLambda $ + nonEmpty (instrToOps ops) VMap m -> - fmap Un.ValueMap . forM (Map.toList m) $ \(k, v) -> + fmap (valueList Un.ValueMap) . forM (Map.toList m) $ \(k, v) -> Un.Elt (cValToValue k) <$> valToOpOrValue v VBigMap m -> - fmap Un.ValueMap . forM (Map.toList m) $ \(k, v) -> + fmap (valueList Un.ValueMap) . forM (Map.toList m) $ \(k, v) -> Un.Elt (cValToValue k) <$> valToOpOrValue v + where + valueList ctor = maybe Un.ValueNil ctor . nonEmpty cValToValue :: CVal t -> Un.Value Un.Op cValToValue cVal = case cVal of diff --git a/src/Michelson/Untyped/Value.hs b/src/Michelson/Untyped/Value.hs --- a/src/Michelson/Untyped/Value.hs +++ b/src/Michelson/Untyped/Value.hs @@ -31,11 +31,12 @@ | ValueRight (Value op) | ValueSome (Value op) | ValueNone - | ValueSeq [Value op] + | ValueNil + | ValueSeq (NonEmpty $ Value op) -- ^ A sequence of elements: can be a list or a set. -- We can't distinguish lists and sets during parsing. - | ValueMap [Elt op] - | ValueLambda [op] + | ValueMap (NonEmpty $ Elt op) + | ValueLambda (NonEmpty op) deriving stock (Eq, Show, Functor, Data, Generic) data Elt op = Elt (Value op) (Value op) @@ -63,12 +64,13 @@ ValueRight v -> "(Right " +| v |+ ")" ValueSome v -> "(Some " +| v |+ ")" ValueNone -> "None" + ValueNil -> "{}" ValueSeq vs -> buildList vs ValueMap els -> buildList els ValueLambda ops -> buildList ops where - buildList :: Buildable a => [a] -> Builder - buildList items = + buildList :: Buildable a => NonEmpty a -> Builder + buildList (toList -> items) = "{" <> mconcat (intersperse "; " $ map Buildable.build items) <> "}" diff --git a/src/Morley/Macro.hs b/src/Morley/Macro.hs --- a/src/Morley/Macro.hs +++ b/src/Morley/Macro.hs @@ -41,9 +41,12 @@ ValueLeft x -> ValueLeft (expandValue x) ValueRight x -> ValueRight (expandValue x) ValueSome x -> ValueSome (expandValue x) + ValueNil -> ValueNil ValueSeq valueList -> ValueSeq (map expandValue valueList) ValueMap eltList -> ValueMap (map expandElt eltList) - ValueLambda opList -> ValueLambda (expandFlat $ opList) + ValueLambda opList -> + maybe ValueNil ValueLambda $ + nonEmpty (expandFlat $ toList opList) x -> fmap (unsafeCastPrim . expand) x expandElt :: Elt ParsedOp -> Elt Op diff --git a/src/Morley/Parser.hs b/src/Morley/Parser.hs --- a/src/Morley/Parser.hs +++ b/src/Morley/Parser.hs @@ -29,6 +29,7 @@ import Morley.Lexer import qualified Morley.Macro as Macro import Morley.Parser.Annotations +import Morley.Parser.Helpers import Morley.Types (CustomParserException(..), ParsedOp(..), Parser, ParserException(..)) import qualified Morley.Types as Mo @@ -97,18 +98,24 @@ where ti = snd <$> (lexeme $ typeInner (pure Mo.noAnn)) -ops :: Parser [Mo.ParsedOp] -ops = do +op' :: Parser Mo.ParsedOp +op' = do lms <- asks Mo.letMacros - let op' = choice [ (Mo.PRIM . Mo.EXT) <$> nopInstr - , Mo.LMAC <$> mkLetMac lms - , Mo.PRIM <$> prim - , Mo.MAC <$> macro - , primOrMac - , Mo.SEQ <$> ops - ] - braces $ sepEndBy op' semicolon + choice + [ (Mo.PRIM . Mo.EXT) <$> nopInstr + , Mo.LMAC <$> mkLetMac lms + , Mo.PRIM <$> prim + , Mo.MAC <$> macro + , primOrMac + , Mo.SEQ <$> ops + ] +ops :: Parser [Mo.ParsedOp] +ops = braces $ sepEndBy op' semicolon + +ops1 :: Parser (NonEmpty Mo.ParsedOp) +ops1 = braces $ sepEndBy1 op' semicolon + ------------------------------------------------------------------------------- -- Let block ------------------------------------------------------------------------------- @@ -216,7 +223,8 @@ valueInner = choice $ [ intLiteral, stringLiteral, bytesLiteral, unitValue , trueValue, falseValue, pairValue, leftValue, rightValue - , someValue, noneValue, seqValue, mapValue, lambdaValue, dataLetValue + , someValue, noneValue, nilValue, seqValue, mapValue, lambdaValue + , dataLetValue ] dataLetValue :: Parser (Mo.Value ParsedOp) @@ -302,17 +310,20 @@ noneValue :: Parser (Mo.Value ParsedOp) noneValue = do symbol "None"; return Mo.ValueNone +nilValue :: Parser (Mo.Value ParsedOp) +nilValue = Mo.ValueNil <$ (try $ braces pass) + lambdaValue :: Parser (Mo.Value ParsedOp) -lambdaValue = Mo.ValueLambda <$> ops +lambdaValue = Mo.ValueLambda <$> ops1 seqValue :: Parser (Mo.Value ParsedOp) -seqValue = Mo.ValueSeq <$> (try $ braces $ sepEndBy value semicolon) +seqValue = Mo.ValueSeq <$> (try $ braces $ sepEndBy1 value semicolon) eltValue :: Parser (Mo.Elt ParsedOp) eltValue = do void $ symbol "Elt"; Mo.Elt <$> value <*> value mapValue :: Parser (Mo.Value ParsedOp) -mapValue = Mo.ValueMap <$> (try $ braces $ sepEndBy eltValue semicolon) +mapValue = Mo.ValueMap <$> (try $ braces $ sepEndBy1 eltValue semicolon) ------------------------------------------------------------------------------- -- Types diff --git a/src/Morley/Parser/Helpers.hs b/src/Morley/Parser/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Parser/Helpers.hs @@ -0,0 +1,9 @@ +module Morley.Parser.Helpers + ( sepEndBy1 + ) where + +import qualified Data.List.NonEmpty as NE +import qualified Text.Megaparsec as P + +sepEndBy1 :: MonadPlus m => m a -> m sep -> m (NonEmpty a) +sepEndBy1 = fmap NE.fromList ... P.sepEndBy1 diff --git a/src/Morley/Runtime.hs b/src/Morley/Runtime.hs --- a/src/Morley/Runtime.hs +++ b/src/Morley/Runtime.hs @@ -94,7 +94,7 @@ data InterpreterError = IEUnknownContract !Address -- ^ The interpreted contract hasn't been originated. - | IEInterpreterFailed !(Contract Op) + | IEInterpreterFailed !Address !(InterpretUntypedError MorleyLogs) -- ^ Interpretation of Michelson contract failed. | IEAlreadyOriginated !Address @@ -116,7 +116,8 @@ build = \case IEUnknownContract addr -> "The contract is not originated " +| addr |+ "" - IEInterpreterFailed _ err -> "Michelson interpreter failed: " +| err |+ "" + IEInterpreterFailed addr err -> + "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ "" IEAlreadyOriginated addr cs -> "The following contract is already originated: " +| addr |+ ", " +| cs |+ "" @@ -372,7 +373,7 @@ , iurNewStorage = newValue , iurNewState = InterpreterState printedLogs newRemainingSteps } - <- first (IEInterpreterFailed contract) $ + <- first (IEInterpreterFailed addr) $ interpretMorleyUntyped contract (tdParameter txData) (csStorage cs) contractEnv let diff --git a/src/Morley/Runtime/GState.hs b/src/Morley/Runtime/GState.hs --- a/src/Morley/Runtime/GState.hs +++ b/src/Morley/Runtime/GState.hs @@ -25,6 +25,7 @@ import Control.Lens (at) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as Aeson import Data.Aeson.Options (defaultOptions) import Data.Aeson.TH (deriveJSON) import qualified Data.ByteString.Lazy as LBS @@ -132,7 +133,12 @@ -- | Write 'GState' to a file. writeGState :: FilePath -> GState -> IO () -writeGState fp gs = LBS.writeFile fp (Aeson.encode gs) +writeGState fp gs = LBS.writeFile fp (Aeson.encodePretty' config gs) + where + config = + Aeson.defConfig + { Aeson.confTrailingNewline = True + } -- | Updates that can be applied to 'GState'. data GStateUpdate diff --git a/src/Morley/Test/Integrational.hs b/src/Morley/Test/Integrational.hs --- a/src/Morley/Test/Integrational.hs +++ b/src/Morley/Test/Integrational.hs @@ -1,142 +1,206 @@ -- | Utilities for integrational testing. +-- Example tests can be found in the 'morley-test' test suite. module Morley.Test.Integrational - ( IntegrationalValidator + ( + -- * Re-exports + TxData (..) + + -- * Testing engine + , TestOperation (..) + , IntegrationalValidator , SuccessValidator + , IntegrationalScenario , integrationalTestExpectation , integrationalTestProperty - , simplerIntegrationalTestExpectation - , simplerIntegrationalTestProperty + , originate + , transfer + , validate + , setMaxSteps + , setNow -- * Validators , composeValidators - , expectStorageValue - , expectStorageConstant + , composeValidatorsList + , expectAnySuccess + , expectStorageUpdate + , expectStorageUpdateConst , expectBalance + , expectStorageConst , expectGasExhaustion + , expectMichelsonFailed ) where -import Control.Lens (at) +import Control.Lens (at, makeLenses, (.=), (<>=)) +import Control.Monad.Except (Except, runExcept, throwError) import qualified Data.List as List import Fmt (blockListF, pretty, (+|), (|+)) import Test.Hspec (Expectation, expectationFailure) import Test.QuickCheck (Property) import Michelson.Interpret (InterpretUntypedError(..), MichelsonFailed(..), RemainingSteps) -import Morley.Aliases (UntypedValue) +import Michelson.Untyped (OriginationOperation(..), mkContractAddress) +import Morley.Aliases (UntypedContract, UntypedValue) import Morley.Runtime (InterpreterError(..), InterpreterOp(..), InterpreterRes(..), interpreterPure) import Morley.Runtime.GState +import Morley.Runtime.TxData import Morley.Test.Dummy import Morley.Test.Util (failedProp, succeededProp) import Tezos.Address (Address) import Tezos.Core (Mutez, Timestamp) +---------------------------------------------------------------------------- +-- Some internals (they are here because TH makes our very existence much harder) +---------------------------------------------------------------------------- + +data InternalState = InternalState + { _isMaxSteps :: !RemainingSteps + , _isNow :: !Timestamp + , _isGState :: !GState + , _isOperations :: ![InterpreterOp] + -- ^ Operations to be interpreted when 'TOValidate' is encountered. + } + +makeLenses ''InternalState + +---------------------------------------------------------------------------- +-- Interface +---------------------------------------------------------------------------- + +-- | Operations supported by this testing engine. +-- Each operation has a corresponding top-level function where its semantics is defined. +-- Usually you shouldn't use this type directly. +data TestOperation + = TOInterpreterOp !InterpreterOp + | TOValidate !IntegrationalValidator + | TOSetMaxSteps !RemainingSteps + | TOSetNow !Timestamp + -- | Validator for integrational testing. -- If an error is expected, it should be 'Left' with validator for errors. -- Otherwise it should check final global state and its updates. type IntegrationalValidator = Either (InterpreterError -> Bool) SuccessValidator +-- | Validator for integrational testing that expects successful execution. type SuccessValidator = (GState -> [GStateUpdate] -> Either Text ()) +type IntegrationalScenarioState = [TestOperation] + +-- | A monad inside which integrational tests can be described using +-- do-notation. +type IntegrationalScenarioM = State IntegrationalScenarioState + +-- | A dummy data type that ensures that `validate` is called in the +-- end of each scenario. It is intentionally not exported. +data Validated = Validated + +type IntegrationalScenario = IntegrationalScenarioM Validated + -- | Integrational test that executes given operations and validates -- them using given validator. It can fail using 'Expectation' -- capability. -integrationalTestExpectation :: - Timestamp -> RemainingSteps -> [InterpreterOp] -> IntegrationalValidator -> Expectation +-- It starts with 'initGState' and some reasonable dummy values for +-- gas limit and current timestamp. You can update blockchain state +-- by performing some operations. +integrationalTestExpectation :: IntegrationalScenario -> Expectation integrationalTestExpectation = integrationalTest (maybe pass (expectationFailure . toString)) --- | Integrational test that executes given operations and validates --- them using given validator. It can fail using 'Property' --- capability. It can be used with QuickCheck's @forAll@ to make a +-- | Integrational test similar to 'integrationalTestExpectation'. +-- It can fail using 'Property' capability. +-- It can be used with QuickCheck's @forAll@ to make a -- property-based test with arbitrary data. -integrationalTestProperty :: - Timestamp -> RemainingSteps -> [InterpreterOp] -> IntegrationalValidator -> Property +integrationalTestProperty :: IntegrationalScenario -> Property integrationalTestProperty = integrationalTest (maybe succeededProp failedProp) --- | 'integrationalTestExpectation' which uses dummy now and max steps. -simplerIntegrationalTestExpectation :: [InterpreterOp] -> IntegrationalValidator -> Expectation -simplerIntegrationalTestExpectation = - integrationalTestExpectation dummyNow dummyMaxSteps +-- | Originate a contract with given initial storage and balance. Its +-- address is returned. +originate :: + UntypedContract -> UntypedValue -> Mutez -> IntegrationalScenarioM Address +originate contract value balance = + mkContractAddress origination <$ putOperation (TOInterpreterOp originateOp) + where + origination = (dummyOrigination value contract) {ooBalance = balance} + originateOp = OriginateOp origination --- | 'integrationalTestProperty' which uses dummy now and max steps. -simplerIntegrationalTestProperty :: [InterpreterOp] -> IntegrationalValidator -> Property -simplerIntegrationalTestProperty = - integrationalTestProperty dummyNow dummyMaxSteps +-- | Transfer tokens to given address. +transfer :: TxData -> Address -> IntegrationalScenarioM () +transfer txData destination = + putOperation (TOInterpreterOp $ TransferOp destination txData) -integrationalTest :: - (Maybe Text -> res) - -> Timestamp - -> RemainingSteps - -> [InterpreterOp] - -> IntegrationalValidator - -> res -integrationalTest howToFail now maxSteps operations validator = - validateResult - howToFail - validator - (interpreterPure now maxSteps initGState operations) +-- | Execute all operations that were added to the scenarion since +-- last 'validate' call. If validator fails, the execution will be aborted. +validate :: IntegrationalValidator -> IntegrationalScenario +validate validator = Validated <$ putOperation (TOValidate validator) -validateResult :: - (Maybe Text -> res) - -> IntegrationalValidator - -> Either InterpreterError InterpreterRes - -> res -validateResult howToFail validator result = - case (validator, result) of - (Left validateError, Left err) - | validateError err -> doNotFail - (_, Left err) -> - doFail $ "Unexpected interpreter error: " <> pretty err - (Left _, Right _) -> - doFail $ "Interpreter unexpectedly didn't fail" - (Right validateUpdates, Right ir) - | Left bad <- validateUpdates (_irGState ir) (_irUpdates ir) -> - doFail $ - "Updates are incorrect: " +| bad |+ ". Updates are: \n" +| - blockListF (_irUpdates ir) |+ "" - | otherwise -> doNotFail - where - doNotFail = howToFail Nothing - doFail = howToFail . Just +-- | Make all further interpreter calls (which are triggered by the +-- 'validate' function) use given timestamp as the current one. +setNow :: Timestamp -> IntegrationalScenarioM () +setNow = putOperation . TOSetNow +-- | Make all further interpreter calls (which are triggered by the +-- 'validate' function) use given gas limit. +setMaxSteps :: RemainingSteps -> IntegrationalScenarioM () +setMaxSteps = putOperation . TOSetMaxSteps + +putOperation :: TestOperation -> IntegrationalScenarioM () +putOperation op = id <>= one op + ---------------------------------------------------------------------------- -- Validators to be used within 'IntegrationalValidator' ---------------------------------------------------------------------------- +-- | 'SuccessValidator' that always passes. +expectAnySuccess :: SuccessValidator +expectAnySuccess _ _ = pass + -- | Check that storage value is updated for given address. Takes a -- predicate that is used to check the value. -- -- It works even if updates are not filtered (i. e. a value can be -- updated more than once). -expectStorageValue :: +expectStorageUpdate :: Address -> (UntypedValue -> Either Text ()) -> SuccessValidator -expectStorageValue addr predicate _ updates = +expectStorageUpdate addr predicate _ updates = case List.find checkAddr (reverse updates) of Nothing -> Left $ "Storage of " +| addr |+ " is not updated" Just (GSSetStorageValue _ val) -> first (("Storage of " +| addr |+ "is updated incorrectly: ") <>) $ predicate val -- 'checkAddr' ensures that only 'GSSetStorageValue' can be found - Just _ -> error "expectStorageValue: internal error" + Just _ -> error "expectStorageUpdate: internal error" where checkAddr (GSSetStorageValue addr' _) = addr' == addr checkAddr _ = False --- | Like 'expectStorageValue', but expects a constant. -expectStorageConstant :: +-- | Like 'expectStorageUpdate', but expects a constant. +expectStorageUpdateConst :: Address -> UntypedValue -> SuccessValidator -expectStorageConstant addr expected = - expectStorageValue addr predicate +expectStorageUpdateConst addr expected = + expectStorageUpdate addr predicate where predicate val | val == expected = pass | otherwise = Left $ "expected " +| expected |+ "" +-- | Check that eventually address has some particular storage value. +expectStorageConst :: Address -> UntypedValue -> SuccessValidator +expectStorageConst addr expected gs _ = + case gsAddresses gs ^. at addr of + Just (ASContract cs) + | csStorage cs == expected -> pass + | otherwise -> + Left $ intro +| "its storage is " +| csStorage cs |+ "" + Just (ASSimple {}) -> + Left $ intro +| "it's a simple address" + Nothing -> Left $ intro +| "it's unknown" + where + intro = "Expected " +| addr |+ " to have storage " +| expected |+ ", but " + -- | Check that eventually address has some particular balance. expectBalance :: Address -> Mutez -> SuccessValidator expectBalance addr balance gs _ = @@ -157,7 +221,7 @@ -- For example: -- -- expectBalance bal addr `composeValidators` --- expectStorageConstant addr2 ValueUnit +-- expectStorageUpdateConst addr2 ValueUnit composeValidators :: SuccessValidator -> SuccessValidator @@ -165,8 +229,81 @@ composeValidators val1 val2 gState updates = val1 gState updates >> val2 gState updates +-- | Compose a list of success validators. +composeValidatorsList :: [SuccessValidator] -> SuccessValidator +composeValidatorsList = foldl' composeValidators expectAnySuccess + +-- | Check that interpreter failed due to gas exhaustion. expectGasExhaustion :: InterpreterError -> Bool expectGasExhaustion = \case IEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> True _ -> False + +-- | Expect that interpretation of contract with given address ended +-- with [FAILED]. +expectMichelsonFailed :: Address -> InterpreterError -> Bool +expectMichelsonFailed addr = + \case + IEInterpreterFailed failedAddr (RuntimeFailure {}) -> addr == failedAddr + _ -> False + +---------------------------------------------------------------------------- +-- Implementation of the testing engine +---------------------------------------------------------------------------- + +initIS :: InternalState +initIS = InternalState + { _isNow = dummyNow + , _isMaxSteps = dummyMaxSteps + , _isGState = initGState + , _isOperations = mempty + } + +integrationalTest :: + (Maybe Text -> res) + -> IntegrationalScenario + -> res +integrationalTest howToFail scenario = + howToFail $ leftToMaybe $ runExcept (runStateT integrationalTestDo initIS) + where + operations = execState scenario [] + integrationalTestDo :: StateT InternalState (Except Text) () + integrationalTestDo = mapM_ integrationalTestStep operations + +integrationalTestStep :: TestOperation -> StateT InternalState (Except Text) () +integrationalTestStep = + \case + TOInterpreterOp intOp -> isOperations <>= one intOp + TOValidate validator -> do + now <- use isNow + maxSteps <- use isMaxSteps + gState <- use isGState + ops <- use isOperations + mUpdatedGState <- + lift $ validateResult validator $ interpreterPure now maxSteps gState ops + isOperations .= mempty + whenJust mUpdatedGState $ \newGState -> isGState .= newGState + TOSetNow newNow -> isNow .= newNow + TOSetMaxSteps newMaxSteps -> isMaxSteps .= newMaxSteps + +validateResult :: + IntegrationalValidator + -> Either InterpreterError InterpreterRes + -> Except Text (Maybe GState) +validateResult validator result = + case (validator, result) of + (Left validateError, Left err) + | validateError err -> pure Nothing + (_, Left err) -> + doFail $ "Unexpected interpreter error: " <> pretty err + (Left _, Right _) -> + doFail $ "Interpreter unexpectedly didn't fail" + (Right validateUpdates, Right ir) + | Left bad <- validateUpdates (_irGState ir) (_irUpdates ir) -> + doFail $ + "Updates are incorrect: " +| bad |+ ". Updates are: \n" +| + blockListF (_irUpdates ir) |+ "" + | otherwise -> pure $ Just $ _irGState ir + where + doFail = throwError diff --git a/src/Tezos/Address.hs b/src/Tezos/Address.hs --- a/src/Tezos/Address.hs +++ b/src/Tezos/Address.hs @@ -8,6 +8,7 @@ -- * Formatting , formatAddress , parseAddress + , unsafeParseAddress ) where import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey) @@ -84,6 +85,9 @@ , ")" ] +-- | Parse an address from its human-readable textual representation +-- used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU"). Or +-- fail if it's invalid. parseAddress :: Text -> Either ParseAddressError Address parseAddress addressText = case parseKeyHash addressText of @@ -91,6 +95,11 @@ Left keyAddrErr -> first (ParseAddressBothFailed keyAddrErr) $ parseContractAddress addressText Right keyHash -> Right (KeyAddress keyHash) + +-- | Partial version of 'parseAddress' which assumes that the address +-- is correct. Can be used in tests. +unsafeParseAddress :: HasCallStack => Text -> Address +unsafeParseAddress = either (error . pretty) id . parseAddress data ParseContractAddressError = ParseContractAddressWrongBase58Check diff --git a/test/Test/Arbitrary.hs b/test/Test/Arbitrary.hs --- a/test/Test/Arbitrary.hs +++ b/test/Test/Arbitrary.hs @@ -7,8 +7,9 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Test.QuickCheck (Arbitrary(..), Gen, choose, elements, listOf, oneof, vector) +import Test.QuickCheck (Arbitrary(..), Gen, choose, elements, listOf, oneof, suchThatMap, vector) import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary(..)) +import Test.QuickCheck.Instances.Semigroup () import Test.QuickCheck.Instances.Text () import Michelson.Untyped @@ -55,6 +56,12 @@ smallSize :: Gen Int smallSize = choose (0, 3) +smallList :: Arbitrary a => Gen [a] +smallList = smallSize >>= vector + +smallList1 :: Arbitrary a => Gen (NonEmpty a) +smallList1 = smallList `suchThatMap` nonEmpty + instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Contract op) instance (Arbitrary op) => Arbitrary (Contract op) where arbitrary = Contract <$> arbitrary <*> arbitrary <*> arbitrary @@ -204,18 +211,10 @@ , ValueRight <$> arbitrary , ValueSome <$> arbitrary , pure ValueNone - , (do size1 <- smallSize - l1 <- vector size1 - pure $ ValueSeq l1 - ) - , (do size1 <- smallSize - l1 <- vector size1 - pure $ ValueMap l1 - ) - , (do size1 <- smallSize - l1 <- vector size1 - pure $ ValueLambda l1 - ) + , pure ValueNil + , ValueSeq <$> smallList1 + , ValueMap <$> smallList1 + , ValueLambda <$> smallList1 ] instance (Arbitrary op, ToADTArbitrary op) => ToADTArbitrary (Elt op) diff --git a/test/Test/Interpreter.hs b/test/Test/Interpreter.hs --- a/test/Test/Interpreter.hs +++ b/test/Test/Interpreter.hs @@ -18,6 +18,7 @@ import Test.Interpreter.CallSelf (selfCallerSpec) import Test.Interpreter.Compare (compareSpec) import Test.Interpreter.Conditionals (conditionalsSpec) +import Test.Interpreter.EnvironmentSpec (environmentSpec) import Test.Interpreter.StringCaller (stringCallerSpec) spec :: Spec @@ -62,6 +63,7 @@ conditionalsSpec stringCallerSpec selfCallerSpec + environmentSpec specWithTypedContract "contracts/steps_to_quota_test1.tz" $ \contract -> do it "Amount of steps should reduce" $ do diff --git a/test/Test/Interpreter/CallSelf.hs b/test/Test/Interpreter/CallSelf.hs --- a/test/Test/Interpreter/CallSelf.hs +++ b/test/Test/Interpreter/CallSelf.hs @@ -10,14 +10,14 @@ import Michelson.Interpret (ContractEnv(..), InterpreterState(..), RemainingSteps(..)) import Michelson.Typed -import Michelson.Untyped (OriginationOperation(..), mkContractAddress) import qualified Michelson.Untyped as Untyped import Morley.Aliases (UntypedContract) -import Morley.Runtime (InterpreterOp(..), TxData(..)) import Morley.Runtime.GState import Morley.Test (ContractPropValidator, contractProp, specWithContract) import Morley.Test.Dummy import Morley.Test.Integrational +import Tezos.Address (Address) +import Tezos.Core (unsafeMkMutez) selfCallerSpec :: Spec selfCallerSpec = @@ -69,8 +69,7 @@ prop propertyDescription $ forAll genFixture $ \fixture -> - integrationalTestProperty dummyNow (fMaxSteps fixture) - (operations fixture) (integValidator fixture) + integrationalTestProperty (integrationalScenario uSelfCaller fixture) where -- Environment for unit test unitContractEnv = dummyContractEnv @@ -85,26 +84,24 @@ "it fails due to gas limit if the number is large, otherwise the " <> "storage is updated to the number of calls" - operations :: Fixture -> [InterpreterOp] - operations fixture = [originateOp, transferOp fixture] - - origination :: OriginationOperation - origination = dummyOrigination (Untyped.ValueInt 0) uSelfCaller - address = mkContractAddress origination - originateOp = OriginateOp origination - - txData :: Fixture -> TxData - txData fixture = TxData +integrationalScenario :: UntypedContract -> Fixture -> IntegrationalScenario +integrationalScenario uSelfCaller fixture = do + setMaxSteps (fMaxSteps fixture) + address <- originate uSelfCaller (Untyped.ValueInt 0) (unsafeMkMutez 1) + let + txData :: TxData + txData = TxData { tdSenderAddress = genesisAddress , tdParameter = Untyped.ValueInt (fromIntegral $ fParameter fixture) , tdAmount = minBound } - transferOp fixture = TransferOp address (txData fixture) - - integValidator :: Fixture -> IntegrationalValidator - integValidator fixture + transfer txData address + validate (validator address) + where + validator :: Address -> IntegrationalValidator + validator address | fExpectSuccess fixture = let expectedStorage = Untyped.ValueInt (fromIntegral $ fParameter fixture) - in Right $ expectStorageConstant address expectedStorage + in Right $ expectStorageUpdateConst address expectedStorage | otherwise = Left expectGasExhaustion diff --git a/test/Test/Interpreter/EnvironmentSpec.hs b/test/Test/Interpreter/EnvironmentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Interpreter/EnvironmentSpec.hs @@ -0,0 +1,104 @@ +-- | Tests for the 'environment.tz' contract + +module Test.Interpreter.EnvironmentSpec + ( environmentSpec + ) where + +import Test.Hspec (Spec) +import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) +import Test.QuickCheck (Arbitrary(..), choose) +import Test.QuickCheck.Instances.Text () + +import Michelson.Interpret (RemainingSteps(..)) +import Michelson.Typed +import qualified Michelson.Untyped as Untyped +import Morley.Aliases (UntypedContract, UntypedValue) +import Morley.Runtime.GState +import Morley.Test (specWithContract) +import Morley.Test.Integrational +import Tezos.Address +import Tezos.Core + +environmentSpec :: Spec +environmentSpec = + specWithContract "contracts/environment.tz" specImpl + +data Fixture = Fixture + { fNow :: !Timestamp + , fMaxSteps :: !RemainingSteps + , fPassOriginatedAddress :: !Bool + , fBalance :: !Mutez + , fAmount :: !Mutez + } deriving (Show) + +instance Arbitrary Fixture where + arbitrary = do + fNow <- timestampFromSeconds @Int <$> choose (100000, 111111) + fMaxSteps <- RemainingSteps <$> choose (1000, 1200) + fPassOriginatedAddress <- arbitrary + fBalance <- unsafeMkMutez <$> choose (1, 1234) + fAmount <- unsafeMkMutez <$> choose (1, 42) + return Fixture {..} + +shouldExpectFailed :: Fixture -> Bool +shouldExpectFailed fixture = + or + [ fBalance fixture > unsafeMkMutez 1000 + , fNow fixture < timestampFromSeconds @Int 100500 + , fPassOriginatedAddress fixture + , fAmount fixture < unsafeMkMutez 15 + ] + +shouldReturn :: Fixture -> UntypedValue +shouldReturn fixture + | fMaxSteps fixture - consumedGas > 1000 = Untyped.ValueTrue + | otherwise = Untyped.ValueFalse + where + consumedGas = 24 + +specImpl :: + (UntypedContract, Contract ('Tc 'CAddress) ('Tc 'CBool)) + -> Spec +specImpl (uEnvironment, _environment) = do + let scenario = integrationalScenario uEnvironment + modifyMaxSuccess (min 12) $ + prop description $ + integrationalTestExpectation . scenario + where + description = + "This contract fails under conditions described in a comment at the " <> + "beginning of this contract and returns whether remaining gas is " <> + "greater than 1000" + +integrationalScenario :: UntypedContract -> Fixture -> IntegrationalScenario +integrationalScenario contract fixture = do + -- First of all let's set desired gas limit and NOW + setNow $ fNow fixture + setMaxSteps $ fMaxSteps fixture + + -- Then let's originated the 'environment.tz' contract + environmentAddress <- + originate contract Untyped.ValueFalse (fBalance fixture) + + -- And transfer tokens to it + let + param + | fPassOriginatedAddress fixture = environmentAddress + | otherwise = genesisAddress + txData = TxData + { tdSenderAddress = genesisAddress + , tdParameter = Untyped.ValueString (formatAddress param) + , tdAmount = fAmount fixture + } + transfer txData environmentAddress + + -- Execute operations and check that interpreter fails when one of + -- failure conditions is met or updates environment's storage + -- approriately + let + validator + | shouldExpectFailed fixture = + Left $ expectMichelsonFailed environmentAddress + | otherwise = + Right $ expectStorageConst environmentAddress $ shouldReturn fixture + validate validator diff --git a/test/Test/Interpreter/StringCaller.hs b/test/Test/Interpreter/StringCaller.hs --- a/test/Test/Interpreter/StringCaller.hs +++ b/test/Test/Interpreter/StringCaller.hs @@ -1,4 +1,6 @@ --- | Tests for the 'stringCaller.tz' contract. +-- | Tests for the 'stringCaller.tz' contract and its interaction with +-- the 'idString.tz' contract. Both of them have comments describing +-- their behavior. module Test.Interpreter.StringCaller ( stringCallerSpec @@ -9,15 +11,12 @@ import Test.QuickCheck.Instances.Text () import Michelson.Typed -import Michelson.Untyped (OriginationOperation(..), mkContractAddress) import qualified Michelson.Untyped as Untyped -import Morley.Aliases (UntypedContract, UntypedValue) -import Morley.Runtime (InterpreterOp(..), TxData(..)) +import Morley.Aliases (UntypedContract) import Morley.Runtime.GState import Morley.Test (specWithContract) -import Morley.Test.Dummy import Morley.Test.Integrational -import Tezos.Address (formatAddress) +import Tezos.Address import Tezos.Core stringCallerSpec :: Spec @@ -32,53 +31,111 @@ -> (UntypedContract, Contract ('Tc 'CString) ('Tc 'CString)) -> Spec specImpl (uStringCaller, _stringCaller) (uIdString, _idString) = do - it "stringCaller calls idString and updates its storage with a constant" $ - simplerIntegrationalTestExpectation - (operations newValueConstant) - (Right (updatesValidator newValueConstant)) + let scenario = integrationalScenario uStringCaller uIdString + let suffix = + " and properly updates balances. But fails if idString's balance is ≥ \ + \1000 and NOW is ≥ 500" + it ("stringCaller calls idString and updates its storage with a constant" + <> suffix) $ + integrationalTestExpectation (scenario constStr) -- The test is trivial, so it's kinda useless to run it many times modifyMaxSuccess (const 2) $ - prop "stringCaller calls idString and updates its storage with an arbitrary value" $ - \(Untyped.ValueString -> newValue) -> simplerIntegrationalTestProperty - (operations newValue) - (Right (updatesValidator newValue)) + prop ("stringCaller calls idString and updates its storage with an arbitrary value" + <> suffix) $ + \str -> integrationalTestProperty (scenario str) where - newValueConstant = Untyped.ValueString "caller" + constStr = "caller" - idStringOrigination :: OriginationOperation - idStringOrigination = - dummyOrigination (Untyped.ValueString "hello") uIdString - originateIdString = OriginateOp idStringOrigination - idStringAddress = mkContractAddress idStringOrigination +integrationalScenario :: UntypedContract -> UntypedContract -> Text -> IntegrationalScenario +integrationalScenario stringCaller idString str = do + let + initIdStringBalace = unsafeMkMutez 900 + initStringCallerBalance = unsafeMkMutez 500 - stringCallerOrigination :: OriginationOperation - stringCallerOrigination = - dummyOrigination (Untyped.ValueString $ formatAddress idStringAddress) - uStringCaller - originateStringCaller = OriginateOp stringCallerOrigination - stringCallerAddress = mkContractAddress stringCallerOrigination + -- Originate both contracts + idStringAddress <- + originate idString (Untyped.ValueString "hello") initIdStringBalace + stringCallerAddress <- + originate stringCaller (Untyped.ValueString $ formatAddress idStringAddress) + initStringCallerBalance - txData :: UntypedValue -> TxData - txData newValue = TxData + -- NOW = 500, so stringCaller shouldn't fail + setNow (timestampFromSeconds @Int 500) + + -- Transfer 100 tokens to stringCaller, it should transfer 300 tokens + -- to idString + let + newValue = Untyped.ValueString str + txData = TxData { tdSenderAddress = genesisAddress , tdParameter = newValue - , tdAmount = minBound + , tdAmount = unsafeMkMutez 100 } - transferToStringCaller newValue = - TransferOp stringCallerAddress (txData newValue) + transferToStringCaller = transfer txData stringCallerAddress + transferToStringCaller - operations newValue = - [ originateIdString - , originateStringCaller - , transferToStringCaller newValue - ] + -- Execute operations and check balances and storage of 'idString' + do + let + -- `stringCaller.tz` transfers 300 mutez. + -- 'idString.tz' transfers 5 tokens. + -- Also 100 tokens are transferred from the genesis address. + expectedStringCallerBalance = unsafeMkMutez (500 - 300 + 100) + expectedIdStringBalance = unsafeMkMutez (900 + 300 - 5) + expectedConstAddrBalance = unsafeMkMutez 5 - -- `stringCaller.tz` transfers 2 mutez. - expectedIdStringBalance = - ooBalance idStringOrigination `unsafeAddMutez` unsafeMkMutez 2 + updatesValidator :: SuccessValidator + updatesValidator = composeValidatorsList + [ expectStorageUpdateConst idStringAddress newValue + , expectBalance idStringAddress expectedIdStringBalance + , expectBalance stringCallerAddress expectedStringCallerBalance + , expectBalance constAddr expectedConstAddrBalance + ] + validate (Right updatesValidator) - updatesValidator :: UntypedValue -> SuccessValidator - updatesValidator newValue = - expectStorageConstant idStringAddress newValue `composeValidators` - expectBalance idStringAddress expectedIdStringBalance + -- Now let's transfer 100 tokens to stringCaller again. + transferToStringCaller + + -- This time execution should fail, because idString should fail + -- because its balance is greater than 1000. + void $ validate (Left $ expectMichelsonFailed idStringAddress) + + -- We can also send tokens from idString to tz1 address directly + let + txDataToConst = TxData + { tdSenderAddress = idStringAddress + , tdParameter = Untyped.ValueUnit + , tdAmount = unsafeMkMutez 200 + } + transfer txDataToConst constAddr + + -- Let's check balance of idString and tz1 address + do + let + expectedIdStringBalance = unsafeMkMutez (900 + 300 - 5 - 200) + expectedConstAddrBalance = unsafeMkMutez (5 + 200) + + updatesValidator :: SuccessValidator + updatesValidator = composeValidatorsList + [ expectBalance idStringAddress expectedIdStringBalance + , expectBalance constAddr expectedConstAddrBalance + ] + + void $ validate (Right updatesValidator) + + -- Now we can transfer to stringCaller again and it should succeed + -- this time, because the balance of idString decreased + transferToStringCaller + + -- Let's simply assert that it should succeed to keep the scenario shorter + void $ validate (Right expectAnySuccess) + + -- Now let's set NOW to 600 and expect stringCaller to fail + setNow (timestampFromSeconds @Int 600) + transferToStringCaller + validate (Left $ expectMichelsonFailed stringCallerAddress) + +-- Address hardcoded in 'idString.tz'. +constAddr :: Address +constAddr = unsafeParseAddress "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU" diff --git a/test/Test/Macro.hs b/test/Test/Macro.hs --- a/test/Test/Macro.hs +++ b/test/Test/Macro.hs @@ -2,6 +2,8 @@ ( spec ) where +import qualified Data.List.NonEmpty as NE + import Morley.Macro import Morley.Types import Test.Hspec (Expectation, Spec, describe, it, shouldBe) @@ -163,11 +165,11 @@ expandedPapair = ValuePair (ValuePair (ValueInt 5) (ValueInt 5)) (ValueInt 5) parsedLambdaWithMac :: Value ParsedOp - parsedLambdaWithMac = ValueLambda - [MAC (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn)] + parsedLambdaWithMac = ValueLambda $ + one (MAC (PAPAIR (P (F (noAnn, noAnn)) (P (F (noAnn, noAnn)) (F (noAnn, noAnn)))) noAnn noAnn)) expandedLambdaWithMac :: Value Op - expandedLambdaWithMac = ValueLambda + expandedLambdaWithMac = ValueLambda . NE.fromList $ [ Op {unOp = DIP [Op {unOp = PAIR noAnn noAnn noAnn noAnn}]} , Op {unOp = PAIR noAnn noAnn noAnn noAnn} ] diff --git a/test/Test/Parser.hs b/test/Test/Parser.hs --- a/test/Test/Parser.hs +++ b/test/Test/Parser.hs @@ -2,6 +2,7 @@ ( spec ) where +import qualified Data.List.NonEmpty as NE import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy) import Text.Megaparsec (parse) @@ -38,12 +39,20 @@ valueParserTest :: Expectation valueParserTest = do + P.parseNoEnv P.value "" "{}" `shouldBe` + (Right Mo.ValueNil) P.parseNoEnv P.value "" "{PUSH int 5;}" `shouldBe` - (Right $ Mo.ValueLambda [Mo.PRIM (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5))]) + (Right . Mo.ValueLambda $ NE.fromList + [Mo.PRIM (Mo.PUSH noAnn (Mo.Type (Mo.Tc Mo.CInt) noAnn) (Mo.ValueInt 5))] + ) P.parseNoEnv P.value "" "{1; 2}" `shouldBe` - (Right $ Mo.ValueSeq [Mo.ValueInt 1, Mo.ValueInt 2]) + (Right . Mo.ValueSeq $ NE.fromList + [Mo.ValueInt 1, Mo.ValueInt 2] + ) P.parseNoEnv P.value "" "{Elt 1 2; Elt 3 4}" `shouldBe` - (Right $ Mo.ValueMap [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)]) + (Right . Mo.ValueMap $ NE.fromList + [Mo.Elt (Mo.ValueInt 1) (Mo.ValueInt 2), Mo.Elt (Mo.ValueInt 3) (Mo.ValueInt 4)] + ) stringLiteralTest :: Expectation stringLiteralTest = do