Runtime.hs

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

-- | Tests for Michelson.Runtime.

module Test.Michelson.Runtime
  ( test_executorPure
  ) where

import Control.Lens (at)
import Fmt (pretty, (+|), (|+))
import System.FilePath ((</>))
import Test.Hspec.Expectations (Expectation, expectationFailure, shouldSatisfy)
import Test.HUnit (Assertion, assertFailure, (@?), (@?=))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Michelson.ErrorPos (InstrCallStack(..), Pos(..), SrcPos(..))
import Michelson.Interpret (ContractEnv(..), InterpretResult(..), interpretUntyped)
import Michelson.Runtime hiding (transfer)
import Michelson.Runtime.GState (GState(..), genesisAddress, initGState)
import Michelson.Test.Dummy (dummyContractEnv, dummyMaxSteps, dummyNow, dummyOrigination)
import Michelson.Test.Integrational
  (IntegrationalScenario, TestError(CustomTestError), catchExpectedError, integrationalFail,
  integrationalTestExpectation, originate, transfer, unexpectedInterpreterError)
import Michelson.Text (mt)
import Michelson.Typed (untypeValue)
import Michelson.Untyped
import Tezos.Address
import Tezos.Core (unsafeMkMutez)

import Test.Util.Contracts (contractsDir)

test_executorPure :: IO [TestTree]
test_executorPure = do
  illTypedContract <-
    prepareContract (Just (contractsDir </> "ill-typed/sum_strings.tz"))
  pure
    [ testGroup "Updates storage value of executed contract" $
      [ testCase "contract1" $ updatesStorageValue contractAux1
      , testCase "contract2" $ updatesStorageValue contractAux2
      ]
    , testCase "Succeeds to originate the same contract twice, with different addresses"
        succeedsToOriginateTwice
    , testCase "Fails to originate an ill-typed contract"
        (failsToOriginateIllTyped (ValueString [mt||]) illTypedContract)
    , testCase "Fails transfering 0tz to plain account"
        $ integrationalTestExpectation testZeroTransactionFails
    , testCase "Success transfering 0tz to a contract"
        $ integrationalTestExpectation testZeroTransactionSuccess
    , testCase "Transfer of 0tz from unknown address is allowed" transferFromUnknown
    ]

----------------------------------------------------------------------------
-- Test code
----------------------------------------------------------------------------

-- | Data type, that containts contract and its auxiliary data.
--
-- This type is mostly used for testing purposes.
data ContractAux = ContractAux
  { caContract :: Contract
  , caEnv :: ContractEnv
  , caStorage :: Value
  , caParameter :: Value
  }

updatesStorageValue :: ContractAux -> Assertion
updatesStorageValue ca = either (assertFailure . pretty) handleResult $ do
  let
    ce = caEnv ca
    origination = contractAuxToOrigination ca
    txData = TxData
      { tdSenderAddress = ceSender ce
      , tdParameter = caParameter ca
      , tdEntrypoint = DefEpName
      , tdAmount = unsafeMkMutez 100
      }

  runExecutorM dummyNow dummyMaxSteps initGState $ do
    addr <- withGlobalOperation (OriginateOp origination)
      $ executeOrigination origination
    executeGlobalOperations [TransferOp addr txData]
    return addr
  where
    toNewStorage :: InterpretResult -> Value
    toNewStorage InterpretResult {..} = untypeValue iurNewStorage

    handleResult :: (ExecutorRes, Address) -> Assertion
    handleResult (ir, addr) = do
      expectedValue <-
        either (assertFailure . pretty) (pure . toNewStorage) $
        interpretUntyped
                  (caContract ca) (caParameter ca) (caStorage ca) (caEnv ca)
      case gsAddresses (_erGState ir) ^. at addr of
        Nothing -> expectationFailure $ "Address not found: " <> pretty addr
        Just (ASContract cs) -> csStorage cs @?= expectedValue
        Just _ -> expectationFailure $ "Address has unexpected state " <> pretty addr

succeedsToOriginateTwice :: Expectation
succeedsToOriginateTwice = either (assertFailure . pretty) handleResult $ do
  runExecutorM dummyNow dummyMaxSteps initGState $ do
    addr1 <- withGlobalOperation (OriginateOp origination)
      $ executeOrigination origination
    addr2 <- withGlobalOperation (OriginateOp origination)
      $ executeOrigination origination
    return (addr1, addr2)
  where
    contract = caContract contractAux1
    origination = dummyOrigination (caStorage contractAux1) contract

    handleResult :: (ExecutorRes, (Address, Address)) -> Assertion
    handleResult (_, (addr1, addr2)) =
      addr1 /= addr2 @? "Two originated addresses are not different"

failsToOriginateIllTyped :: Value -> Contract -> Expectation
failsToOriginateIllTyped initialStorage illTypedContract =
  simpleTest ops isIllTypedContract
  where
    origination = dummyOrigination initialStorage illTypedContract
    ops = [OriginateOp origination]
    isIllTypedContract (Left (EEIllTypedContract {})) = True
    isIllTypedContract _ = False

simpleTest
  :: HasCallStack
  => [ExecutorOp]
  -> (Either ExecutorError ExecutorRes -> Bool)
  -> Expectation
simpleTest ops predicate =
  fst <$> runExecutorM dummyNow dummyMaxSteps initGState (executeGlobalOperations ops)
  `shouldSatisfy` predicate

testZeroTransactionFails :: IntegrationalScenario
testZeroTransactionFails = do
  let
    txData = TxData
        { tdSenderAddress = genesisAddress
        , tdParameter = ValueNil
        , tdEntrypoint = DefEpName
        , tdAmount = unsafeMkMutez 0 }

  transfer txData genesisAddress `catchExpectedError`
    \case
      EEZeroTransaction addr
        | addr == genesisAddress -> pass
        | otherwise -> integrationalFail $ CustomTestError $
            "Expected " +| genesisAddress |+ ", but got " +| addr |+ ""
      err -> unexpectedInterpreterError err "expected attempt to send 0tz"

testZeroTransactionSuccess :: IntegrationalScenario
testZeroTransactionSuccess = do
  let
    contract = caContract contractAux1
    storage = caStorage contractAux1
    balance = ceBalance . caEnv $ contractAux1
    txData = TxData
        { tdSenderAddress = genesisAddress
        , tdParameter = caParameter contractAux1
        , tdEntrypoint = DefEpName
        , tdAmount = unsafeMkMutez 0 }
  address <- originate contract "test0tzContract" storage balance
  transfer txData address

transferFromUnknown :: Assertion
transferFromUnknown = do
  let
    res = runExecutorM dummyNow dummyMaxSteps initGState $ do
      addr <- withGlobalOperation (OriginateOp origination)
        $ executeOrigination origination
      executeGlobalOperations [TransferOp addr txData]

  whenLeft res $
    assertFailure . pretty
  where
    ca = contractAux1
    origination = contractAuxToOrigination ca
    txData =
      TxData
        { tdSenderAddress = detGenKeyAddress "transferFromUnknown"
        , tdParameter = caParameter ca
        , tdEntrypoint = DefEpName
        , tdAmount = unsafeMkMutez 0
        }

----------------------------------------------------------------------------
-- Data
----------------------------------------------------------------------------

ics :: Word -> InstrCallStack
ics x = InstrCallStack [] (SrcPos (Pos x) (Pos 0))

contractAux1 :: ContractAux
contractAux1 = ContractAux
  { caContract = contract
  , caEnv = dummyContractEnv
  , caStorage = ValueTrue
  , caParameter = ValueString [mt|aaa|]
  }
  where
    contract :: Contract
    contract = Contract
      { contractParameter = ParameterType (Type TString noAnn) noAnn
      , contractStorage = Type TBool noAnn
      , contractCode =
        [ WithSrcEx (ics 0) $ PrimEx (CDR noAnn noAnn)
        , WithSrcEx (ics 1) $ PrimEx (NIL noAnn noAnn $ Type TOperation noAnn)
        , WithSrcEx (ics 2) $ PrimEx (PAIR noAnn noAnn noAnn noAnn)
        ]
      }

contractAux2 :: ContractAux
contractAux2 = contractAux1
  { caContract = (caContract contractAux1)
    { contractCode =
      [ WithSrcEx (ics 0) $ PrimEx (CDR noAnn noAnn)
      , WithSrcEx (ics 1) $ PrimEx (NOT noAnn)
      , WithSrcEx (ics 2) $ PrimEx (NIL noAnn noAnn $ Type TOperation noAnn)
      , WithSrcEx (ics 3) $ PrimEx (PAIR noAnn noAnn noAnn noAnn)
      ]
    }
  }

contractAuxToOrigination :: ContractAux -> OriginationOperation
contractAuxToOrigination ca =
  let contract = caContract ca
      ce = caEnv ca
   in (dummyOrigination (caStorage ca) contract) {ooBalance = ceBalance ce}