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 #-}

{-# LANGUAGE OverloadedLists #-}

module TestSuite.Cleveland.RunCode
  ( test_runs_code
  , test_emulator_state_is_not_modified
  , test_other_operations_are_not_executed
  , test_handles_mix_of_bigmaps_and_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 (gsContractAddressesL)
import Morley.Michelson.Typed (untypeValue)
import Morley.Michelson.Untyped (Elt(..), Value'(..))
import Morley.Tezos.Address
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 = untypeValue $ toVal @Integer 5
      , rcParameter = untypeValue $ toVal @Integer 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 = untypeValue $ toVal ()
      , rcParameter = untypeValue $ toVal ()
      , 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 = untypeValue $ toVal @Integer 0
      , rcParameter = untypeValue $ toVal ()
      , 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_mix_of_bigmaps_and_bigmap_ids :: TestTree
test_handles_mix_of_bigmaps_and_bigmap_ids =
  testScenario "handles a mix of bigmaps and 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 <- originate "bigmap" (one ("key", 20)) $ idContract @() @(BigMap MText Integer)
    bigMapId <- getStorage handle

    (_, results) <- runCode RunCode
      { rcContract = lookupBigMapKey
      , rcParameter =
          -- a list with a big_map ID and a big_map value
          ValueSeq
            [ untypeValue $ toVal bigMapId
            , ValueMap [Elt (ValueString "key") (ValueInt 30)]
            ]
      , rcStorage =
          ValuePair
            (ValueSeq
              [ untypeValue $ toVal bigMapId
              , ValueMap [Elt (ValueString "key") (ValueInt 40)]
              ]
            )
            (ValueNil)
      , rcAmount = 0
      , rcBalance = 0
      , rcSource = Nothing
      , rcNow = Nothing
      , rcLevel = Nothing
      }

    results @== [40, 20, 30, 20]

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 = untypeValue $ toVal $ Nothing @EnvVars
      , rcParameter = untypeValue $ toVal ()
      , 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 @== toAddress sender
    envSource envVars @== toAddress 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 "contract" () (idContract @Integer @()) [tz|123u|]
    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 = untypeValue $ toVal $ Nothing @Address
      , rcParameter = untypeValue $ toVal ()
      , 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

    MkAddress selfAddr@ContractAddress{} <- runCode RunCode
      { rcContract = returnSelf
      , rcStorage = untypeValue $ toVal $ Nothing @Address
      , rcParameter = untypeValue $ toVal @Integer 0
      , rcAmount = 0
      , rcBalance = 0
      , rcSource = Nothing
      , rcNow = Nothing
      , rcLevel = Nothing
      } >>= evalJust "Expected contract to return a `Some`"

    emulatorState ^. gsContractAddressesL . at selfAddr @== Nothing

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

-- | This contracts has a list of big_maps in its storage, and takes an additional
-- list of big_maps in its parameter.
--
-- When called, it looks up the key "key" in all big_maps, and stores
-- all results in a @[Integer]@ in the storage.
lookupBigMapKey
  :: Contract [BigMap MText Integer]
              ([BigMap MText Integer], [Integer])
              ()
lookupBigMapKey = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $
  -- Unpair everything
  L.unpair
  # L.dip L.unpair
  # L.stackType @'[[BigMap MText Integer], [BigMap MText Integer], [Integer]]

  -- Discard the `[Integer]` in the storage
  # L.dipN @2 L.drop
  # L.stackType @'[[BigMap MText Integer], [BigMap MText Integer]]

  -- Get the value at key "key" from all big_maps
  # L.nil @Integer
  # L.swap
  # getValues
  # L.stackType @'[[Integer], [BigMap MText Integer]]
  # L.swap
  # getValues
  # L.stackType @'[[Integer]]

  # L.nil
  # L.pair
  # L.nil @Operation # L.pair
  where
    -- Get the value at key "key" from all big_maps
    getValues :: [BigMap MText Integer] ': [Integer] ': s :-> [Integer] ': s
    getValues =
      L.iter
        (
          L.push @MText "key"
          # L.get
          # L.assertSome @MText "Expected Some, found None."
          # L.cons
        )