Interpreter.hs

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

module Test.Interpreter
  ( test_basic5
  , test_increment
  , test_fail
  , test_mutez_add_overflow
  , test_mutez_sub_overflow
  , test_basic1
  , test_lsl
  , test_lsr
  , test_FAILWITH
  , test_gas_exhaustion
  , test_add1_list
  , test_Sum_types
  , test_Product_types
  , test_split_bytes
  , test_split_string_simple
  , test_complex_strings
  , test_contract_instr_on_implicit
  , test_map_preserve_stack
  ) where

import Fmt (pretty)
import Hedgehog (MonadTest, annotate, assert, forAll, property, (===))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Hspec.Expectations (Expectation, shouldSatisfy)
import Test.HUnit (assertFailure)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)
import Test.Tasty.HUnit (testCase)

import Michelson.Interpret (MichelsonFailed(..), interpret)
import Michelson.Test (concatTestTrees, testTreesWithTypedContract)
import Michelson.Test.Dummy (dummyContractEnv)
import Michelson.Test.Unit
import Michelson.Test.Util (failedTest)
import Michelson.Text
import Michelson.Typed (IsoValue(..), T(..), epcPrimitive)
import qualified Michelson.Typed as T
import Tezos.Address
import Tezos.Crypto

import Test.Util.Contracts

interpretSimple
  :: forall cp st.
     ( IsoValue cp, IsoValue st
     , T.ParameterScope (ToT cp)
     , T.ForbidOr (ToT cp)
     )
  => T.Contract (ToT cp) (ToT st)
  -> cp
  -> st
  -> ContractReturn (ToT st)
interpretSimple contract cp st =
  interpret (T.cCode contract) epcPrimitive (toVal cp) (toVal st) dummyContractEnv

test_basic5 :: IO [TestTree]
test_basic5 =
  testTreesWithTypedContract (contractsDir </> "basic5.tz") $ \contract -> pure
  [ testCase "Basic test" $
      contractProp @() @[Integer] contract (validateStorageIs [13 :: Integer, 100])
        dummyContractEnv () [1]
  ]

test_increment :: IO [TestTree]
test_increment =
  testTreesWithTypedContract (contractsDir </> "increment.tz") $ \contract -> pure
  [ testCase "Basic test" $
      contractProp @() @Integer contract (validateStorageIs @Integer 24)
        dummyContractEnv () 23
  ]

test_fail :: IO [TestTree]
test_fail =
  testTreesWithTypedContract (contractsDir </> "tezos_examples/macros/fail.tz") $ \contract -> pure
  [ testCase "Fail test" $
      interpretSimple contract () ()
        `shouldSatisfy` (isLeft . fst)
  ]

test_mutez_add_overflow :: IO [TestTree]
test_mutez_add_overflow =
  testTreesWithTypedContract (contractsDir </> "mutez_add_overflow.tz") $ \contract -> pure
  [ testCase "Mutez add overflow test" $
      interpretSimple contract () ()
        `shouldSatisfy` (isLeft . fst)
  ]

test_mutez_sub_overflow :: IO [TestTree]
test_mutez_sub_overflow =
  testTreesWithTypedContract (contractsDir </> "mutez_sub_underflow.tz") $ \contract -> pure
  [ testCase "Mutez sub underflow test" $
      interpretSimple contract () ()
        `shouldSatisfy` (isLeft . fst)
  ]

test_basic1 :: IO [TestTree]
test_basic1 =
  testTreesWithTypedContract (contractsDir </> "basic1.tz") $ \contract -> pure
  [ testProperty "Random check" $ property $ do
      input <- forAll $ Gen.list (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000))
      contractProp @_ @[Integer] contract (validateBasic1 input)
        dummyContractEnv () input
  ]

test_lsl :: IO [TestTree]
test_lsl =
  testTreesWithTypedContract (contractsDir </> "lsl.tz") $ \contract -> pure
  [ testCase "LSL shouldn't overflow test" $
      contractProp @Natural @Natural contract (validateStorageIs @Natural 20)
        dummyContractEnv 5 2
  , testCase "LSL should overflow test" $
      interpretSimple contract (5 :: Natural) (257 :: Natural)
        `shouldSatisfy` (isLeft . fst)
  ]

test_lsr :: IO [TestTree]
test_lsr =
  testTreesWithTypedContract (contractsDir </> "lsr.tz") $ \contract -> pure
  [ testCase "LSR shouldn't underflow test" $
      contractProp @Natural @Natural contract (validateStorageIs @Natural 3)
        dummyContractEnv 30 3
  , testCase "LSR should underflow test" $
      interpretSimple contract (1000 :: Natural) (257 :: Natural)
        `shouldSatisfy` (isLeft . fst)
  ]

test_FAILWITH :: IO [TestTree]
test_FAILWITH = concatTestTrees
  [ testTreesWithTypedContract (contractsDir </> "failwith_message.tz") $ \contract ->
    pure
    [ testCase "Failwith message test" $ do
        let msg = [mt|An error occurred.|] :: MText
        contractProp contract (validateMichelsonFailsWith msg) dummyContractEnv
          msg ()
    ]
  , testTreesWithTypedContract (contractsDir </> "failwith_message2.tz") $ \contract ->
    pure
    [ testCase "Conditional failwith message test" $ do
        let msg = [mt|An error occurred.|]
        contractProp contract (validateMichelsonFailsWith msg) dummyContractEnv
          (True, msg) ()

    , testCase "Conditional success test" $ do
        let param = (False, [mt|Err|] :: MText)
        contractProp contract validateSuccess dummyContractEnv param ()
    ]
  ]

test_gas_exhaustion :: IO [TestTree]
test_gas_exhaustion =
  testTreesWithTypedContract (contractsDir </> "gas_exhaustion.tz") $ \contract -> pure
  [ testCase "Contract should fail due to gas exhaustion" $ do
      let dummyStr = [mt|x|]
      case fst $ interpretSimple contract dummyStr dummyStr of
        Right _ -> assertFailure "expecting contract to fail"
        Left MichelsonGasExhaustion -> pass
        Left _ -> assertFailure "expecting another failure reason"
  ]

test_add1_list :: IO [TestTree]
test_add1_list =
  testTreesWithTypedContract (contractsDir </> "tezos_examples/attic/add1_list.tz") $ \contract ->
  let
    doValidate :: MonadTest m =>
     [Integer] -> ContractPropValidator (ToT [Integer]) (m ())
    doValidate param (res, _) =
      case res of
        Left failed -> failedTest $
          "add1_list unexpectedly failed: " <> pretty failed
        Right (fromVal . snd -> finalStorage) ->
          map succ param === finalStorage
  in pure
  [ testProperty "Random check" $ property $ do
      param <- forAll $ Gen.list (Range.linear 0 100) (Gen.integral (Range.linearFrom 0 -1000 1000))
      contractProp contract (doValidate param) dummyContractEnv param param
  ]

test_Sum_types :: IO [TestTree]
test_Sum_types = concatTestTrees
  [ testTreesWithTypedContract (contractsDir </> "union.mtz") $ \contract -> pure
    [ testGroup "union.mtz: union corresponds to Haskell types properly" $
        let caseTest param =
              contractProp contract validateSuccess dummyContractEnv param ()
        in
        [ testCase "Case 1" $ caseTest (Case1 3)
        , testCase "Case 2" $ caseTest (Case2 [mt|a|])
        , testCase "Case 3" $ caseTest (Case3 $ Just [mt|b|])
        , testCase "Case 4" $ caseTest (Case4 $ Left [mt|b|])
        , testCase "Case 5" $ caseTest (Case5 [[mt|q|]])
        ]
    ]
  , testTreesWithTypedContract (contractsDir </> "case.mtz") $ \contract -> pure
    [ testGroup "CASE instruction" $
        let caseTest param expectedStorage =
              contractProp contract (validateStorageIs @MText expectedStorage)
                dummyContractEnv param [mt||]
        in
        [ testCase "Case 1" $ caseTest (Case1 5) [mt|int|]
        , testCase "Case 2" $ caseTest (Case2 [mt|a|]) [mt|string|]
        , testCase "Case 3" $ caseTest (Case3 $ Just [mt|aa|]) [mt|aa|]
        , testCase "Case 4" $ caseTest (Case4 $ Right [mt|b|]) [mt|or string string|]
        , testCase "Case 5" $ caseTest (Case5 $ [[mt|a|], [mt|b|]]) [mt|ab|]
        ]
    ]
  , testTreesWithTypedContract (contractsDir </> "tag.mtz") $ \contract -> pure
    [ testCase "TAG instruction" $
        let expected = mconcat [[mt|unit|], [mt|o|], [mt|ab|], [mt|nat|], [mt|int|]]
        in contractProp contract (validateStorageIs expected) dummyContractEnv () [mt||]
    ]
  ]

test_Product_types :: IO [TestTree]
test_Product_types = concatTestTrees
  [ testTreesWithTypedContract (contractsDir </> "access.mtz") $ \contract -> pure
    [ testCase "ACCESS instruction" $
        contractProp @Tuple1 contract validateSuccess dummyContractEnv
          (1, [mt|a|], Just [mt|a|], Right [mt|a|], [[mt|a|]]) ()
    ]
  , testTreesWithTypedContract (contractsDir </> "set.mtz") $ \contract -> pure
    [ testCase "SET instruction" $
      let expected = (2, [mt|za|], Just [mt|wa|], Right [mt|ya|], [[mt|ab|]]) :: Tuple1
      in contractProp @_ @Tuple1 contract (validateStorageIs expected)
        dummyContractEnv () (1, [mt|a|], Just [mt|a|], Right [mt|a|], [[mt|a|], [mt|b|]])
    ]
  , testTreesWithTypedContract (contractsDir </> "construct.mtz") $ \contract -> pure
    [ testCase "CONSTRUCT instruction" $
      let expected = (1, [mt|a|], Just [mt|b|], Left [mt|q|], []) :: Tuple1
      in contractProp @_ @Tuple1 contract (validateStorageIs expected)
        dummyContractEnv () (0, [mt||], Nothing, Right [mt||], [])
    ]
  ]

test_split_bytes :: IO [TestTree]
test_split_bytes =
  testTreesWithTypedContract (contractsDir </> "tezos_examples/opcodes/split_bytes.tz") $
    \contract -> pure
  [ testCase "splits given byte sequence into parts" $
      let expected = ["\11", "\12", "\13"] :: [ByteString]
      in contractProp contract (validateStorageIs expected) dummyContractEnv
         ("\11\12\13" :: ByteString) ([] :: [ByteString])
  ]

test_split_string_simple :: IO [TestTree]
test_split_string_simple =
  testTreesWithTypedContract (contractsDir </> "split_string_simple.tz") $ \contract ->
  pure
  [ testCase "applies SLICE instruction" $ do
      let
        oneTest :: Natural -> Natural -> MText -> Maybe MText -> Expectation
        oneTest o l str expected =
          contractProp contract (validateStorageIs expected) dummyContractEnv
          (o, l) (Just str)

      -- These values have been tested using alphanet.sh
      oneTest 0 0 [mt|aaa|] (Just [mt||])
      oneTest 2 0 [mt|aaa|] (Just [mt||])
      oneTest 3 0 [mt|aaa|] Nothing
      oneTest 0 5 [mt|aaa|] Nothing
      oneTest 1 2 [mt|abc|] (Just [mt|bc|])
      oneTest 1 1 [mt|abc|] (Just [mt|b|])
      oneTest 2 1 [mt|abc|] (Just [mt|c|])
      oneTest 2 2 [mt|abc|] Nothing
      oneTest 1 1 [mt|a""|] (Just [mt|"|])
      oneTest 1 2 [mt|a\n|] Nothing
  ]

test_complex_strings :: IO [TestTree]
test_complex_strings =
  testTreesWithTypedContract (contractsDir </> "complex_strings.tz") $ \contract ->
  pure
  [ testCase "ComplexString" $
      contractProp contract
      (validateStorageIs [mt|text: "aa" \\\n|])
      dummyContractEnv [mt|text: |] [mt||]
  ]

data Union1
  = Case1 Integer
  | Case2 MText
  | Case3 (Maybe MText)
  | Case4 (Either MText MText)
  | Case5 [MText]
  deriving stock (Generic)
  deriving anyclass (IsoValue)

type Tuple1 = (Integer, MText, Maybe MText, Either MText MText, [MText])

test_contract_instr_on_implicit :: IO [TestTree]
test_contract_instr_on_implicit =
  testTreesWithTypedContract (contractsDir </> "contract_instr_unit.tz") $ \contractGood ->
  testTreesWithTypedContract (contractsDir </> "contract_instr_nonunit.tz") $ \contractBad ->
  pure
  [ testCase "CONTRACT instruction succeeds on implicit accounts" $
      contractProp contractGood validateSuccess dummyContractEnv addr ()

  , testCase "CONTRACT instruction considers implicit accounts as unit-parametrized" $
      contractProp contractBad (validateMichelsonFailsWith [mt|No such contract|])
        dummyContractEnv addr ()
  ]
  where
    addr = mkKeyAddress . toPublic $ detSecretKey "sfsdfsdf"

-- | This test creates a map of two items and then converts them into a list
-- with @MAP@ primitive, counting the number of items along the way.
--
-- See https://gitlab.com/morley-framework/morley/-/issues/123
test_map_preserve_stack :: IO [TestTree]
test_map_preserve_stack =
  testTreesWithTypedContract (contractsDir </> "map_preserve_stack.tz") $ \contract ->
  pure
  [ testCase "MAP preserves deep stack modifications (#123)" $
      contractProp @() @([Integer], Integer) contract
        (validateStorageIs @([Integer], Integer) ([257, 43], 2))
        dummyContractEnv () ([], 0)
  ]

----------------------------------------------------------------------------

validateBasic1
  :: MonadTest m
  => [Integer] -> ContractPropValidator ('TList 'TInt) (m ())
validateBasic1 input (Right (ops, res), _) = do
    fromVal res === [sum input + 12, 100]

    annotate "returned no ops"
    assert $ null ops
validateBasic1 _ (Left e, _) = failedTest $ show e