-- editorconfig-checker-disable-file
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Evaluation.Regressions
  ( schnorrVerifyRegressions
  ) where

import Data.Bits (zeroBits)
import Data.ByteString (ByteString)
import Data.List.Split (chunksOf)
import Evaluation.Builtins.Common (typecheckEvaluateCek)
import GHC.Exts (fromListN)
import PlutusCore
  ( DefaultFun (VerifySchnorrSecp256k1Signature)
  , EvaluationResult (EvaluationFailure)
  )
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModelForTesting)
import PlutusCore.MkPlc (builtin, mkConstant, mkIterAppNoAnn)
import PlutusPrelude
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertEqual, assertFailure, testCase)
import Text.Read (readMaybe)

schnorrVerifyRegressions :: TestTree
schnorrVerifyRegressions :: TestTree
schnorrVerifyRegressions =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"Schnorr signature verification regressions"
    [ [Char] -> Assertion -> TestTree
testCase [Char]
"malformed verkey should fail" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        let badVerKey :: ByteString
badVerKey = ByteString
"m"
        let message :: ByteString
message = ByteString
"\213"
        let comp :: Term TyName Name DefaultUni DefaultFun ()
comp =
              Term TyName Name DefaultUni DefaultFun ()
-> [Term TyName Name DefaultUni DefaultFun ()]
-> Term TyName Name DefaultUni DefaultFun ()
forall (term :: * -> *) tyname name (uni :: * -> *) fun.
TermLike term tyname name uni fun =>
term () -> [term ()] -> term ()
mkIterAppNoAnn
                (() -> DefaultFun -> Term TyName Name DefaultUni DefaultFun ()
forall ann.
ann -> DefaultFun -> Term TyName Name DefaultUni DefaultFun ann
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> fun -> term ann
builtin () DefaultFun
VerifySchnorrSecp256k1Signature)
                [ forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
mkConstant @ByteString () ByteString
badVerKey
                , forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
mkConstant @ByteString () ByteString
message
                , forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
mkConstant @ByteString () ByteString
signature
                ]
        let result :: Either
  (TypeErrorPlc DefaultUni DefaultFun ())
  (EvaluationResult (Term Name DefaultUni DefaultFun ()), [Text])
result = BuiltinSemanticsVariant DefaultFun
-> CostingPart DefaultUni DefaultFun
-> Term TyName Name DefaultUni DefaultFun ()
-> Either
     (TypeErrorPlc DefaultUni DefaultFun ())
     (EvaluationResult (Term Name DefaultUni DefaultFun ()), [Text])
forall (uni :: * -> *) fun (m :: * -> *).
(MonadError (TypeErrorPlc uni fun ()) m, Typecheckable uni fun,
 GEq uni, Everywhere uni ExMemoryUsage, PrettyUni uni, Pretty fun,
 CaseBuiltin uni) =>
BuiltinSemanticsVariant fun
-> CostingPart uni fun
-> Term TyName Name uni fun ()
-> m (EvaluationResult (Term Name uni fun ()), [Text])
typecheckEvaluateCek BuiltinSemanticsVariant DefaultFun
forall a. Default a => a
def BuiltinCostModel
CostingPart DefaultUni DefaultFun
defaultBuiltinCostModelForTesting Term TyName Name DefaultUni DefaultFun ()
comp
        case Either
  (TypeErrorPlc DefaultUni DefaultFun ())
  (EvaluationResult (Term Name DefaultUni DefaultFun ()), [Text])
result of
          Left TypeErrorPlc DefaultUni DefaultFun ()
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"Failed to type check unexpectedly"
          Right (EvaluationResult (Term Name DefaultUni DefaultFun ())
res, [Text]
_) -> [Char]
-> EvaluationResult (Term Name DefaultUni DefaultFun ())
-> EvaluationResult (Term Name DefaultUni DefaultFun ())
-> Assertion
forall a.
(Eq a, Show a, HasCallStack) =>
[Char] -> a -> a -> Assertion
assertEqual [Char]
"" EvaluationResult (Term Name DefaultUni DefaultFun ())
forall a. EvaluationResult a
EvaluationFailure EvaluationResult (Term Name DefaultUni DefaultFun ())
res
    ]

-- The original reproducing case is a hex string
-- Unfortunately, ByteString literals are a weird pseudo-ASCII thing
-- Thus, this manual reconstruction
signature :: ByteString
signature :: ByteString
signature = Int -> [Item ByteString] -> ByteString
forall l. IsList l => Int -> [Item l] -> l
fromListN Int
64 ([Word8] -> ByteString)
-> ([Char] -> [Word8]) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Word8) -> [[Char]] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Word8
go ([[Char]] -> [Word8]) -> ([Char] -> [[Char]]) -> [Char] -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [[Char]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
2 ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"4d83cfb975c5f8b9ba656edb205466bf2c5548f01fc3277427d4ff555df4a996383e171127e82e56fd9bfd0e22df12a004fdac73c67793d97199cc5b223dbe84"
  where
    go :: [Char] -> Word8
    go :: [Char] -> Word8
go = Word8 -> Maybe Word8 -> Word8
forall a. a -> Maybe a -> a
fromMaybe Word8
forall a. Bits a => a
zeroBits (Maybe Word8 -> Word8)
-> ([Char] -> Maybe Word8) -> [Char] -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Word8
forall a. Read a => [Char] -> Maybe a
readMaybe