{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec (spec) where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Context
import Cardano.Ledger.Alonzo.Scripts
import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DeserialiseFailure (..))
import Cardano.Ledger.Binary.Decoding
import Cardano.Ledger.Binary.Encoding
import Cardano.Ledger.Plutus.Language
import Data.List (isPrefixOf)
import qualified Data.List.NonEmpty as NE (toList)
import qualified Data.Map as Map
import Test.Cardano.Ledger.Alonzo.Arbitrary
import Test.Cardano.Ledger.Alonzo.Binary.Annotator ()
import Test.Cardano.Ledger.Common

spec ::
  forall era.
  ( EraPlutusContext era
  , Arbitrary (NativeScript era)
  , DecCBOR (Annotator (NativeScript era))
  ) =>
  Spec
spec :: forall era.
(EraPlutusContext era, Arbitrary (NativeScript era),
 DecCBOR (Annotator (NativeScript era))) =>
Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AlonzoTxWits deserialization" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"plutus scripts" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era))) =>
Spec
emptyFieldsProps @era
      forall era.
(EraPlutusContext era, DecCBOR (Annotator (NativeScript era))) =>
Spec
plutusScriptsProp @era
      forall era.
(AlonzoEraScript era, Arbitrary (NativeScript era),
 DecCBOR (Annotator (NativeScript era))) =>
Spec
nativeScriptsProp @era

emptyFieldsProps ::
  forall era.
  (AlonzoEraScript era, DecCBOR (Annotator (NativeScript era))) =>
  Spec
emptyFieldsProps :: forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era))) =>
Spec
emptyFieldsProps = do
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"fails to deserialize if fields contain an empty collection" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
      Int -> Property
emptyFieldProp (Int -> Property) -> [Int] -> [Property]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 .. Int
7]
  where
    emptyFieldProp :: Int -> Property
    emptyFieldProp :: Int -> Property
emptyFieldProp Int
k =
      IO () -> Property
forall prop. Testable prop => prop -> Property
property (IO () -> Property) -> IO () -> Property
forall a b. (a -> b) -> a -> b
$
        forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era)),
 HasCallStack) =>
Version -> Encoding -> String -> IO ()
expectDeserialiseFailureFromVersion @era
          (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
          (Int -> Encoding
forall {k}. (Ord k, EncCBOR k) => k -> Encoding
emptyEnc Int
k)
          String
"Empty list"
    emptyEnc :: k -> Encoding
emptyEnc k
k = Map k Encoding -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Map k Encoding -> Encoding) -> Map k Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ k -> Encoding -> Map k Encoding
forall k a. k -> a -> Map k a
Map.singleton k
k ([Encoding] -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ([] :: [Encoding]))

plutusScriptsProp ::
  forall era.
  ( EraPlutusContext era
  , DecCBOR (Annotator (NativeScript era))
  ) =>
  Spec
plutusScriptsProp :: forall era.
(EraPlutusContext era, DecCBOR (Annotator (NativeScript era))) =>
Spec
plutusScriptsProp = do
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"fails to deserialize if empty or if it contains duplicates, starting with Conway" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
      [ SupportedLanguage era -> Property
distinctProp
      , SupportedLanguage era -> Property
duplicateProp
      ]
        [SupportedLanguage era -> Property]
-> [SupportedLanguage era] -> [Property]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NonEmpty (SupportedLanguage era) -> [SupportedLanguage era]
forall a. NonEmpty a -> [a]
NE.toList (forall era.
(HasCallStack, EraPlutusContext era) =>
NonEmpty (SupportedLanguage era)
supportedLanguages @era)
  where
    distinctProp :: SupportedLanguage era -> Property
distinctProp SupportedLanguage era
lang =
      Gen Encoding
-> (Encoding -> String) -> (Encoding -> IO ()) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow (SupportedLanguage era -> Bool -> Gen Encoding
genEncoding SupportedLanguage era
lang Bool
False) (forall era. Era era => Encoding -> String
showEnc @era) ((Encoding -> IO ()) -> Property)
-> (Encoding -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$
        forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era)),
 HasCallStack) =>
Encoding -> IO ()
expectDeserialiseSuccess @era

    duplicateProp :: SupportedLanguage era -> Property
duplicateProp SupportedLanguage era
lang =
      Gen Encoding
-> (Encoding -> String) -> (Encoding -> IO ()) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow (SupportedLanguage era -> Bool -> Gen Encoding
genEncoding SupportedLanguage era
lang Bool
True) (forall era. Era era => Encoding -> String
showEnc @era) ((Encoding -> IO ()) -> Property)
-> (Encoding -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$
        \Encoding
enc ->
          forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era)),
 HasCallStack) =>
Version -> Encoding -> String -> IO ()
expectDeserialiseFailureFromVersion @era
            (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
            Encoding
enc
            String
"Final number of elements"

    genEncoding :: SupportedLanguage era -> Bool -> Gen Encoding
    genEncoding :: SupportedLanguage era -> Bool -> Gen Encoding
genEncoding supportedLanguage :: SupportedLanguage era
supportedLanguage@(SupportedLanguage SLanguage l
slang) Bool
duplicate = do
      PlutusScript era
plutusScript <- SupportedLanguage era -> Gen (PlutusScript era)
forall era. SupportedLanguage era -> Gen (PlutusScript era)
genPlutusScript SupportedLanguage era
supportedLanguage
      let plutusScripts :: [PlutusScript era]
plutusScripts
            | Bool
duplicate = [PlutusScript era
plutusScript, PlutusScript era
plutusScript]
            | Bool
otherwise = [PlutusScript era
plutusScript]
      Encoding -> Gen Encoding
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Encoding -> Gen Encoding) -> Encoding -> Gen Encoding
forall a b. (a -> b) -> a -> b
$ Map Int Encoding -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Map Int Encoding -> Encoding) -> Map Int Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ Int -> Encoding -> Map Int Encoding
forall k a. k -> a -> Map k a
Map.singleton (SLanguage l -> Int
forall (l :: Language). SLanguage l -> Int
keys SLanguage l
slang) ([PlutusBinary] -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (PlutusScript era -> PlutusBinary
forall era. AlonzoEraScript era => PlutusScript era -> PlutusBinary
plutusScriptBinary (PlutusScript era -> PlutusBinary)
-> [PlutusScript era] -> [PlutusBinary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PlutusScript era]
plutusScripts))
    keys :: SLanguage l -> Int
    keys :: forall (l :: Language). SLanguage l -> Int
keys SLanguage l
SPlutusV1 = Int
3
    keys SLanguage l
SPlutusV2 = Int
6
    keys SLanguage l
SPlutusV3 = Int
7

nativeScriptsProp ::
  forall era.
  ( AlonzoEraScript era
  , Arbitrary (NativeScript era)
  , DecCBOR (Annotator (NativeScript era))
  ) =>
  Spec
nativeScriptsProp :: forall era.
(AlonzoEraScript era, Arbitrary (NativeScript era),
 DecCBOR (Annotator (NativeScript era))) =>
Spec
nativeScriptsProp = do
  String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop
    String
"fails to deserialize if empty, starting with Conway"
    Property
distinctProp
  where
    distinctProp :: Property
distinctProp =
      Gen Encoding
-> (Encoding -> String) -> (Encoding -> IO ()) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow (Bool -> Gen Encoding
genEncoding Bool
False) (forall era. Era era => Encoding -> String
showEnc @era) ((Encoding -> IO ()) -> Property)
-> (Encoding -> IO ()) -> Property
forall a b. (a -> b) -> a -> b
$
        forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era)),
 HasCallStack) =>
Encoding -> IO ()
expectDeserialiseSuccess @era

    -- TODO: enable this after we enforce distinct entries for Annotator
    -- duplicateProp =
    --   forAllShow (genEncoding True) (showEnc  @era) $
    --     \enc ->
    --       expectDeserialiseFailureFromVersion @era
    --       (natVersion @9)
    --       enc
    --       "Final number of elements"

    genEncoding :: Bool -> Gen Encoding
    genEncoding :: Bool -> Gen Encoding
genEncoding Bool
duplicate = do
      NativeScript era
nativeScript <- forall era. Arbitrary (NativeScript era) => Gen (NativeScript era)
genNativeScript @era
      let nativeScripts :: [NativeScript era]
nativeScripts
            | Bool
duplicate = [NativeScript era
nativeScript, NativeScript era
nativeScript]
            | Bool
otherwise = [NativeScript era
nativeScript]

      Encoding -> Gen Encoding
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Encoding -> Gen Encoding) -> Encoding -> Gen Encoding
forall a b. (a -> b) -> a -> b
$ Map Int Encoding -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Map Int Encoding -> Encoding) -> Map Int Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ Int -> Encoding -> Map Int Encoding
forall k a. k -> a -> Map k a
Map.singleton (Int
1 :: Int) ([NativeScript era] -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR [NativeScript era]
nativeScripts)

expectDeserialiseSuccess ::
  forall era.
  (AlonzoEraScript era, DecCBOR (Annotator (NativeScript era)), HasCallStack) =>
  Encoding ->
  IO ()
expectDeserialiseSuccess :: forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era)),
 HasCallStack) =>
Encoding -> IO ()
expectDeserialiseSuccess Encoding
enc =
  forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era))) =>
Encoding
-> (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ())
-> IO ()
encodeAndCheckDecoded @era Encoding
enc ((Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ())
 -> IO ())
-> (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
    \Either DecoderError (Annotator (AlonzoTxWits era))
decoded -> IO (Annotator (AlonzoTxWits era)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Annotator (AlonzoTxWits era)) -> IO ())
-> IO (Annotator (AlonzoTxWits era)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Either DecoderError (Annotator (AlonzoTxWits era))
-> IO (Annotator (AlonzoTxWits era))
forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight Either DecoderError (Annotator (AlonzoTxWits era))
decoded

expectDeserialiseFailureFromVersion ::
  forall era.
  (AlonzoEraScript era, DecCBOR (Annotator (NativeScript era)), HasCallStack) =>
  Version ->
  Encoding ->
  String ->
  IO ()
expectDeserialiseFailureFromVersion :: forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era)),
 HasCallStack) =>
Version -> Encoding -> String -> IO ()
expectDeserialiseFailureFromVersion Version
v Encoding
enc String
errMsgPrefix =
  forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era))) =>
Encoding
-> (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ())
-> IO ()
encodeAndCheckDecoded @era Encoding
enc ((Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ())
 -> IO ())
-> (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
    \Either DecoderError (Annotator (AlonzoTxWits era))
decoded -> do
      if forall era. Era era => Version
eraProtVerHigh @era Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
v
        then IO (Annotator (AlonzoTxWits era)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Annotator (AlonzoTxWits era)) -> IO ())
-> IO (Annotator (AlonzoTxWits era)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Either DecoderError (Annotator (AlonzoTxWits era))
-> IO (Annotator (AlonzoTxWits era))
forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight Either DecoderError (Annotator (AlonzoTxWits era))
decoded
        else Either DecoderError () -> String -> IO ()
forall t.
(HasCallStack, Show t) =>
Either DecoderError t -> String -> IO ()
expectDeserialiseFailure (Either DecoderError (Annotator (AlonzoTxWits era))
-> Either DecoderError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Either DecoderError (Annotator (AlonzoTxWits era))
decoded) String
errMsgPrefix

expectDeserialiseFailure ::
  (HasCallStack, Show t) =>
  Either DecoderError t ->
  String ->
  IO ()
expectDeserialiseFailure :: forall t.
(HasCallStack, Show t) =>
Either DecoderError t -> String -> IO ()
expectDeserialiseFailure Either DecoderError t
e String
errMsgPrefix = do
  DecoderError
res <- Either DecoderError t -> IO DecoderError
forall b a. (HasCallStack, Show b) => Either a b -> IO a
expectLeft Either DecoderError t
e
  DecoderError
res DecoderError -> (DecoderError -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
    DecoderErrorDeserialiseFailure Text
_ (DeserialiseFailure ByteOffset
_ String
errMsg) ->
      String
errMsgPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
errMsg
    DecoderError
_ -> Bool
False

encodeAndCheckDecoded ::
  forall era.
  (AlonzoEraScript era, DecCBOR (Annotator (NativeScript era))) =>
  Encoding ->
  (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ()) ->
  IO ()
encodeAndCheckDecoded :: forall era.
(AlonzoEraScript era, DecCBOR (Annotator (NativeScript era))) =>
Encoding
-> (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ())
-> IO ()
encodeAndCheckDecoded Encoding
enc Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ()
check = do
  let ver :: Version
ver = forall era. Era era => Version
eraProtVerHigh @era
      bytes :: ByteString
bytes = Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
ver Encoding
enc
  Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ()
check (forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull @(Annotator (AlonzoTxWits era)) Version
ver ByteString
bytes)

showEnc :: forall era. Era era => Encoding -> String
showEnc :: forall era. Era era => Encoding -> String
showEnc Encoding
enc = Encoding -> String
forall a. Show a => a -> String
show (Encoding -> String) -> Encoding -> String
forall a b. (a -> b) -> a -> b
$ Version -> Encoding -> Encoding
toPlainEncoding (forall era. Era era => Version
eraProtVerHigh @era) Encoding
enc