morley-0.4.0: test/Test/Michelson/Runtime.hs

-- | Tests for Michelson.Runtime.

module Test.Michelson.Runtime
  ( test_interpreterPure
  ) where

import Control.Lens (at)
import Fmt (pretty)
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, expectAnySuccess, integrationalTestExpectation, originate, transfer,
  validate)
import Michelson.Text (mt)
import Michelson.Typed (untypeValue)
import Michelson.Untyped
import Tezos.Address
import Tezos.Core (unsafeMkMutez)

test_interpreterPure :: IO [TestTree]
test_interpreterPure = do
  illTypedContract <-
    prepareContract (Just "contracts/ill-typed/sum_strings.tz")
  pure
    [ testGroup "Updates storage value of executed contract" $
      [ testCase "contract1" $ updatesStorageValue contractAux1
      , testCase "contract2" $ updatesStorageValue contractAux2
      ]
    , testCase "Fails to originate an already originated contract" failsToOriginateTwice
    , 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
    addr = mkContractAddress origination
    txData = TxData
      { tdSenderAddress = ceSender ce
      , tdParameter = caParameter ca
      , tdAmount = unsafeMkMutez 100
      }
    interpreterOps =
      [ OriginateOp origination
      , TransferOp addr txData
      ]
  (addr,) <$> interpreterPure dummyNow dummyMaxSteps initGState interpreterOps
  where
    toNewStorage :: InterpretResult -> Value
    toNewStorage InterpretResult {..} = untypeValue iurNewStorage

    handleResult :: (Address, InterpreterRes) -> Assertion
    handleResult (addr, ir) = do
      expectedValue <-
        either (assertFailure . pretty) (pure . toNewStorage) $
        interpretUntyped
                  (caContract ca) (caParameter ca) (caStorage ca) (caEnv ca)
      case gsAddresses (_irGState 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

failsToOriginateTwice :: Expectation
failsToOriginateTwice =
  simpleTest ops isAlreadyOriginated
  where
    contract = caContract contractAux1
    origination = dummyOrigination (caStorage contractAux1) contract
    ops = [OriginateOp origination, OriginateOp origination]
    isAlreadyOriginated (Left (IEAlreadyOriginated {})) = True
    isAlreadyOriginated _ = False

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

simpleTest ::
     [InterpreterOp]
  -> (Either InterpreterError InterpreterRes -> Bool)
  -> Expectation
simpleTest ops predicate =
  interpreterPure dummyNow dummyMaxSteps initGState ops `shouldSatisfy`
  predicate

testZeroTransactionFails :: IntegrationalScenario
testZeroTransactionFails = do
  let
    txData = TxData
        { tdSenderAddress = genesisAddress
        , tdParameter = ValueNil
        , tdAmount = unsafeMkMutez 0 }
    validator =
      \case IEZeroTransaction addr -> addr == genesisAddress
            _ -> False
  transfer txData genesisAddress
  validate $ Left validator

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

transferFromUnknown :: Assertion
transferFromUnknown =
  whenLeft (interpreterPure dummyNow dummyMaxSteps initGState interpreterOps) $
  assertFailure . pretty
  where
    ca = contractAux1
    interpreterOps =
      [ OriginateOp origination
      , TransferOp (mkContractAddress origination) txData
      ]
    origination = contractAuxToOrigination ca
    txData =
      TxData
        { tdSenderAddress = detGenKeyAddress "transferFromUnknown"
        , tdParameter = caParameter ca
        , 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
      { para = Type tstring noAnn
      , stor = Type tbool noAnn
      , code =
        [ 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)
    { code =
      [ 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}