{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{- | Module: Cardano.TestUtils
Description: Construct nominal and attack test cases for unit tests

This module exposes a flexible way to generate test cases that go
through a pre-processing -> pre-condition -> execution -> post-condition
pipeline.

The intention is to provide an easier interface to re-using predicates and pre-processors
between many tests and between different _kinds_ of tests, including nominal and attack
cases, as well as unit and property testing.

This module is currently targeted primarily at tests run on the CEK machine.
In the future, it may be expanded to be polymorphic in terms of arbitrary
"computation". The current computation type is essentially hard-coded to

  (Maybe Datum, Redeemer, ScriptContext, Script) -> (Either EvalError Script, ExBudget, Logs)

but this could be expanded so that other types of tests (emulator, integration, serialization,
golden) could be run as well.
-}
module Cardano.TestUtils (
  -- * Polymorphic Types and Functions

  -- ** PreProcessing
  PreProcessor,

  -- *** Construction
  mkPreProcessor,

  -- *** Elimination
  preProcess,

  -- ** PreCondition Checking
  PreCondition,

  -- *** Construction
  mkPreCondition,

  -- *** Elimination
  checkPreConditions,

  -- ** PostCondition Checking
  PostCondition,

  -- *** Construction
  mkPostCondition,

  -- *** Elimination
  checkPostConditions,

  -- ** Test Cases
  PipelinedTestCase (..),
  PipelinedTestErrors (..),
  pipelinedUnitCase,

  -- * TxFCEKMachinery

  -- ** Generic TxF TestCase
  TxFCEKCase,
  TxFCEKInput (..),
  TxFCEKOutput (..),
  mkTxFCEKCase,
  txfCEKUnitCase,

  -- *** Nominal Tests
  nominalPostCondition,
  nominalCaseBasic,

  -- *** Attack Tests
  attackCaseRegexPostCondition,
  attackCaseBasicRegex,
) where

import Control.Arrow (Kleisli (Kleisli), runKleisli, (>>>))
import Data.Foldable (fold, foldl')
import Data.List (intercalate)
import Data.Monoid (First (First), getFirst)
import Data.Text (Text)
import Plutarch (Script)
import Plutarch.Evaluate (EvalError, evalScriptHuge)
import Plutarch.Extra.Script (applyArguments)
import PlutusCore.Data qualified as PLC
import PlutusLedgerApi.V2 (Datum, ExBudget, Redeemer, ScriptContext, toData)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (assertFailure, testCase)
import Text.RE.TDFA.Text (RE, countMatches, reSource, (*=~))

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

-- | PreProcessing -- could be used for normalization or attacks
newtype PreProcessor err input = PreProcessor
  { forall err input.
PreProcessor err input -> Kleisli (Either err) input input
preProcessor ::
      Kleisli
        (Either err)
        input
        input
  }

mkPreProcessor :: (input -> Either err input) -> PreProcessor err input
mkPreProcessor :: forall input err.
(input -> Either err input) -> PreProcessor err input
mkPreProcessor = Kleisli (Either err) input input -> PreProcessor err input
forall err input.
Kleisli (Either err) input input -> PreProcessor err input
PreProcessor (Kleisli (Either err) input input -> PreProcessor err input)
-> ((input -> Either err input)
    -> Kleisli (Either err) input input)
-> (input -> Either err input)
-> PreProcessor err input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (input -> Either err input) -> Kleisli (Either err) input input
forall (m :: Type -> Type) a b. (a -> m b) -> Kleisli m a b
Kleisli

{- | Given a list of preprocessors, apply them in order from left to right.
Returns the first error encountered, if any.
-}
preProcess ::
  [PreProcessor err input] ->
  input ->
  Either err input
preProcess :: forall err input.
[PreProcessor err input] -> input -> Either err input
preProcess [PreProcessor err input]
pps = Kleisli (Either err) input input -> input -> Either err input
forall (m :: Type -> Type) a b. Kleisli m a b -> a -> m b
runKleisli (Kleisli (Either err) input input -> input -> Either err input)
-> Kleisli (Either err) input input -> input -> Either err input
forall a b. (a -> b) -> a -> b
$ (Kleisli (Either err) input input
 -> Kleisli (Either err) input input
 -> Kleisli (Either err) input input)
-> Kleisli (Either err) input input
-> [Kleisli (Either err) input input]
-> Kleisli (Either err) input input
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Kleisli (Either err) input input
-> Kleisli (Either err) input input
-> Kleisli (Either err) input input
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category @k cat =>
cat a b -> cat b c -> cat a c
(>>>) ((input -> Either err input) -> Kleisli (Either err) input input
forall (m :: Type -> Type) a b. (a -> m b) -> Kleisli m a b
Kleisli input -> Either err input
forall a. a -> Either err a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure) ((PreProcessor err input -> Kleisli (Either err) input input)
-> [PreProcessor err input] -> [Kleisli (Either err) input input]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap PreProcessor err input -> Kleisli (Either err) input input
forall err input.
PreProcessor err input -> Kleisli (Either err) input input
preProcessor [PreProcessor err input]
pps)

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

{- | Checks for after the preprocessing is run. Could be used to check for
balancing, etc

TODO: rewrite as Kleisli?
-}
newtype PreCondition err input = PreCondition
  { forall err input. PreCondition err input -> input -> First err
preCondition :: input -> First err
  }

mkPreCondition :: (input -> Maybe err) -> PreCondition err input
mkPreCondition :: forall input err. (input -> Maybe err) -> PreCondition err input
mkPreCondition input -> Maybe err
f = (input -> First err) -> PreCondition err input
forall err input. (input -> First err) -> PreCondition err input
PreCondition (Maybe err -> First err
forall a. Maybe a -> First a
First (Maybe err -> First err)
-> (input -> Maybe err) -> input -> First err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Maybe err
f)

-- | Check a list of pre-conditions, returning the first error encountered
checkPreConditions ::
  [PreCondition err input] ->
  input ->
  Maybe err
checkPreConditions :: forall err input. [PreCondition err input] -> input -> Maybe err
checkPreConditions [PreCondition err input]
pcs input
args =
  First err -> Maybe err
forall a. First a -> Maybe a
getFirst ((PreCondition err input -> First err)
-> [PreCondition err input] -> First err
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((\input -> First err
x -> input -> First err
x input
args) ((input -> First err) -> First err)
-> (PreCondition err input -> input -> First err)
-> PreCondition err input
-> First err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreCondition err input -> input -> First err
forall err input. PreCondition err input -> input -> First err
preCondition) [PreCondition err input]
pcs)

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

{- | Represents a partial post-condition predicate on the result of
a call to `evalScript :: Script -> (Either EvalError Script, ExBudget, [Text]) `
TODO: Rewrite as Kleisli?

TODO: If its possible to turn budgeting off, we should. These scripts
will be run with some logging output, and they wouldn't in production; thus
costing is not actually representative of anything useful.
-}
newtype PostCondition err output = PostCondition
  {forall err output. PostCondition err output -> output -> First err
postCondition :: output -> First err}

mkPostCondition :: (output -> Maybe err) -> PostCondition err output
mkPostCondition :: forall output err.
(output -> Maybe err) -> PostCondition err output
mkPostCondition output -> Maybe err
f = (output -> First err) -> PostCondition err output
forall err output.
(output -> First err) -> PostCondition err output
PostCondition (Maybe err -> First err
forall a. Maybe a -> First a
First (Maybe err -> First err)
-> (output -> Maybe err) -> output -> First err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. output -> Maybe err
f)

{- | Check a list of post-conditions from left to right, returning the first
error encountered
-}
checkPostConditions ::
  [PostCondition err output] ->
  output ->
  Maybe err
checkPostConditions :: forall err output.
[PostCondition err output] -> output -> Maybe err
checkPostConditions [PostCondition err output]
pcs output
args =
  First err -> Maybe err
forall a. First a -> Maybe a
getFirst ((PostCondition err output -> First err)
-> [PostCondition err output] -> First err
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((\output -> First err
x -> output -> First err
x output
args) ((output -> First err) -> First err)
-> (PostCondition err output -> output -> First err)
-> PostCondition err output
-> First err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostCondition err output -> output -> First err
forall err output. PostCondition err output -> output -> First err
postCondition) [PostCondition err output]
pcs)

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

{- | A type representing a named test case for a transaction family.
NOTE: if the `sc-tools` work ends up panning out, the `args` and `script` arguments
might get combined to a (Maybe Datum, Redeemer, ScriptContext, Script)
-}
data PipelinedTestCase errPP errPreC errPostC input output = PipelinedTestCase
  { forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output -> String
name :: String
  -- ^ Name of the test case
  , forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output
-> [PreProcessor errPP input]
preProcessors :: [PreProcessor errPP input]
  -- ^ Pre-processors (normalizers or attacks); applied in order from left to right
  , forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output
-> [PreCondition errPreC input]
preConditions :: [PreCondition errPreC input]
  -- ^ Pre-condition Checking. Run after pre-processing
  , forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output -> input
input :: input
  -- ^ the input to the computation
  , forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output
-> input -> output
computation :: input -> output
  -- ^ the computation to run
  , forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output
-> [PostCondition errPostC output]
postConditions :: [PostCondition errPostC output]
  -- ^ Post conditions are checked after script execution
  }

-- | A sum type to collect the errors of a pipelined test case
data PipelinedTestErrors errPP errPreC errPostC
  = PipelinedPreProcessorError errPP
  | PipelinedPreConditionError errPreC
  | PipelinedPostConditionError errPostC

{- | Behavior of this function:

- 1.) All pre-processors are run in order from left to right on the arguments.
  If any pre-processor returns a Left, then the resulting test case fails with
  the appropriate error message.
- 2.) All pre-condition checks are run on the pre-processed arguments.
  If any pre-condition checks return Nothing, then the resulting test case fails
  with the appropriate error meesage.
- 3.) The pre-processed arguments are fed to the script.
- 4.) The results of (3) are checked against each post-condition.
  If any of the post-condition checks fail, the test case fails with the appropriate
  error message
- 5.) If none of the above checks cause a failure, the test succeeds.
-}
pipelinedUnitCase ::
  (Show errPP, Show errPreC, Show errPostC) =>
  PipelinedTestCase errPP errPreC errPostC input output ->
  TestTree
pipelinedUnitCase :: forall errPP errPreC errPostC input output.
(Show errPP, Show errPreC, Show errPostC) =>
PipelinedTestCase errPP errPreC errPostC input output -> TestTree
pipelinedUnitCase
  PipelinedTestCase
    { $sel:name:PipelinedTestCase :: forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output -> String
name = String
name'
    , $sel:preProcessors:PipelinedTestCase :: forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output
-> [PreProcessor errPP input]
preProcessors = [PreProcessor errPP input]
preProcessors'
    , $sel:preConditions:PipelinedTestCase :: forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output
-> [PreCondition errPreC input]
preConditions = [PreCondition errPreC input]
preConditions'
    , $sel:input:PipelinedTestCase :: forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output -> input
input = input
input'
    , $sel:computation:PipelinedTestCase :: forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output
-> input -> output
computation = input -> output
computation'
    , $sel:postConditions:PipelinedTestCase :: forall errPP errPreC errPostC input output.
PipelinedTestCase errPP errPreC errPostC input output
-> [PostCondition errPostC output]
postConditions = [PostCondition errPostC output]
postConditions'
    } =
    String -> Assertion -> TestTree
testCase String
name' (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
      -- Run preprocessing
      case [PreProcessor errPP input] -> input -> Either errPP input
forall err input.
[PreProcessor err input] -> input -> Either err input
preProcess [PreProcessor errPP input]
preProcessors' input
input' of
        Left errPP
err -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ errPP -> String
forall a. Show a => a -> String
show errPP
err
        Right input
preProcessedArgs ->
          -- Run pre-condition  checks
          case [PreCondition errPreC input] -> input -> Maybe errPreC
forall err input. [PreCondition err input] -> input -> Maybe err
checkPreConditions [PreCondition errPreC input]
preConditions' input
preProcessedArgs of
            Just errPreC
err' -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ errPreC -> String
forall a. Show a => a -> String
show errPreC
err'
            Maybe errPreC
Nothing ->
              -- Run computation
              let
                evaluationResult :: output
evaluationResult =
                  input -> output
computation' input
preProcessedArgs
               in
                -- Run post condition checks
                case [PostCondition errPostC output] -> output -> Maybe errPostC
forall err output.
[PostCondition err output] -> output -> Maybe err
checkPostConditions [PostCondition errPostC output]
postConditions' output
evaluationResult of
                  Just errPostC
err'' -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ errPostC -> String
forall a. Show a => a -> String
show errPostC
err''
                  Maybe errPostC
Nothing -> () -> Assertion
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

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

-- * TxF CEK Machinery

{- | The arguments needed to run a YTxP-style transaction family (single script)
on the CEK Machine. Includes a datum (for validators only), a redeemer, script context,
and the script itself.
-}
data TxFCEKInput = TxFCEKInput
  { TxFCEKInput -> Maybe Datum
cekDatum :: Maybe Datum
  , TxFCEKInput -> Redeemer
cekRedeemer :: Redeemer
  , TxFCEKInput -> ScriptContext
cekScriptContext :: ScriptContext
  , TxFCEKInput -> Script
cekScript :: Script
  }
  deriving stock (TxFCEKInput -> TxFCEKInput -> Bool
(TxFCEKInput -> TxFCEKInput -> Bool)
-> (TxFCEKInput -> TxFCEKInput -> Bool) -> Eq TxFCEKInput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxFCEKInput -> TxFCEKInput -> Bool
== :: TxFCEKInput -> TxFCEKInput -> Bool
$c/= :: TxFCEKInput -> TxFCEKInput -> Bool
/= :: TxFCEKInput -> TxFCEKInput -> Bool
Eq, Int -> TxFCEKInput -> ShowS
[TxFCEKInput] -> ShowS
TxFCEKInput -> String
(Int -> TxFCEKInput -> ShowS)
-> (TxFCEKInput -> String)
-> ([TxFCEKInput] -> ShowS)
-> Show TxFCEKInput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxFCEKInput -> ShowS
showsPrec :: Int -> TxFCEKInput -> ShowS
$cshow :: TxFCEKInput -> String
show :: TxFCEKInput -> String
$cshowList :: [TxFCEKInput] -> ShowS
showList :: [TxFCEKInput] -> ShowS
Show)

-- | The data produced by the CEK machine when run against a TxFCEKInput.
data TxFCEKOutput = TxFCEKOutput
  { TxFCEKOutput -> Either EvalError Script
cekResult :: Either EvalError Script
  , TxFCEKOutput -> ExBudget
cekExBudget :: ExBudget
  , TxFCEKOutput -> [Text]
cekLogs :: [Text]
  }
  deriving stock (TxFCEKOutput -> TxFCEKOutput -> Bool
(TxFCEKOutput -> TxFCEKOutput -> Bool)
-> (TxFCEKOutput -> TxFCEKOutput -> Bool) -> Eq TxFCEKOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxFCEKOutput -> TxFCEKOutput -> Bool
== :: TxFCEKOutput -> TxFCEKOutput -> Bool
$c/= :: TxFCEKOutput -> TxFCEKOutput -> Bool
/= :: TxFCEKOutput -> TxFCEKOutput -> Bool
Eq, Int -> TxFCEKOutput -> ShowS
[TxFCEKOutput] -> ShowS
TxFCEKOutput -> String
(Int -> TxFCEKOutput -> ShowS)
-> (TxFCEKOutput -> String)
-> ([TxFCEKOutput] -> ShowS)
-> Show TxFCEKOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxFCEKOutput -> ShowS
showsPrec :: Int -> TxFCEKOutput -> ShowS
$cshow :: TxFCEKOutput -> String
show :: TxFCEKOutput -> String
$cshowList :: [TxFCEKOutput] -> ShowS
showList :: [TxFCEKOutput] -> ShowS
Show)

-- | A sum type of the errors for a TxFCEKCase
newtype TxFCEKCase errPP errPreC errPostC
  = TxFCEKCase
      ( PipelinedTestCase
          errPP
          errPreC
          errPostC
          TxFCEKInput
          TxFCEKOutput
      )

-- | Create a TxFCEKCase by filling in the computation via running the script.
mkTxFCEKCase ::
  forall (errPP :: Type) (errPreC :: Type) (errPostC :: Type).
  -- | Name of the test case
  String ->
  -- | List of pre-processors over something like (Maybe Datum, Redeemer, ScriptContext, Script)
  [PreProcessor errPP TxFCEKInput] ->
  -- | List of pre-condition checks over something like (Maybe Datum, Redeemer, ScriptContext, Script)
  [PreCondition errPreC TxFCEKInput] ->
  -- | Something like (Maybe Datum, Redeemer, ScriptContext, Script)
  TxFCEKInput ->
  -- | Post-conditions over something like (Either EvalError Script, ExBudget, [Text])
  [PostCondition errPostC TxFCEKOutput] ->
  TxFCEKCase errPP errPreC errPostC
mkTxFCEKCase :: forall errPP errPreC errPostC.
String
-> [PreProcessor errPP TxFCEKInput]
-> [PreCondition errPreC TxFCEKInput]
-> TxFCEKInput
-> [PostCondition errPostC TxFCEKOutput]
-> TxFCEKCase errPP errPreC errPostC
mkTxFCEKCase String
name' [PreProcessor errPP TxFCEKInput]
pps [PreCondition errPreC TxFCEKInput]
preCs TxFCEKInput
input' [PostCondition errPostC TxFCEKOutput]
postCs =
  PipelinedTestCase errPP errPreC errPostC TxFCEKInput TxFCEKOutput
-> TxFCEKCase errPP errPreC errPostC
forall errPP errPreC errPostC.
PipelinedTestCase errPP errPreC errPostC TxFCEKInput TxFCEKOutput
-> TxFCEKCase errPP errPreC errPostC
TxFCEKCase (PipelinedTestCase errPP errPreC errPostC TxFCEKInput TxFCEKOutput
 -> TxFCEKCase errPP errPreC errPostC)
-> PipelinedTestCase
     errPP errPreC errPostC TxFCEKInput TxFCEKOutput
-> TxFCEKCase errPP errPreC errPostC
forall a b. (a -> b) -> a -> b
$
    PipelinedTestCase
      { $sel:name:PipelinedTestCase :: String
name = String
name'
      , $sel:preProcessors:PipelinedTestCase :: [PreProcessor errPP TxFCEKInput]
preProcessors = [PreProcessor errPP TxFCEKInput]
pps
      , $sel:preConditions:PipelinedTestCase :: [PreCondition errPreC TxFCEKInput]
preConditions = [PreCondition errPreC TxFCEKInput]
preCs
      , $sel:input:PipelinedTestCase :: TxFCEKInput
input = TxFCEKInput
input'
      , $sel:computation:PipelinedTestCase :: TxFCEKInput -> TxFCEKOutput
computation = TxFCEKInput -> TxFCEKOutput
comp
      , $sel:postConditions:PipelinedTestCase :: [PostCondition errPostC TxFCEKOutput]
postConditions = [PostCondition errPostC TxFCEKOutput]
postCs
      }
  where
    comp :: TxFCEKInput -> TxFCEKOutput
    comp :: TxFCEKInput -> TxFCEKOutput
comp (TxFCEKInput Maybe Datum
md Redeemer
r ScriptContext
sc Script
script) =
      let
        dataArgs :: [Data]
dataArgs = (Maybe Datum, Redeemer, ScriptContext) -> [Data]
mkDataArgs (Maybe Datum
md, Redeemer
r, ScriptContext
sc)
        (Either EvalError Script
res, ExBudget
budget, [Text]
logs) = Script -> (Either EvalError Script, ExBudget, [Text])
evalScriptHuge (Script -> (Either EvalError Script, ExBudget, [Text]))
-> ([Data] -> Script)
-> [Data]
-> (Either EvalError Script, ExBudget, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> [Data] -> Script
applyArguments Script
script ([Data] -> (Either EvalError Script, ExBudget, [Text]))
-> [Data] -> (Either EvalError Script, ExBudget, [Text])
forall a b. (a -> b) -> a -> b
$ [Data]
dataArgs
       in
        Either EvalError Script -> ExBudget -> [Text] -> TxFCEKOutput
TxFCEKOutput Either EvalError Script
res ExBudget
budget [Text]
logs

txfCEKUnitCase ::
  forall (errPP :: Type) (errPreC :: Type) (errPostC :: Type).
  (Show errPP, Show errPreC, Show errPostC) =>
  TxFCEKCase errPP errPreC errPostC ->
  TestTree
txfCEKUnitCase :: forall errPP errPreC errPostC.
(Show errPP, Show errPreC, Show errPostC) =>
TxFCEKCase errPP errPreC errPostC -> TestTree
txfCEKUnitCase (TxFCEKCase PipelinedTestCase errPP errPreC errPostC TxFCEKInput TxFCEKOutput
pipelinedCase) = PipelinedTestCase errPP errPreC errPostC TxFCEKInput TxFCEKOutput
-> TestTree
forall errPP errPreC errPostC input output.
(Show errPP, Show errPreC, Show errPostC) =>
PipelinedTestCase errPP errPreC errPostC input output -> TestTree
pipelinedUnitCase PipelinedTestCase errPP errPreC errPostC TxFCEKInput TxFCEKOutput
pipelinedCase

--------------------------------------------------------------------------------
-- Nominal Case

{- | A post condition for checking whether the script execution succeeded or failed
You must supply a way to turn a generic evaluation error into your domain-specific
error type
-}
nominalPostCondition ::
  ((EvalError, [Text]) -> err) -> PostCondition err TxFCEKOutput
nominalPostCondition :: forall err.
((EvalError, [Text]) -> err) -> PostCondition err TxFCEKOutput
nominalPostCondition (EvalError, [Text]) -> err
toErr =
  (TxFCEKOutput -> Maybe err) -> PostCondition err TxFCEKOutput
forall output err.
(output -> Maybe err) -> PostCondition err output
mkPostCondition ((TxFCEKOutput -> Maybe err) -> PostCondition err TxFCEKOutput)
-> (TxFCEKOutput -> Maybe err) -> PostCondition err TxFCEKOutput
forall a b. (a -> b) -> a -> b
$ \(TxFCEKOutput Either EvalError Script
eitherErrOrScript ExBudget
_ [Text]
logs) ->
    case Either EvalError Script
eitherErrOrScript of
      Left EvalError
evalErr -> err -> Maybe err
forall a. a -> Maybe a
Just (err -> Maybe err) -> err -> Maybe err
forall a b. (a -> b) -> a -> b
$ (EvalError, [Text]) -> err
toErr (EvalError
evalErr, [Text]
logs)
      Right Script
_ -> Maybe err
forall a. Maybe a
Nothing

{- | A basic nominal case unit test.
Only checks if the script succeeds; does not do pre-processing, pre-condition checking,
or other post-condition checks.

Throws a generic "String" error (not domain-specific)
-}
nominalCaseBasic ::
  -- | Name of the test case
  String ->
  -- | Datum to apply to the script. Set this to Nothing unless you are
  -- testing a validator
  Maybe Datum ->
  -- | Redeemer
  Redeemer ->
  -- | Nominal context to apply Nominal
  ScriptContext ->
  -- | Nominal to apply
  Script ->
  TxFCEKCase String String String
nominalCaseBasic :: String
-> Maybe Datum
-> Redeemer
-> ScriptContext
-> Script
-> TxFCEKCase String String String
nominalCaseBasic String
name' Maybe Datum
maybeDatum Redeemer
redeemer ScriptContext
nominalCtx Script
script =
  let
    errorPrinter :: ((EvalError, [Text]) -> String)
    errorPrinter :: (EvalError, [Text]) -> String
errorPrinter (EvalError
err, [Text]
logs) =
      String
"Script failed.\nEvaluation error: \n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EvalError -> String
forall a. Show a => a -> String
show EvalError
err
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n Trace Log: \n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (Text -> String
forall a. Show a => a -> String
show (Text -> String) -> [Text] -> [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
logs)
   in
    String
-> [PreProcessor String TxFCEKInput]
-> [PreCondition String TxFCEKInput]
-> TxFCEKInput
-> [PostCondition String TxFCEKOutput]
-> TxFCEKCase String String String
forall errPP errPreC errPostC.
String
-> [PreProcessor errPP TxFCEKInput]
-> [PreCondition errPreC TxFCEKInput]
-> TxFCEKInput
-> [PostCondition errPostC TxFCEKOutput]
-> TxFCEKCase errPP errPreC errPostC
mkTxFCEKCase
      String
name'
      []
      []
      (Maybe Datum -> Redeemer -> ScriptContext -> Script -> TxFCEKInput
TxFCEKInput Maybe Datum
maybeDatum Redeemer
redeemer ScriptContext
nominalCtx Script
script)
      [((EvalError, [Text]) -> String)
-> PostCondition String TxFCEKOutput
forall err.
((EvalError, [Text]) -> err) -> PostCondition err TxFCEKOutput
nominalPostCondition (EvalError, [Text]) -> String
errorPrinter]

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

{- | The attackCaseRegex-style functions will fail with
  - A (Nothing, [Text]) if the script succeeds. [Text] in the tuple contains the logs.
  - A (Just Int, [Text]) if the script fails, but the regex does not match exactly once.
    The int contains the number of matches
-}
attackCaseRegexPostCondition ::
  -- | A way to go from the number of matches (if unequal to 1) and the logs to
  -- a domain-specific error
  ((Maybe Int, [Text]) -> err) ->
  -- | The regular expression to match against. It must match exactly once
  -- for the post-condition check to pass
  RE ->
  PostCondition err TxFCEKOutput
attackCaseRegexPostCondition :: forall err.
((Maybe Int, [Text]) -> err)
-> RE -> PostCondition err TxFCEKOutput
attackCaseRegexPostCondition (Maybe Int, [Text]) -> err
toErr RE
expectedFailureRE =
  (TxFCEKOutput -> Maybe err) -> PostCondition err TxFCEKOutput
forall output err.
(output -> Maybe err) -> PostCondition err output
mkPostCondition ((TxFCEKOutput -> Maybe err) -> PostCondition err TxFCEKOutput)
-> (TxFCEKOutput -> Maybe err) -> PostCondition err TxFCEKOutput
forall a b. (a -> b) -> a -> b
$ \(TxFCEKOutput Either EvalError Script
eitherErrorOrScript ExBudget
_ [Text]
logs) ->
    case Either EvalError Script
eitherErrorOrScript of
      Left EvalError
_evalError ->
        let
          numMatches :: Int
numMatches = Matches Text -> Int
forall a. Matches a -> Int
countMatches ([Text] -> Text
forall m. Monoid m => [m] -> m
forall (t :: Type -> Type) m. (Foldable t, Monoid m) => t m -> m
fold [Text]
logs Text -> RE -> Matches Text
*=~ RE
expectedFailureRE)
         in
          if Int
numMatches Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
            then Maybe err
forall a. Maybe a
Nothing
            else err -> Maybe err
forall a. a -> Maybe a
Just (err -> Maybe err) -> err -> Maybe err
forall a b. (a -> b) -> a -> b
$ (Maybe Int, [Text]) -> err
toErr (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
numMatches, [Text]
logs)
      Right Script
_ ->
        err -> Maybe err
forall a. a -> Maybe a
Just (err -> Maybe err) -> err -> Maybe err
forall a b. (a -> b) -> a -> b
$ (Maybe Int, [Text]) -> err
toErr (Maybe Int
forall a. Maybe a
Nothing, [Text]
logs)

{- | Generate an "attack case" test tree, given a name, an expected failure condition,
the arguments to the script, an attack, and the script itself.

The expected failure condition is matched as a regex. It must match the logs exactly once.
-}
attackCaseBasicRegex ::
  -- | Name of the test case
  String ->
  -- | Expected Failure String Match; TODO: This can be improved. Maybe use
  -- a discriminated error sum type with a injective string mapping?
  RE ->
  -- | Datum to apply to the script. Set this to Nothing unless you are
  -- testing a validator
  Maybe Datum ->
  -- | Redeemer
  Redeemer ->
  -- | Nominal context to apply attack
  ScriptContext ->
  -- | The script to execute
  Script ->
  -- | Attack to apply
  PreProcessor errPP TxFCEKInput ->
  TxFCEKCase errPP String String
attackCaseBasicRegex :: forall errPP.
String
-> RE
-> Maybe Datum
-> Redeemer
-> ScriptContext
-> Script
-> PreProcessor errPP TxFCEKInput
-> TxFCEKCase errPP String String
attackCaseBasicRegex String
name' RE
expectedFailureRE Maybe Datum
maybeDatum Redeemer
redeemer ScriptContext
nominalCtx Script
script' PreProcessor errPP TxFCEKInput
attack =
  let
    errorPrinter :: (Maybe Int, [Text]) -> String
errorPrinter (Maybe Int
Nothing, [Text]
logs) =
      String
"Script Succeeded, but failure was expected. Logs: \n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n    " (Text -> String
forall a. Show a => a -> String
show (Text -> String) -> [Text] -> [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
logs)
    errorPrinter (Just Int
numMatches, [Text]
logs) =
      String
"The script execution against the attack case failed, but without "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"the expected error. The regex\n    "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RE -> String
reSource RE
expectedFailureRE
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nshould have matched the logs exactly once, but it matched "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numMatches
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" times."
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nLogs:\n    "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n    " (Text -> String
forall a. Show a => a -> String
show (Text -> String) -> [Text] -> [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
logs)
   in
    String
-> [PreProcessor errPP TxFCEKInput]
-> [PreCondition String TxFCEKInput]
-> TxFCEKInput
-> [PostCondition String TxFCEKOutput]
-> TxFCEKCase errPP String String
forall errPP errPreC errPostC.
String
-> [PreProcessor errPP TxFCEKInput]
-> [PreCondition errPreC TxFCEKInput]
-> TxFCEKInput
-> [PostCondition errPostC TxFCEKOutput]
-> TxFCEKCase errPP errPreC errPostC
mkTxFCEKCase
      String
name'
      [PreProcessor errPP TxFCEKInput
attack]
      []
      (Maybe Datum -> Redeemer -> ScriptContext -> Script -> TxFCEKInput
TxFCEKInput Maybe Datum
maybeDatum Redeemer
redeemer ScriptContext
nominalCtx Script
script')
      [((Maybe Int, [Text]) -> String)
-> RE -> PostCondition String TxFCEKOutput
forall err.
((Maybe Int, [Text]) -> err)
-> RE -> PostCondition err TxFCEKOutput
attackCaseRegexPostCondition (Maybe Int, [Text]) -> String
errorPrinter RE
expectedFailureRE]

--------------------------------------------------------------------------------
-- Helpers

-- | Turn a scripts arguments into the appropriate list-of-data representation
mkDataArgs :: (Maybe Datum, Redeemer, ScriptContext) -> [PLC.Data]
mkDataArgs :: (Maybe Datum, Redeemer, ScriptContext) -> [Data]
mkDataArgs (Maybe Datum
Nothing, Redeemer
redeemer, ScriptContext
ctx) = [Redeemer -> Data
forall a. ToData a => a -> Data
toData Redeemer
redeemer, ScriptContext -> Data
forall a. ToData a => a -> Data
toData ScriptContext
ctx]
mkDataArgs (Just Datum
datum, Redeemer
redeemer, ScriptContext
ctx) = [Datum -> Data
forall a. ToData a => a -> Data
toData Datum
datum, Redeemer -> Data
forall a. ToData a => a -> Data
toData Redeemer
redeemer, ScriptContext -> Data
forall a. ToData a => a -> Data
toData ScriptContext
ctx]