{-# 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.Allegra.Scripts (Timelock)
import Cardano.Ledger.Alonzo.Core
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.Map as Map
import qualified Data.Maybe as Maybe (mapMaybe)
import Test.Cardano.Ledger.Alonzo.Arbitrary
import Test.Cardano.Ledger.Common

spec ::
  forall era.
  ( AlonzoEraScript era
  , Script era ~ AlonzoScript era
  , NativeScript era ~ Timelock era
  ) =>
  Spec
spec :: forall era.
(AlonzoEraScript era, Script era ~ AlonzoScript era,
 NativeScript era ~ Timelock era) =>
Spec
spec = do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AlonzoTxWits deserialization" forall a b. (a -> b) -> a -> b
$ do
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"plutus scripts" forall a b. (a -> b) -> a -> b
$ do
      forall era. AlonzoEraScript era => Spec
emptyFieldsProps @era
      forall era.
(AlonzoEraScript era, Script era ~ AlonzoScript era) =>
Spec
plutusScriptsProp @era
      forall era.
(AlonzoEraScript era, Script era ~ AlonzoScript era,
 NativeScript era ~ Timelock era) =>
Spec
nativeScriptsProp @era

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

plutusScriptsProp ::
  forall era.
  ( AlonzoEraScript era
  , Script era ~ AlonzoScript era
  ) =>
  Spec
plutusScriptsProp :: forall era.
(AlonzoEraScript era, Script era ~ AlonzoScript era) =>
Spec
plutusScriptsProp = do
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"fails to deserialize if empty or if it contains duplicates, starting with Conway" forall a b. (a -> b) -> a -> b
$
    forall prop. Testable prop => [prop] -> Property
conjoin forall a b. (a -> b) -> a -> b
$
      [ Language -> Property
distinctProp
      , Language -> Property
duplicateProp
      ]
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [forall a. Bounded a => a
minBound .. forall era. AlonzoEraScript era => Language
eraMaxLanguage @era]
  where
    distinctProp :: Language -> Property
distinctProp Language
lang =
      forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow (Language -> Bool -> Gen Encoding
genEncoding Language
lang Bool
False) (forall era. Era era => Encoding -> String
showEnc @era) forall a b. (a -> b) -> a -> b
$
        forall era.
(AlonzoEraScript era, HasCallStack) =>
Encoding -> IO ()
expectDeserialiseSuccess @era

    duplicateProp :: Language -> Property
duplicateProp Language
lang =
      forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow (Language -> Bool -> Gen Encoding
genEncoding Language
lang Bool
True) (forall era. Era era => Encoding -> String
showEnc @era) forall a b. (a -> b) -> a -> b
$
        \Encoding
enc ->
          forall era.
(AlonzoEraScript 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 :: Language -> Bool -> Gen Encoding
    genEncoding :: Language -> Bool -> Gen Encoding
genEncoding Language
lang Bool
duplicate = do
      AlonzoScript era
sc <- forall era.
(AlonzoEraScript era, Script era ~ AlonzoScript era) =>
Language -> Gen (AlonzoScript era)
genPlutusScript @era Language
lang
      let scs :: [AlonzoScript era]
scs
            | Bool
duplicate = [AlonzoScript era
sc, AlonzoScript era
sc]
            | Bool
otherwise = [AlonzoScript era
sc]
      let plutusBins :: [PlutusBinary]
plutusBins = forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
            forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe
              (\AlonzoScript era
x -> forall (l :: Language). Plutus l -> PlutusBinary
plutusBinary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall era.
AlonzoEraScript era =>
Script era -> Maybe (PlutusScript era)
toPlutusScript AlonzoScript era
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (l :: Language) era.
(PlutusLanguage l, AlonzoEraScript era) =>
SLanguage l -> PlutusScript era -> Maybe (Plutus l)
toPlutusSLanguage SLanguage l
slang))
              [AlonzoScript era]
scs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => a -> Encoding
encCBOR forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (Language -> Int
keys Language
lang) (forall a. EncCBOR a => a -> Encoding
encCBOR [PlutusBinary]
plutusBins)
    keys :: Language -> Int
keys Language
PlutusV1 = Int
3 :: Int
    keys Language
PlutusV2 = Int
6
    keys Language
PlutusV3 = Int
7

nativeScriptsProp ::
  forall era.
  ( AlonzoEraScript era
  , Script era ~ AlonzoScript era
  , NativeScript era ~ Timelock era
  ) =>
  Spec
nativeScriptsProp :: forall era.
(AlonzoEraScript era, Script era ~ AlonzoScript era,
 NativeScript era ~ Timelock era) =>
Spec
nativeScriptsProp = do
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop
    String
"fails to deserialize if empty, starting with Conway"
    Property
distinctProp
  where
    distinctProp :: Property
distinctProp =
      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) forall a b. (a -> b) -> a -> b
$
        forall era.
(AlonzoEraScript 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
      AlonzoScript era
sc <- forall era.
(AlonzoEraScript era, NativeScript era ~ Timelock era) =>
Gen (AlonzoScript era)
genNativeScript @era
      let scs :: [AlonzoScript era]
scs
            | Bool
duplicate = [AlonzoScript era
sc, AlonzoScript era
sc]
            | Bool
otherwise = [AlonzoScript era
sc]

      let natives :: [Timelock era]
natives = forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe forall era. EraScript era => Script era -> Maybe (NativeScript era)
getNativeScript [AlonzoScript era]
scs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => a -> Encoding
encCBOR forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (Int
1 :: Int) (forall a. EncCBOR a => a -> Encoding
encCBOR [Timelock era]
natives)

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

expectDeserialiseFailureFromVersion ::
  forall era.
  (AlonzoEraScript era, HasCallStack) =>
  Version ->
  Encoding ->
  String ->
  IO ()
expectDeserialiseFailureFromVersion :: forall era.
(AlonzoEraScript era, HasCallStack) =>
Version -> Encoding -> String -> IO ()
expectDeserialiseFailureFromVersion Version
v Encoding
enc String
errMsgPrefix =
  forall era.
AlonzoEraScript era =>
Encoding
-> (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ())
-> IO ()
encodeAndCheckDecoded @era Encoding
enc forall a b. (a -> b) -> a -> b
$
    \Either DecoderError (Annotator (AlonzoTxWits era))
decoded -> do
      if forall era. Era era => Version
eraProtVerHigh @era forall a. Ord a => a -> a -> Bool
< Version
v
        then forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight Either DecoderError (Annotator (AlonzoTxWits era))
decoded
        else forall t.
(HasCallStack, Show t) =>
Either DecoderError t -> String -> IO ()
expectDeserialiseFailure (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 <- forall b a. (HasCallStack, Show b) => Either a b -> IO a
expectLeft Either DecoderError t
e
  DecoderError
res forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \case
    DecoderErrorDeserialiseFailure Text
_ (DeserialiseFailure ByteOffset
_ String
errMsg) ->
      String
errMsgPrefix forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
errMsg
    DecoderError
_ -> Bool
False

encodeAndCheckDecoded ::
  forall era.
  AlonzoEraScript era =>
  Encoding ->
  (Either DecoderError (Annotator (AlonzoTxWits era)) -> IO ()) ->
  IO ()
encodeAndCheckDecoded :: forall era.
AlonzoEraScript 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 = 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 = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Version -> Encoding -> Encoding
toPlainEncoding (forall era. Era era => Version
eraProtVerHigh @era) Encoding
enc