EnvironmentSpec.hs

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

-- | Tests for the 'environment.tz' contract

module Test.Interpreter.EnvironmentSpec
  ( test_environment
  ) where

import Hedgehog (Gen, forAll, property, withTests)
import qualified Hedgehog.Gen as Gen
import Test.Tasty (TestTree)
import Test.Tasty.Hedgehog (testProperty)

import Morley.Michelson.Runtime.GState
import Morley.Michelson.Typed
import qualified Morley.Michelson.Typed as T
import qualified Morley.Michelson.Untyped as U
import Morley.Tezos.Core
import Test.Cleveland
import Test.Cleveland.Michelson.Import (embedContract)

import Test.Util.Contracts

test_environment :: [TestTree]
test_environment =
  [ testImpl contract
  , testScenario "Default balance" $ scenario do
      addr <- newFreshAddress "random address testDefaultBalance"
      transferMoney addr 1
      getBalance addr @@== 1
  ]
  where
    contract = $$(embedContract @'TAddress @'TUnit (inContractsDir "environment.tz"))

data Fixture = Fixture
  { fPassOriginatedAddress :: Bool
  , fBalance :: Mutez
  , fAmount :: Mutez
  } deriving stock (Show)

genFixture :: Gen Fixture
genFixture = do
  fPassOriginatedAddress <- Gen.bool
  fBalance <- toMutez <$> Gen.enum 1 1234
  fAmount <- toMutez <$> Gen.enum 1 42
  return Fixture {..}

testImpl
  :: T.Contract 'TAddress 'TUnit
  -> TestTree
testImpl environment  = do
  -- The conditions under which this contract fails are described in a comment
  -- at the beginning of the contract.
  testProperty "contract fails under certain conditions" $
    withTests 50 $ property $ do
      fixture <- forAll genFixture
      testScenarioProps $ scenario do
        -- Let's originate the 'environment.tz' contract
        let
          uoData = UntypedOriginateData
            { uodName = "environment"
            , uodBalance = fBalance fixture
            , uodStorage = U.ValueUnit
            , uodContract = (T.convertContract environment)
            }

        environmentAddress <- originateUntyped uoData

        -- And transfer tokens to it
        let
          param
            | fPassOriginatedAddress fixture = environmentAddress
            | otherwise = genesisAddress
          transferData = TransferData
            { tdTo = environmentAddress
            , tdAmount = fAmount fixture
            , tdEntrypoint = DefEpName
            , tdParameter = param
            }

        -- Execute operations and check that interpreter fails when one of
        -- failure conditions is met or updates environment's storage
        -- approriately
        let
          balanceAfterTransfer = fBalance fixture `unsafeAddMutez` fAmount fixture
        if
          | balanceAfterTransfer > toMutez 1000 ->
              expectFailedWith balanceAfterTransfer $
                transfer transferData
          | fPassOriginatedAddress fixture ->
              expectFailedWith environmentAddress $
                transfer transferData
          | fAmount fixture < toMutez 15 ->
              expectFailedWith (fAmount fixture) $
                transfer transferData
          | otherwise -> transfer transferData