ExpectFailure.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

module TestSuite.Cleveland.ExpectFailure
  ( test_CatchExceptions
  , test_FailsIfTheGivenActionDoesNotThrow
  , test_BranchErrorHandleInRightWay
  , hprop_BooleanOperators_Flatten_TransferFailurePredicates
  , test_TransferFailure_predicates
  ) where

import Lorentz as L hiding (comment)

import Fmt (Builder, jsonListF', pretty, unlinesF)
import Hedgehog (Gen, Property, PropertyT, forAllWith, property)
import Hedgehog.Gen qualified as Gen
import Test.Tasty (TestTree, testGroup)

import Morley.Micheline (toExpression)
import Morley.Michelson.Runtime.GState (genesisAddress1)
import Morley.Tezos.Address (ta)
import Morley.Tezos.Core (parseChainId)
import Morley.Util.Interpolate (it)
import Test.Cleveland
import Test.Cleveland.Internal.Abstract
  (AddressAndAlias(..), ExpressionOrTypedValue(..), GenericTestError(..), TransferFailure(..),
  TransferFailureReason(..))
import Test.Cleveland.Internal.Actions (TransferFailurePredicate(..))
import Test.Cleveland.Internal.Exceptions
import Test.Cleveland.Util (failedTest, fromHex)
import TestSuite.Util (shouldFailWithMessage)

test_CatchExceptions :: TestTree
test_CatchExceptions =
  testScenario "catches exceptions" $ scenario do
    validAddr <- newAddress auto
    contractAddr <- originate
      "test catchTransferFailure"
      ()
      (defaultContract testContractCode)
      [tz|1u|]

    let (testContractWithNumericErrors, errorTagMap) = useNumericErrors testContractCode
    contractNumericAddr <- originate
      "test catchTransferFailure numeric errors"
      ()
      (defaultContract testContractWithNumericErrors)
      [tz|1u|]

    attempt (transfer contractAddr $ calling (ep @"TriggerFailWith") ()) >>= \case
      Left err -> checkTransferFailure err $ failedWith (constant [mt|oops|])
      Right _ -> failure "Expected contract to fail"

    catchTransferFailure $
      transfer contractAddr $ calling (ep @"TriggerFailWith") ()

    expectTransferFailure (failedWith (constant [mt|oops|])) $
      transfer contractAddr $ calling (ep @"TriggerFailWith") ()

    expectTransferFailure (failedWith (constant [mt|oops|]) && addressIs contractAddr) $
      transfer contractAddr $ calling (ep @"TriggerFailWith") ()

    expectFailedWith [mt|oops|] $
      transfer contractAddr $ calling (ep @"TriggerFailWith") ()

    expectError (VoidResult False) $
      transfer contractAddr $ calling (ep @"VoidEP") (mkVoid True)

    expectTransferFailure (failedWith $ constant (1 :: Natural, (2 :: Natural, 3 :: Natural)))  $
      transfer contractAddr $ calling (ep @"TriggerFailWithRightCombedPair") ()

    -- Check that string and bytes forms of 'chain_id' are equal if they are
    -- used as error argument.
    let c = fromRight (error "impossible") $ parseChainId "NetXUdfLh6Gm88t"
    expectTransferFailure
      (failedWith (constant @ChainId c)) $
        transfer contractAddr $ calling (ep @"TriggerFailWithChainIdStr") ()

    expectTransferFailure
      (failedWith (constant @ChainId c)) $
        transfer contractAddr $ calling (ep @"TriggerFailWithChainIdBytes") ()

    expectCustomError #customError 1 $
      transfer contractAddr $ calling (ep @"TriggerFailWithCustomError") ()

    expectCustomError_ #customErrorUnit1 $
      transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit1") ()

    expectCustomError_ #customErrorUnit2 $
      transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit2") ()

    expectCustomErrorNoArg #customErrorNoArg $
      transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") ()

    expectCustomErrorAnyArg #customError $
      transfer contractAddr $ calling (ep @"TriggerFailWithCustomError") ()

    expectCustomErrorAnyArg #customErrorUnit1 $
      transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit1") ()

    expectCustomErrorAnyArg #customErrorNoArg $
      transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") ()

    shouldFailWithMessage "Contract failed with any custom error tagged with \"WrongErrorTag\"" $
      expectCustomErrorAnyArg #wrongErrorTag $
        transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") ()

    shouldFailWithMessage "Contract failed with any custom error tagged with \"CustomError\"" $
      expectCustomErrorAnyArg #customError $
        transfer contractAddr $ calling (ep @"TriggerShiftOverflow") ()

    shouldFailWithMessage "Expected an exception to be thrown, but it wasn't" $
      expectCustomErrorAnyArg #customErrorNoArg pass

    expectNumericError errorTagMap (VoidResult False) $
      transfer contractNumericAddr $ calling (ep @"VoidEP") $ mkVoid True

    expectTransferFailure shiftOverflow $
      transfer contractAddr $ calling (ep @"TriggerShiftOverflow") ()

    expectTransferFailure gasExhaustion $
      transfer contractAddr $ calling (ep @"TriggerGasExhaustion") ()

    expectTransferFailure emptyTransaction $
      transfer validAddr [tz|0u|]

    expectTransferFailure badParameter $
      transfer contractAddr $ unsafeCalling #expectAddress [mt|aa|]

    expectTransferFailure badParameter $
      transfer contractAddr $ unsafeCalling #expectAddress @Natural 1

    -- check that an action throws one of many errors.
    let expectedErrs =
          failedWith (constant @Integer 1) ||
          failedWith (constant @MText "oops") ||
          failedWith (customError #customError 1)

    transfer contractAddr (calling (ep @"TriggerFailWithCustomError") ()) &
      expectTransferFailure expectedErrs

test_FailsIfTheGivenActionDoesNotThrow :: TestTree
test_FailsIfTheGivenActionDoesNotThrow =
  testScenario "catchTransferFailure fails when the given action does not throw" $ scenario $
    catchTransferFailure pass
      & shouldFailWithMessage (pretty UnexpectedSuccess)

test_BranchErrorHandleInRightWay :: TestTree
test_BranchErrorHandleInRightWay =
  testScenario "catchTransferFailure and attempt unwrap exceptions with extra info" $ scenario do
    let action =
          runIO $
              addCallStack $
                annotateExceptions (ScenarioBranchName ["a"]) $
                  addCallStack $
                    annotateExceptions (ScenarioBranchName ["b"]) $
                      throwM $ TransferFailure (AddressAndAlias [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|] Nothing) BadParameter

    res <- attempt @TransferFailure action

    case res of
      Left err -> checkTransferFailure err badParameter
      Right _ -> failure $ "Expected 'attempt' to return a 'bad parameter' exception, but it succeeded."

    action & expectTransferFailure badParameter

data Parameter
  = ExpectAddress Address
    -- ^ Entrypoint that expects an Address as an argument
  | TriggerFailWith
    -- ^ Entrypoint that always fails with the string "oops"
  | TriggerShiftOverflow
    -- ^ Entrypoint that always fails with a shift overflow error.
  | TriggerGasExhaustion
    -- ^ Entrypoint that tried to fall into an infinite loop.
  | VoidEP (Void_ Bool Bool)
    -- ^ A Void entrypoint
  | TriggerFailWithCustomError
    -- ^ Entrypoint that always fails with a custom Lorentz error
  | TriggerFailWithCustomErrorUnit1
    -- ^ Entrypoint that always fails with a custom Lorentz error with a Unit param
  | TriggerFailWithCustomErrorUnit2
    -- ^ Entrypoint that always fails with a custom Lorentz error with a Unit param
  | TriggerFailWithCustomErrorNoArg
    -- ^ Entrypoint that always fails with a custom Lorentz error with no parameter
  | TriggerFailWithRightCombedPair
    -- ^ Entrypoint that always fails with the (1, (2, 3)) pair
  | TriggerFailWithChainIdStr
    -- ^ Entrypoint that always fails with the chain_id "NetXUdfLh6Gm88t"
  | TriggerFailWithChainIdBytes
    -- ^ Entrypoint that always fails with the chain_id "NetXUdfLh6Gm88t"
  deriving stock Generic
  deriving anyclass IsoValue

instance ParameterHasEntrypoints Parameter where
  type ParameterEntrypointsDerivation Parameter = EpdPlain

-- | A contract that triggers a variety of error scenarios
-- depending on the argument it's given.
testContractCode :: '[(Parameter, ())] :-> '[(List Operation, ())]
testContractCode =
  car #
  entryCaseSimple @Parameter
    ( #cExpectAddress /-> L.drop # push () # nil # pair
    , #cTriggerFailWith /-> push ("oops" :: MText) # failWith
    , #cTriggerShiftOverflow /->
        push @Natural 257 #
        push @Natural 1 #
        lsl #
        L.drop # push () # nil @Operation # pair
    , #cTriggerGasExhaustion /-> push True # loop (push True) # failUsing [mt|mem|]
    , #cVoidEP /-> void_ L.not
    , #cTriggerFailWithCustomError /-> push @Natural 1 # failCustom #customError
    , #cTriggerFailWithCustomErrorUnit1 /-> failCustom_ #customErrorUnit1
    , #cTriggerFailWithCustomErrorUnit2 /-> failCustom_ #customErrorUnit2
    , #cTriggerFailWithCustomErrorNoArg /-> failCustomNoArg #customErrorNoArg
    , #cTriggerFailWithRightCombedPair /-> push @(Natural, (Natural, Natural)) (1, (2, 3)) # failWith
    , #cTriggerFailWithChainIdStr /-> push @MText "NetXUdfLh6Gm88t" # failWith
    , #cTriggerFailWithChainIdBytes /-> push @ByteString (unsafe $ fromHex "458aa837") # failWith
    )

type instance ErrorArg "customError" = Natural
instance CustomErrorHasDoc "customError" where
  customErrClass = ErrClassActionException
  customErrDocMdCause = "N/A"

type instance ErrorArg "customErrorUnit1" = ()
instance CustomErrorHasDoc "customErrorUnit1" where
  customErrClass = ErrClassActionException
  customErrDocMdCause = "N/A"

type instance ErrorArg "customErrorUnit2" = L.UnitErrorArg
instance CustomErrorHasDoc "customErrorUnit2" where
  customErrClass = ErrClassActionException
  customErrDocMdCause = "N/A"

type instance ErrorArg "customErrorNoArg" = L.NoErrorArg
instance CustomErrorHasDoc "customErrorNoArg" where
  customErrClass = ErrClassActionException
  customErrDocMdCause = "N/A"

hprop_BooleanOperators_Flatten_TransferFailurePredicates :: Property
hprop_BooleanOperators_Flatten_TransferFailurePredicates = do
  property $ do
    predicate <- forAllWith (pretty . showPredicate) genTransferFailurePredicate

    case predicate of
      TransferFailurePredicate{} -> pass
      AndPredicate ps -> forM_ ps (isFlattened predicate)
      OrPredicate ps -> forM_ ps (isFlattened predicate)

  where
    -- | Check that, in a tree of predicates:
    --
    -- * an "and" node is never followed by another "and" node.
    -- * an "or" node is never followed by another "or" node.
    isFlattened :: TransferFailurePredicate -> TransferFailurePredicate -> PropertyT IO ()
    isFlattened parentPredicate predicate =
      case predicate of
        TransferFailurePredicate{} -> pass
        AndPredicate ps -> do
          case parentPredicate of
            AndPredicate _ -> failedTest "Found 2 adjacent 'and' nodes"
            _ -> pass

          forM_ ps (isFlattened predicate)
        OrPredicate ps -> do
          case parentPredicate of
            OrPredicate _ -> failedTest "Found 2 adjacent 'or' nodes"
            _ -> pass

          forM_ ps (isFlattened predicate)

    showPredicate :: TransferFailurePredicate -> Builder
    showPredicate = \case
      TransferFailurePredicate{} ->
        "TransferFailurePredicate (TransferFailurePredicateDesc  \"\" (const True))"
      AndPredicate ps ->
        pretty $ unlinesF
          [ "AndPredicate"
          , jsonListF' showPredicate ps
          ]
      OrPredicate ps ->
        pretty $ unlinesF
          [ "OrPredicate"
          , jsonListF' showPredicate ps
          ]

    genTransferFailurePredicate :: Gen TransferFailurePredicate
    genTransferFailurePredicate =
      Gen.recursive Gen.choice
        [ pure $ TransferFailurePredicate "" (const True)
        ]
        [ Gen.subterm2 genTransferFailurePredicate genTransferFailurePredicate (&&)
        , Gen.subterm2 genTransferFailurePredicate genTransferFailurePredicate (||)
        , Gen.subterm genTransferFailurePredicate Prelude.not
        ]

testFailWith
  :: ConstantScope t => ((Value t -> ExpressionOrTypedValue) -> TestTree)
  -> [TestTree]
testFailWith f =
  [ testGroup "with EOTVExpression" $ [f (EOTVExpression . toExpression)]
  , testGroup "with EOTVTypedValue" $ [f EOTVTypedValue] ]

test_TransferFailure_predicates :: [TestTree]
test_TransferFailure_predicates = concatMap testFailWith $
  [ impl_test_AndPredicate_succeeds_if_all_conditions_hold
  , impl_test_OrPredicate_succeeds_if_any_condition_holds
  , impl_test_AndPredicate_fails_if_any_condition_fails
  , impl_test_OrPredicate_fails_if_all_conditions_fail
  , impl_test_checkTransferFailure_shows_only_failing_predicates ]

impl_test_AndPredicate_succeeds_if_all_conditions_hold
  , impl_test_OrPredicate_succeeds_if_any_condition_holds
  , impl_test_AndPredicate_fails_if_any_condition_fails
  , impl_test_OrPredicate_fails_if_all_conditions_fail
  , impl_test_checkTransferFailure_shows_only_failing_predicates
  :: (Value (ToT Integer) -> ExpressionOrTypedValue) -> TestTree

impl_test_AndPredicate_succeeds_if_all_conditions_hold conv =
  testScenario "AndPredicate succeeds if all conditions hold" $ scenario do
    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing
    checkTransferFailure err $ failedWith (constant @Integer 1) && addressIs genesisAddress1

impl_test_OrPredicate_succeeds_if_any_condition_holds conv =
  testScenario "AndPredicate succeeds if any condition holds" $ scenario do
    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing
    checkTransferFailure err $
      failedWith (constant @Integer 1) ||
      failedWith (constant @Integer 2) ||
      failedWith (constant @Integer 3)

impl_test_AndPredicate_fails_if_any_condition_fails conv =
  testScenario "AndPredicate succeeds if all conditions hold" $ scenario do
    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing

    checkTransferFailure err
      ( failedWith (constant @Integer 1) &&
        failedWith (constant @Integer 2) &&
        failedWith (constant @Integer 3)
      )
      & shouldFailWithMessage [it|
Expected transfer to fail with an error such that:

  (
    Contract failed with: 2
    AND
    Contract failed with: 3
  )

But these conditions were not met.
Actual transfer error:
  Contract: #{genesisAddress1} failed with: 1|]

impl_test_OrPredicate_fails_if_all_conditions_fail conv =
  testScenario "AndPredicate succeeds if all conditions hold" $ scenario do
    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing

    checkTransferFailure err
      ( failedWith (constant @Integer 2) ||
        failedWith (constant @Integer 3) ||
        failedWith (constant @Integer 4)
      )
      & shouldFailWithMessage [it|
Expected transfer to fail with an error such that:

  (
    Contract failed with: 2
    OR
    Contract failed with: 3
    OR
    Contract failed with: 4
  )

But these conditions were not met.
Actual transfer error:
  Contract: #{genesisAddress1} failed with: 1|]

impl_test_checkTransferFailure_shows_only_failing_predicates conv =
  testScenario "checkTransferFailure shows only failing predicates" $ scenario do
    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing

    checkTransferFailure err
      ( (failedWith (constant @Integer 1) && failedWith (constant @Integer 2)) &&
        (failedWith (constant @Integer 3) && failedWith (constant @Integer 4)) &&
        (failedWith (constant @Integer 1) || failedWith (constant @Integer 6)) &&
        (failedWith (constant @Integer 7) || failedWith (constant @Integer 8))
      )
      & shouldFailWithMessage [it|
Expected transfer to fail with an error such that:

  (
    Contract failed with: 2
    AND
    Contract failed with: 3
    AND
    Contract failed with: 4
    AND
    (
      Contract failed with: 7
      OR
      Contract failed with: 8
    )
  )

But these conditions were not met.
Actual transfer error:
  Contract: #{genesisAddress1} failed with: 1|]