Integrational.hs

{-# OPTIONS_GHC -Wno-deprecations #-}

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Utilities for integrational testing.
-- Example tests can be found in the 'morley-test' test suite.

module Michelson.Test.Integrational
  (
    -- * Re-exports
    TxData (..)
  -- * More genesis addresses which can be used in tests
  , genesisAddress
  , genesisAddress1
  , genesisAddress2
  , genesisAddress3
  , genesisAddress4
  , genesisAddress5
  , genesisAddress6

  -- * Testing engine
  , IntegrationalScenarioM
  , IntegrationalScenario
  , TestError (..)
  , integrationalTestExpectation
  , integrationalTestProp
  , originate
  , tOriginate
  , transfer
  , tTransfer
  , integrationalFail
  , unexpectedInterpreterError
  , setMaxSteps
  , modifyNow
  , setNow
  , rewindTime
  , withSender
  , setChainId
  , branchout
  , (?-)
  , offshoot

  -- * Validators
  , expectNoUpdates
  , expectNoStorageUpdates
  , expectStorageUpdate
  , expectStorageUpdateConst
  , expectBalance
  , expectStorage
  , expectStorageConst
  , tExpectStorageConst

  -- * Errors
  , attempt
  , expectError
  , catchExpectedError
  , expectGasExhaustion
  , expectMichelsonFailed

  -- * Lenses
  , isGState

  -- * Deprecated
  , integrationalTestProperty
  ) where

import Control.Lens (assign, at, makeLenses, makeLensesFor, modifying, (%=), (.=), (<>=), (?=))
import Control.Monad.Except (Except, catchError, runExcept, throwError, withExcept)
import qualified Data.List as List
import Data.Map as Map (empty, insert, lookup)
import Fmt (Buildable(..), blockListF, listF, pretty, (+|), (|+))
import Hedgehog (MonadTest)
import Named ((:!), arg)
import Test.Hspec (Expectation, expectationFailure)
import qualified Test.QuickCheck as QC

import Michelson.Interpret (InterpretError(..), MichelsonFailed(..), RemainingSteps)
import Michelson.Runtime
  (ExecutorError, ExecutorError'(..), ExecutorM, ExecutorOp(..), ExecutorRes(..),
  executeGlobalOperations, executeOrigination, runExecutorM, withGlobalOperation)
import Michelson.Runtime.GState
import Michelson.Runtime.TxData
import Michelson.Test.Dummy
import Michelson.Test.Util (failedProp, failedTest, succeededProp, succeededTest)
import Michelson.TypeCheck (TCError)
import qualified Michelson.Typed as Typed
import Michelson.Typed.Scope (ParameterScope, StorageScope, properParameterEvi, withDict)
import Michelson.Untyped (Contract, EpName, OriginationOperation(..), Value)
import Tezos.Address (Address)
import Tezos.Core (ChainId, Mutez, Timestamp, timestampPlusSeconds, unsafeMkMutez)

----------------------------------------------------------------------------
-- Some internals (they are here because TH makes our very existence much harder)
----------------------------------------------------------------------------

-- | A result of an executed operation.
type ExecutorResOrError a = Either ExecutorError (ExecutorRes, a)
type ExecutorResOrError' = Either ExecutorError ExecutorRes

data InternalState = InternalState
  { _isMaxSteps :: RemainingSteps
  , _isNow :: Timestamp
  , _isGState :: GState
  , _isInterpreterLog :: [ExecutorResOrError']
  -- ^ Store result of interpreted operations as they added.
  , _isExecutorResult :: Maybe ExecutorRes
  -- ^ Store the most recent result of interpreted operations.
  , _isContractsNames :: Map Address Text
  -- ^ Map from contracts addresses to humanreadable names.
  , _isSender :: Maybe Address
  -- ^ If set, all following transfers will be executed on behalf
  -- of the given contract.
  }

makeLenses ''InternalState

-- | When using 'branch' function for building test scenarios - names
-- of branches we are currently within.
newtype ScenarioBranchName = ScenarioBranchName { unTestBranch :: [Text] }

instance Buildable ScenarioBranchName where
  build = mconcat . intersperse "/" . map build . unTestBranch

----------------------------------------------------------------------------
-- Interface
----------------------------------------------------------------------------

-- | A monad inside which integrational tests can be described using
-- do-notation.
type IntegrationalScenarioM = StateT InternalState (Except ScenarioError)

type IntegrationalScenario = IntegrationalScenarioM ()

newtype ExpectedStorage = ExpectedStorage Value deriving stock (Show)
newtype ExpectedBalance = ExpectedBalance Mutez deriving stock (Show)

data AddressName = AddressName (Maybe Text) Address deriving stock (Show)

addrToAddrName :: Address -> InternalState -> AddressName
addrToAddrName addr iState =
  AddressName (lookup addr (iState ^. isContractsNames)) addr

addrNameToAddr :: AddressName -> Address
addrNameToAddr (AddressName _ addr) = addr

instance Buildable AddressName where
  build (AddressName mbName addr) =
    build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName

type IntegrationalExecutorError = ExecutorError' AddressName

data TestError
  = InterpreterError IntegrationalExecutorError
  | UnexpectedInterpreterError Text IntegrationalExecutorError
  | UnexpectedTypeCheckError TCError
  | ExpectingInterpreterToFail
  | IncorrectUpdates TestError [GStateUpdate]
  | IncorrectStorageUpdate AddressName Text
  | InvalidStorage AddressName ExpectedStorage Text
  | StoragePredicateMismatch AddressName Text
  | InvalidBalance AddressName ExpectedBalance Text
  | UnexpectedUpdates (NonEmpty GStateUpdate)
  | ValidatingEmptyScenario
  | CustomTestError Text
  deriving stock (Show)

instance Buildable TestError where
  build (InterpreterError iErr) =
    "Interpreter failed: " +| iErr |+ ""
  build (UnexpectedInterpreterError reason iErr) =
    "Unexpected interpreter error. Reason: " +| reason |+ ". Got: " +| iErr |+ ""
  build (UnexpectedTypeCheckError tcErr) =
    "Unexpected type check error. Reason: " +| tcErr |+ ""
  build ExpectingInterpreterToFail =
    "Interpreter unexpectedly didn't fail"
  build (IncorrectUpdates vErr updates) =
    "Updates are incorrect: " +| vErr |+ " . Updates are:"
    +| blockListF updates |+ ""
  build (IncorrectStorageUpdate addr msg) =
    "Storage of " +| addr |+ " is updated incorrectly: " +| msg |+ ""
  build (InvalidStorage addr (ExpectedStorage expected) msg) =
    "Expected " +| addr |+ " to have storage " +| expected |+ ", but " +| msg |+ ""
  build (StoragePredicateMismatch addr msg) =
    "Expected " +| addr |+ " to have storage that matches the predicate, but" +| msg |+ ""
  build (InvalidBalance addr (ExpectedBalance expected) msg) =
    "Expected " +| addr |+ " to have balance " +| expected |+ ", but " +| msg |+ ""
  build (UnexpectedUpdates updates) =
    "Did not expect certain updates, but there are some: " +| listF updates |+ ""
  build ValidatingEmptyScenario =
    "Validating empty scenario"
  build (CustomTestError msg) = pretty msg

instance Exception TestError where
  displayException = pretty

-- | Overall information about test scenario error.
data ScenarioError = ScenarioError
  { _seBranch :: ScenarioBranchName
  , _seError :: TestError
  }

makeLensesFor [("_seBranch", "seBranch")] ''ScenarioError

instance Buildable ScenarioError where
  build (ScenarioError br err) =
    let builtBranch
          | nullScenarioBranch br = ""
          | otherwise = "In '" +| br |+ "' branch:\n"
    in builtBranch <> build err

-- | Integrational test that executes given operations and validates
-- them. It can fail using 'Expectation' capability.
-- 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
  :: HasCallStack
  => IntegrationalScenario -> Expectation
integrationalTestExpectation =
  integrationalTest (maybe pass (expectationFailure . pretty))

-- | Integrational test similar to 'integrationalTestExpectation'.
-- It can fail using 'QC.Property' capability.
-- It can be used with QuickCheck's @forAll@ to make a
-- property-based test with arbitrary data.
integrationalTestProperty :: IntegrationalScenario -> QC.Property
integrationalTestProperty =
  integrationalTest (maybe succeededProp (failedProp . pretty))
{-# DEPRECATED integrationalTestProperty "Use 'integrationalTestProp' instead." #-}

-- | Integrational test similar to 'integrationalTestExpectation'.
-- It can fail using 'Property' capability.
-- It can be used with Hedgehog's @forAll@ to make a
-- property-based test with arbitrary data.
integrationalTestProp :: MonadTest m => IntegrationalScenario -> m ()
integrationalTestProp scenario =
  integrationalTest (maybe succeededTest (failedTest . pretty)) scenario

-- | Helper function which provides the results of the given operations.
interpret :: ExecutorM a -> IntegrationalScenarioM (ExecutorResOrError a)
interpret action = do
  now <- use isNow
  maxSteps <- use isMaxSteps
  gState <- use isGState
  let interpretedResult = runExecutorM now maxSteps gState action
  whenRight interpretedResult $ \(result, _) -> isGState .= _erGState result
  return interpretedResult

-- | Interprets provided list of operations.
registerInterpretation :: [ExecutorOp] -> IntegrationalScenarioM ()
registerInterpretation ops =
  interpret (executeGlobalOperations ops) <&> fmap fst >>= putResult

-- | Originate a contract with given initial storage and balance. Its
-- address is returned.
originate :: Contract -> Text -> Value -> Mutez -> IntegrationalScenarioM Address
originate contract contractName value balance = do
  is <- get
  result <- interpret $ withGlobalOperation (OriginateOp origination)
        $ executeOrigination origination
  putResult $ fmap fst result
  address <- either (interpreterError is) (pure . snd) $ result

  isContractsNames %= insert address contractName
  return address
  where
    interpreterError :: InternalState -> ExecutorError -> IntegrationalScenarioM a
    interpreterError is = integrationalFail . InterpreterError . mkError is

    origination = (dummyOrigination value contract) {ooBalance = balance}

-- | Like 'originate', but for typed contract and value.
tOriginate ::
     (ParameterScope cp, StorageScope st)
  => Typed.Contract cp st
  -> Text
  -> Typed.Value st
  -> Mutez
  -> IntegrationalScenarioM Address
tOriginate contract name value balance =
  originate (Typed.convertContract contract) name
    (Typed.untypeValue value) balance

-- | Transfer tokens to a given address.
transfer :: TxData -> Address -> IntegrationalScenarioM ()
transfer txData destination = do
  mSender <- use isSender
  let unwrappedData = maybe id (set tdSenderAddressL) mSender txData
  registerInterpretation [TransferOp destination unwrappedData]

-- | Similar to 'transfer', for typed values.
-- Note that it works with untyped 'Address' and does not check that
-- entrypoint with given name is present and has the expected type.
-- Passed value must correspond to the entrypoint argument type, not
-- the parameter type of the contract (and must be unit for implicit
-- accounts).
tTransfer
  :: forall arg.
     (ParameterScope arg)
  => "from" :! Address
  -> "to" :! Address
  -> Mutez
  -> EpName
  -> Typed.Value arg
  -> IntegrationalScenarioM ()
tTransfer (arg #from -> from) (arg #to -> to) money epName param =
  let txData = TxData
        { tdSenderAddress = from
        , tdParameter =
            withDict (properParameterEvi @arg) $
            Typed.untypeValue param
        , tdEntrypoint = epName
        , tdAmount = money
        }
  in transfer txData to

-- | Validator for integrational testing that expects successful execution.
validate
  :: (InternalState -> GState -> [GStateUpdate] -> Either TestError ())
  -> IntegrationalScenario
validate validator = do
  iState <- get
  interpreterResult <- use isExecutorResult
  case interpreterResult of
    Nothing -> integrationalFail ValidatingEmptyScenario
    Just result -> do
      case validator iState (_erGState result) (_erUpdates result) of
        Left bad -> integrationalFail $ IncorrectUpdates bad (_erUpdates result)
        Right () -> pass

-- | Just fail with given error.
integrationalFail :: TestError -> IntegrationalScenarioM anything
integrationalFail = throwError . ScenarioError emptyScenarioBranch

-- | Fail a test because an interpreter error happened unexpectedly, with the given reason.
unexpectedInterpreterError :: ExecutorError -> Text -> IntegrationalScenarioM a
unexpectedInterpreterError err reason = do
  iState <- get
  integrationalFail $ UnexpectedInterpreterError reason (mkError iState err)

-- | Make all further interpreter calls use the modified timestamp as the current one.
modifyNow :: (Timestamp -> Timestamp) -> IntegrationalScenarioM ()
modifyNow = modifying isNow

-- | Make all further interpreter calls use the given timestamp as the current one.
setNow :: Timestamp -> IntegrationalScenarioM ()
setNow time = modifyNow (const time)

-- | Increase current time by the given number of seconds.
rewindTime :: Integer -> IntegrationalScenarioM ()
rewindTime interval = modifyNow (flip timestampPlusSeconds interval)

-- | Make all further interpreter calls use the given gas limit.
setMaxSteps :: RemainingSteps -> IntegrationalScenarioM ()
setMaxSteps = assign isMaxSteps

-- | Pretend that given address initiates all the transfers within the
-- code block (i.e. @SENDER@ instruction will return this address).
withSender :: Address -> IntegrationalScenarioM a -> IntegrationalScenarioM a
withSender addr scenario = do
  prevSender <- use isSender
  isSender ?= addr
  scenario <* (isSender .= prevSender)

-- | Make all further interpreter calls use the given chain id.
setChainId :: ChainId -> IntegrationalScenarioM ()
setChainId = assign (isGState . gsChainIdL)

-- | Put an interpreted result to InternalState.
putResult :: ExecutorResOrError' -> IntegrationalScenarioM ()
putResult resOrErr = do
  isInterpreterLog <>= one resOrErr
  case resOrErr of
    Right res -> isExecutorResult .= Just res
    Left err -> do
      iState <- get
      integrationalFail $ InterpreterError $ mkError iState err

-- | Make branch names for a case when we are not within any branch.
emptyScenarioBranch :: ScenarioBranchName
emptyScenarioBranch = ScenarioBranchName []

-- | Add a new branch element to names provided by inner 'branch' calls.
appendScenarioBranch :: Text -> ScenarioBranchName -> ScenarioBranchName
appendScenarioBranch brName (ScenarioBranchName branches) =
  ScenarioBranchName (brName : branches)

nullScenarioBranch :: ScenarioBranchName -> Bool
nullScenarioBranch (ScenarioBranchName brs) = null brs

-- | Execute multiple testing scenarios independently, basing
-- them on scenario built till this point.
--
-- The following property holds for this function:
--
-- @ pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c] @.
--
-- In case of property failure in one of the branches no following branch is
-- executed.
--
-- Providing empty list of scenarios to this function causes error;
-- we do not require 'NonEmpty' here though for convenience.
branchout :: HasCallStack => [(Text, IntegrationalScenario)] -> IntegrationalScenario
branchout scenarios
  | null scenarios = error "branch: empty list of scenarios provided"
  | otherwise = do
      st <- get
      lift . forM_ scenarios $ \(name, scenario) ->
        withExcept (seBranch %~ appendScenarioBranch name) $
        evalStateT scenario st

-- | Make a tuple with name without extra syntactic noise.
(?-) :: Text -> a -> (Text, a)
(?-) = (,)
infixr 0 ?-

-- | Test given scenario with the state gathered till this moment;
-- if this scenario passes, go on as if it never happened.
offshoot :: Text -> IntegrationalScenario -> IntegrationalScenario
offshoot name scenario = do
  st <- get
  lift $
    withExcept (seBranch %~ appendScenarioBranch name) $
    evalStateT scenario st

----------------------------------------------------------------------------
-- Validators
----------------------------------------------------------------------------

-- | Check that there were no updates.
expectNoUpdates :: IntegrationalScenario
expectNoUpdates = validate $ \_ _ updates ->
  maybe pass (throwError . UnexpectedUpdates) . nonEmpty $ updates

-- | Check that there were no storage updates.
expectNoStorageUpdates :: IntegrationalScenario
expectNoStorageUpdates = validate $ \_ _ updates ->
  maybe pass (throwError . UnexpectedUpdates) . nonEmpty $
  filter isStorageUpdate updates
  where
    isStorageUpdate = \case
      GSSetStorageValue {} -> True
      _ -> False

-- | Check that storage value satisfies the given predicate.
expectStorage
  :: Address
  -> (Value -> Either TestError ())
  -> IntegrationalScenario
expectStorage addr predicate = validate $ \is gs _ ->
  let intro = StoragePredicateMismatch (addrToAddrName addr is) in
  case gsAddresses gs ^. at addr of
    Just (ASContract cs) ->
      predicate $ csStorage cs
    Just (ASSimple {}) ->
      Left $ intro $ "it's a simple address"
    Nothing -> Left $ intro $ "it's unknown"

-- | 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).
expectStorageUpdate
  :: Address
  -> (Value -> Either TestError ())
  -> IntegrationalScenario
expectStorageUpdate addr predicate = validate $ \is _ updates ->
  case List.find checkAddr (reverse updates) of
    Nothing -> Left $
      IncorrectStorageUpdate (addrToAddrName addr is) "storage wasn't updated"
    Just (GSSetStorageValue _ val _) ->
      first (IncorrectStorageUpdate (addrToAddrName addr is) . pretty) $
      predicate val
    -- 'checkAddr' ensures that only 'GSSetStorageValue' can be found
    Just _ -> error "expectStorageUpdate: internal error"
  where
    checkAddr (GSSetStorageValue addr' _ _) = addr' == addr
    checkAddr _ = False

-- | Like 'expectStorageUpdate', but expects a constant.
expectStorageUpdateConst
  :: Address
  -> Value
  -> IntegrationalScenario
expectStorageUpdateConst addr expected = do
  is <- get
  let
    predicate val
      | val == expected = pass
      | otherwise = Left $
        IncorrectStorageUpdate (addrToAddrName addr is) (pretty expected)
  expectStorageUpdate addr predicate

-- | Check that eventually address has some particular storage value.
expectStorageConst :: Address -> Value -> IntegrationalScenario
expectStorageConst addr expected = do
  is <- get
  let
    predicate val
      | val == expected = pass
      | otherwise = Left $
        InvalidStorage (addrToAddrName addr is) (ExpectedStorage expected) (pretty val)
  expectStorage addr predicate

-- | Similar to 'expectStorageConst', for typed stuff.
tExpectStorageConst
  :: forall st.
     (StorageScope st)
  => Address -> Typed.Value st -> IntegrationalScenario
tExpectStorageConst addr expected =
  expectStorageConst addr (Typed.untypeValue expected)

-- | Check that eventually address has some particular balance.
expectBalance :: Address -> Mutez -> IntegrationalScenario
expectBalance addr balance = validate $ \is gs _ ->
  let realBalance = maybe (unsafeMkMutez 0) asBalance (gsAddresses gs ^. at addr) in
  if realBalance == balance then pass
  else
    Left
    $ InvalidBalance (addrToAddrName addr is) (ExpectedBalance balance)
    $ "its actual balance is: " <> pretty realBalance


-- | Attempt to run an action and return its result or, if interpretation fails, an error.
attempt :: IntegrationalScenarioM a -> IntegrationalScenarioM (Either ExecutorError a)
attempt ma = catchError (Right <$> ma) $ \case
  ScenarioError _ (InterpreterError err) -> pure . Left $ addrNameToAddr <$> err
  err -> throwError err

-- | Run an action that is expected to fail.
-- If the action fails, the test succeeds and the error is returned.
-- If the action succeeds, the test fails.
expectError :: IntegrationalScenarioM a -> IntegrationalScenarioM ExecutorError
expectError scenario = catchExpectedError scenario pure

-- | Run an action that is expected to fail.
--
-- In @action `catchExpectedError` f@:
-- If the action fails, @f@ is applied to the error.
-- If the action succeeds, the test fails.
catchExpectedError
  :: IntegrationalScenarioM a
  -> (ExecutorError -> IntegrationalScenarioM b)
  -> IntegrationalScenarioM b
catchExpectedError scenario handle =
  attempt scenario >>= \case
    Left err -> handle err
    Right _ -> integrationalFail ExpectingInterpreterToFail

-- | Check that interpreter failed due to gas exhaustion.
expectGasExhaustion :: ExecutorError -> IntegrationalScenario
expectGasExhaustion =
  \case
    EEInterpreterFailed _ (RuntimeFailure (MichelsonGasExhaustion, _)) -> pass
    err -> unexpectedInterpreterError err "expected runtime failure due to gas exhaustion"

-- | Expect that interpretation of contract with given address ended
-- with [FAILED].
expectMichelsonFailed :: (MichelsonFailed -> Bool) -> Address -> ExecutorError -> IntegrationalScenario
expectMichelsonFailed predicate expectedAddr err =
  case err of
    EEInterpreterFailed actualAddr (RuntimeFailure (mf, _))
      | expectedAddr /= actualAddr -> do
          iState <- get
          unexpectedInterpreterError err $
            "expected runtime failure for contract with address "
            <> pretty (addrToAddrName expectedAddr iState)
      | not (predicate mf) -> unexpectedInterpreterError err "predicate failed"
      | otherwise -> pass
    _ -> unexpectedInterpreterError err "expected runtime failure"

----------------------------------------------------------------------------
-- Implementation of the testing engine
----------------------------------------------------------------------------

initIS :: InternalState
initIS = InternalState
  { _isNow = dummyNow
  , _isMaxSteps = dummyMaxSteps
  , _isGState = initGState
  , _isInterpreterLog = mempty
  , _isExecutorResult = Nothing
  , _isContractsNames = Map.empty
  , _isSender = Nothing
  }

integrationalTest ::
     (Maybe ScenarioError -> res)
  -> IntegrationalScenario
  -> res
integrationalTest howToFail scenario =
  howToFail $ leftToMaybe $ runExcept (runStateT scenario initIS)

mkError
  :: InternalState
  -> ExecutorError
  -> IntegrationalExecutorError
mkError is = fmap $ flip addrToAddrName is