-- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_HADDOCK not-home #-} -- | 'TransferFailure' Predicates module Test.Cleveland.Internal.Actions.TransferFailurePredicate ( module Test.Cleveland.Internal.Actions.TransferFailurePredicate ) where import Control.Lens (makeLenses) import Fmt (Buildable(..), Doc) import Lorentz (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText, errorToVal, errorToValNumeric, toVal) import Lorentz.Constraints import Morley.Micheline (Expression, fromExpression, toExpression) import Morley.Michelson.Typed (Constrained(..), SomeConstant) import Test.Cleveland.Internal.Abstract import Test.Cleveland.Lorentz.Types -- | A predicate that checks whether a transfer operation failed for the expected reason. -- -- Predicates can be combined using the '&&' and '||' operators. data TransferFailurePredicate = TransferFailurePredicate -- ^ Predicate with a description TransferFailurePredicateDesc -- ^ The explanation of the expected outcome. (TransferFailure -> Bool) -- ^ The predicate itself. | AndPredicate (NonEmpty TransferFailurePredicate) | OrPredicate (NonEmpty TransferFailurePredicate) data TransferFailurePredicateDesc = TransferFailurePredicateDesc { _tfpdNegated :: Bool , _tfpdDescription :: Doc } makeLenses ''TransferFailurePredicateDesc instance Buildable TransferFailurePredicateDesc where build TransferFailurePredicateDesc{..} | _tfpdNegated = "NOT (" <> build _tfpdDescription <> ")" | otherwise = build _tfpdDescription instance IsString TransferFailurePredicateDesc where fromString = tfpd . fromString tfpd :: Doc -> TransferFailurePredicateDesc tfpd = TransferFailurePredicateDesc False instance Boolean TransferFailurePredicate where AndPredicate l && AndPredicate r = AndPredicate $ l <> r AndPredicate l && r = AndPredicate $ l <> one r l && AndPredicate r = AndPredicate $ one l <> r l && r = AndPredicate $ one l <> one r OrPredicate l || OrPredicate r = OrPredicate $ l <> r OrPredicate l || r = OrPredicate $ l <> one r l || OrPredicate r = OrPredicate $ one l <> r l || r = OrPredicate $ one l <> one r not = \case TransferFailurePredicate msg p -> TransferFailurePredicate (msg & tfpdNegated %~ not) (not . p) AndPredicate xs -> OrPredicate $ not <$> xs OrPredicate xs -> AndPredicate $ not <$> xs transferFailureReasonPredicate :: Doc -> (TransferFailureReason -> Bool) -> TransferFailurePredicate transferFailureReasonPredicate b p = TransferFailurePredicate (tfpd b) (p . tfReason) -- | Asserts that interpretation of a contract failed due to an overflow error. shiftOverflow :: TransferFailurePredicate shiftOverflow = transferFailureReasonPredicate "Contract failed due to an overflow error" (== ShiftOverflow) -- | Asserts that an action failed due to an attempt to transfer 0tz towards a simple address. emptyTransaction :: TransferFailurePredicate emptyTransaction = transferFailureReasonPredicate "Attempted to transfer 0tz to a simple address" (== EmptyTransaction) -- | Asserts that an action failed due to an attempt to call a contract with an invalid parameter. badParameter :: TransferFailurePredicate badParameter = transferFailureReasonPredicate "Attempted to call a contract with a parameter of the wrong type" (== BadParameter) -- | Asserts that interpretation of a contract failed due to gas exhaustion. gasExhaustion :: TransferFailurePredicate gasExhaustion = transferFailureReasonPredicate "Execution failed due to gas exhaustion" (== GasExhaustion) -- | Asserts that interpretation of a contract ended with @FAILWITH@, throwing the given error. -- -- This function should be used together with one of the "@FAILWITH@ constructors" -- (e.g. 'constant', 'customError'). failedWith :: SomeConstant -> TransferFailurePredicate failedWith expectedFailWithVal = failedWithPredicate ("Contract failed with: " <> build expectedFailWithVal) (isEq expectedFailWithVal) where isEq :: SomeConstant -> Expression -> Bool isEq (SomeConstant v) = either (const False) (== v) . fromExpression -- | Asserts that interpretation of a contract ended with @FAILWITH@, and the -- error satisfies the given predicate. failedWithPredicate :: Doc -> (Expression -> Bool) -> TransferFailurePredicate failedWithPredicate msg valPredicate = transferFailureReasonPredicate msg $ \case FailedWith eotv _ -> valPredicate $ case eotv of EOTVExpression expr -> expr EOTVTypedValue tv -> toExpression tv _ -> False -- | Asserts that the error occurred while interpreting the contract with the given address. addressIs :: ToAddress addr => addr -- ^ The expected address. -> TransferFailurePredicate addressIs (toAddress -> expectedAddr) = TransferFailurePredicate (tfpd $ "Failure occurred in contract with address: " <> build expectedAddr) \TransferFailure{..} -> toAddress tfAddressAndAlias == expectedAddr ---------------------------------------------------------------------------- -- 'FAILWITH' errors ---------------------------------------------------------------------------- -- | A constant michelson value that a contract threw with @FAILWITH@. constant :: forall err. NiceConstant err => err -> SomeConstant constant err = SomeConstant $ toVal err -- | A lorentz error. lerror :: forall err. IsError err => err -> SomeConstant lerror err = errorToVal err SomeConstant -- | A custom lorentz error. customError :: forall arg tag. (IsError (CustomError tag), MustHaveErrorArg tag (MText, arg)) => Label tag -> arg -> SomeConstant customError tag arg = lerror $ CustomError tag (errorTagToMText tag, arg) -- | A custom lorentz error with a @unit@ argument. customError_ :: (IsError (CustomError tag), MustHaveErrorArg tag (MText, ())) => Label tag -> SomeConstant customError_ tag = customError tag () -- | A custom lorentz error with no argument. customErrorNoArg :: (IsError (CustomError tag), MustHaveErrorArg tag MText) => Label tag -> SomeConstant customErrorNoArg tag = lerror $ CustomError tag (errorTagToMText tag) -- | A lorentz numeric error. numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant numericError tagMap err = errorToValNumeric tagMap err SomeConstant