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 Data.Either.Validation (Validation(Success))
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 (parseAddress)
import Morley.Tezos.Core (parseChainId)
import Morley.Util.Interpolate (i)
import Test.Cleveland
import Test.Cleveland.Internal.Abstract
  (ExpressionOrTypedValue(..), FailedInBranch(..), GenericTestError(..), TransferFailure(..),
  TransferFailureReason(..))
import Test.Cleveland.Internal.Actions (TransferFailurePredicate(..))
import Test.Cleveland.Internal.Exceptions (WithCallStack(..))
import Test.Cleveland.Internal.Pure (emptyScenarioBranch)
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 OriginateData
      { odName = "test catchTransferFailure"
      , odStorage = ()
      , odBalance = 1
      , odContract = defaultContract testContractCode
      }

    let (testContractWithNumericErrors, errorTagMap) = useNumericErrors testContractCode
    contractNumericAddr <- originate OriginateData
      { odName = "test catchTransferFailure numeric errors"
      , odStorage = ()
      , odBalance = 1
      , odContract = defaultContract testContractWithNumericErrors
      }

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

    catchTransferFailure $
      call contractAddr (Call @"TriggerFailWith") ()

    expectTransferFailure (failedWith (constant [mt|oops|])) $
      call contractAddr (Call @"TriggerFailWith") ()

    expectTransferFailure (failedWith (constant [mt|oops|]) && addressIs contractAddr) $
      call contractAddr (Call @"TriggerFailWith") ()

    expectFailedWith [mt|oops|] $
      call contractAddr (Call @"TriggerFailWith") ()

    expectError (VoidResult False) $
      call contractAddr (Call @"VoidEP") (mkVoid True)

    expectTransferFailure (failedWith $ constant (1 :: Natural, (2 :: Natural, 3 :: Natural)))  $
      call contractAddr (Call @"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)) $
        call contractAddr (Call @"TriggerFailWithChainIdStr") ()

    expectTransferFailure
      (failedWith (constant @ChainId c)) $
        call contractAddr (Call @"TriggerFailWithChainIdBytes") ()

    expectCustomError #customError 1 $
      call contractAddr (Call @"TriggerFailWithCustomError") ()

    expectCustomError_ #customErrorUnit1 $
      call contractAddr (Call @"TriggerFailWithCustomErrorUnit1") ()

    expectCustomError_ #customErrorUnit2 $
      call contractAddr (Call @"TriggerFailWithCustomErrorUnit2") ()

    expectCustomErrorNoArg #customErrorNoArg $
      call contractAddr (Call @"TriggerFailWithCustomErrorNoArg") ()

    expectNumericError errorTagMap (VoidResult False) $
      call contractNumericAddr (Call @"VoidEP") (mkVoid True)

    expectTransferFailure shiftOverflow $
      call contractAddr (Call @"TriggerShiftOverflow") ()

    expectTransferFailure gasExhaustion $
      call contractAddr (Call @"TriggerGasExhaustion") ()

    expectTransferFailure emptyTransaction $
      transferMoney validAddr 0

    expectTransferFailure badParameter $
      transfer TransferData
        { tdTo = contractAddr
        , tdAmount = 0
        , tdEntrypoint = ep "expectAddress"
        , tdParameter = [mt|aa|]
        }

    expectTransferFailure badParameter $
      transfer TransferData
        { tdTo = contractAddr
        , tdAmount = 0
        , tdEntrypoint = ep "expectAddress"
        , tdParameter = (1 :: Natural)
        }

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

    call contractAddr (Call @"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 . throwM $
              WithCallStack callStack $ SomeException $
                FailedInBranch emptyScenarioBranch $ SomeException $
                  WithCallStack callStack $ SomeException $
                    FailedInBranch emptyScenarioBranch $ SomeException $
                      TransferFailure (unsafe $ parseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC") 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 :: ContractCode Parameter ()
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 \\_ -> Success ()"
      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 \_ -> Success ()
        ]
        [ Gen.subterm2 genTransferFailurePredicate genTransferFailurePredicate (&&)
        , Gen.subterm2 genTransferFailurePredicate genTransferFailurePredicate (||)
        ]

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 genesisAddress1 $ 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 genesisAddress1 $ 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 genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing

    checkTransferFailure err
      ( failedWith (constant @Integer 1) &&
        failedWith (constant @Integer 2) &&
        failedWith (constant @Integer 3)
      )
      & shouldFailWithMessage [i|
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: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]

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

    checkTransferFailure err
      ( failedWith (constant @Integer 2) ||
        failedWith (constant @Integer 3) ||
        failedWith (constant @Integer 4)
      )
      & shouldFailWithMessage [i|
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: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]

impl_test_checkTransferFailure_shows_only_failing_predicates conv =
  testScenario "checkTransferFailure shows only failing predicates" $ scenario do
    let err = TransferFailure genesisAddress1 $ 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 [i|
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: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]