RunCode.hs

-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- Disable the warning generated by the `L.source` instruction.
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}

module TestSuite.Cleveland.RunCode
  ( test_runs_code
  , test_emulator_state_is_not_modified
  , test_other_operations_are_not_executed
  , test_handles_bigmap
  , test_handles_bigmap_ids
  , test_env_vars_can_be_observed
  , test_can_observe_existing_onchain_contracts_and_accounts
  , test_self_address_does_not_exist_onchain
  ) where

import Control.Lens (at)
import Debug qualified (show)
import Test.Tasty (TestTree)

import Lorentz (HasAnnotation)
import Lorentz qualified as L
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)

test_runs_code :: TestTree
test_runs_code =
  testScenario "runs the given contract's code" $ scenario do
    runCode RunCode
      { rcContract = increment
      , rcStorage = NotRPC 5
      , rcParameter = NotRPC 3
      , rcAmount = 0
      , rcBalance = 0
      , rcSource = Nothing
      , rcNow = Nothing
      , rcLevel = Nothing
      } @@== 8
  where
    increment :: Contract Integer Integer ()
    increment = L.defaultContract $
      L.unpair
      # L.add
      # L.nil # L.pair

test_emulator_state_is_not_modified :: TestTree
test_emulator_state_is_not_modified =
  testScenarioOnEmulator "the emulator's state is not modified" $ scenario do
    before <- get
    runCode RunCode
      { rcContract = transferToSender
      , rcStorage = NotRPC ()
      , rcParameter = NotRPC ()
      , rcAmount = 900
      , rcBalance = 900
      , rcSource = Nothing
      , rcNow = Just (Timestamp 1337)
      , rcLevel = Just 42
      }
    after <- get
    checkComparesWith Debug.show before (==) Debug.show after
  where
    transferToSender :: Contract () () ()
    transferToSender = L.defaultContract $
      L.drop
      # L.sender
      # L.contract @()
      # L.assertSome @MText "Address's parameter is not of type unit."
      # L.push @Mutez 10
      # L.push ()
      # L.transferTokens
      # L.dip (L.nil) # L.cons
      # L.dip (L.push ()) # L.pair

test_other_operations_are_not_executed :: TestTree
test_other_operations_are_not_executed =
  testScenario "other operations are not executed" $ scenario do
    -- If we originated the contract and called it, it would loop
    -- until it ran out of gas.

    -- But because `runCode` is not supposed to execute operations emitted by the first call,
    -- then the counter should only be increased to 1 and then stop.
    runCode RunCode
      { rcContract = unboundRecursion
      , rcStorage = NotRPC 0
      , rcParameter = NotRPC ()
      , 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.
    unboundRecursion :: Contract () Integer ()
    unboundRecursion = L.defaultContract $
      L.cdr
      # L.push @Integer 1 # L.add
      # L.self @()
      # L.push @Mutez 0
      # L.push ()
      # L.transferTokens
      # L.dip L.nil # L.cons
      # L.pair

test_handles_bigmap :: TestTree
test_handles_bigmap =
  testScenario "handles bigmaps in parameter/storage" $ scenario do
    (total, bigMapId) <- runCode RunCode
      { rcContract = lookupBigMapKey
      , rcStorage = NotRPC ((0, 0), one ("key", 50))
      , rcParameter = NotRPC ("key", one ("key", 20))
      , rcAmount = 0
      , rcBalance = 0
      , rcSource = Nothing
      , rcNow = Nothing
      , rcLevel = Nothing
      }

    total @== (50, 20)
    -- Check that the bigmap was not actually created on-chain.
    getBigMapValueMaybe bigMapId "key" @@== Nothing

test_handles_bigmap_ids :: TestTree
test_handles_bigmap_ids =
  testScenario "handles bigmap IDs in parameter/storage" $ scenario do
    -- Originate a contract with a big_map in its storage
    -- in order to actually create a valid on-chain bigmap ID.
    handle <- originateSimple @() @(BigMap MText Integer) @() "bigmap" (one ("key", 30)) idContract
    bigMapId <- getStorage handle

    (total, _) <- runCode RunCode
      { rcContract = lookupBigMapKey
      , rcStorage = IsRPC ((0, 0), bigMapId)
      , rcParameter = IsRPC ("key", bigMapId)
      , rcAmount = 0
      , rcBalance = 0
      , rcSource = Nothing
      , rcNow = Nothing
      , rcLevel = Nothing
      }

    total @== (30, 30)

test_env_vars_can_be_observed :: TestTree
test_env_vars_can_be_observed =
  testScenario "environment variables can be observed" $ scenario do
    sender <- newFreshAddress auto
    source <- newFreshAddress auto

    envVars <- withSender sender $ runCode RunCode
      { rcContract = readEnvVars
      , rcStorage = NotRPC Nothing
      , rcParameter = NotRPC ()
      , rcAmount = 456
      , rcBalance = 123
      , rcSource = Just source
      , rcNow = Just (Timestamp 8)
      , rcLevel = Just 29
      } >>= evalJust "Expected contract to return a `Some`"

    envLevel envVars @== 29
    envNow envVars @== Timestamp 8
    getChainId @@== envChainId envVars
    envSender envVars @== sender
    envSource envVars @== source
    envAmount envVars @== 456
    envBalance envVars @== 123
  where
    readEnvVars :: Contract () (Maybe EnvVars) ()
    readEnvVars = L.defaultContract $
      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
            , L.fieldCtor $ L.amount
            , L.fieldCtor $ L.balance
            )
      # L.some # L.nil # L.pair

data EnvVars = EnvVars
  { envLevel :: Natural
  , envNow :: Timestamp
  , envChainId :: ChainId
  , envSender :: Address
  , envSource :: Address
  , envAmount :: Mutez
  , envBalance :: Mutez
  }
  deriving stock (Generic)
  deriving anyclass (IsoValue, HasAnnotation)

instance HasRPCRepr EnvVars where type AsRPC EnvVars = EnvVars

test_can_observe_existing_onchain_contracts_and_accounts :: TestTree
test_can_observe_existing_onchain_contracts_and_accounts =
  testScenario "existing onchain contracts/acounts can be observed" $ scenario do
    contractAddress <- toAddress <$> originate OriginateData
      { odName = "contract"
      , odBalance = 123
      , odStorage = ()
      , odContract = idContract @Integer @()
      }

    let
      checkContractExists :: Contract () (Maybe Address) ()
      checkContractExists = L.defaultContract $
        L.drop
        -- Assert that the given address exists and belongs to a contract.
        # L.push contractAddress
        # L.contract @Integer
        # L.assertSome @MText "Expected to find a contract with parameter `Integer`."
        # L.address
        # L.some # L.nil # L.pair

    runCode RunCode
      { rcContract = checkContractExists
      , rcStorage = IsRPC Nothing
      , rcParameter = IsRPC ()
      , rcAmount = 0
      , rcBalance = 0
      , rcSource = Nothing
      , rcNow = Nothing
      , rcLevel = Nothing
      } @@== Just contractAddress

test_self_address_does_not_exist_onchain :: TestTree
test_self_address_does_not_exist_onchain =
  testScenarioOnEmulator "SELF address does not exist onchain" $ scenario do
    emulatorState <- use psGState

    let
      returnSelf :: Contract Integer (Maybe Address) ()
      returnSelf = L.defaultContract $
        L.drop
        -- Check `SELF` instruction succeeds
        # L.self @Integer
        # L.drop
        # L.selfAddress # L.contract @Integer
        # L.assertSome @MText "Expected to find a contract with parameter `Integer`."
        # L.address # L.some # L.nil # L.pair

    selfAddr <- runCode RunCode
      { rcContract = returnSelf
      , rcStorage = IsRPC Nothing
      , rcParameter = IsRPC 0
      , rcAmount = 0
      , rcBalance = 0
      , rcSource = Nothing
      , rcNow = Nothing
      , rcLevel = Nothing
      } >>= evalJust "Expected contract to return a `Some`"

    emulatorState ^. gsAddressesL . at selfAddr @== Nothing

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | Looks up an integer in:
--
-- * The big_map given in the parameter
-- * The big_map in the storage
--
-- ... and stores both results in the storage.
lookupBigMapKey :: Contract (MText, BigMap MText Integer) ((Integer, Integer), BigMap MText Integer) ()
lookupBigMapKey = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $
  L.unpair
  # L.dip L.cdr
  # L.unpair
  # L.stackType @'[MText, BigMap MText Integer, BigMap MText Integer]

  # L.dup
  # L.dip L.swap
  # L.stackType @'[MText, BigMap MText Integer, MText, BigMap MText Integer]

  -- Make a copy of the bigmap in the storage
  # L.dupN @4
  # L.dug @4
  # L.stackType @'[MText, BigMap MText Integer, MText, BigMap MText Integer, BigMap MText Integer]

  -- Retrieve keys
  # L.get
  # L.assertSome @MText "Expected Some, found None."
  # L.dug @2
  # L.get
  # L.assertSome @MText "Expected Some, found None."

  # L.pair
  # L.pair
  # L.nil @Operation # L.pair