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

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

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary.Decoding
import Cardano.Ledger.Binary.Encoding
import Cardano.Ledger.Plutus.CostModels
import Cardano.Ledger.Plutus.Language
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Word (Word8)
import Lens.Micro
import Test.Cardano.Ledger.Alonzo.Arbitrary (genEraLanguage)
import Test.Cardano.Ledger.Common

spec :: forall era. (AlonzoEraPParams era, AlonzoEraScript era) => Spec
spec :: forall era. (AlonzoEraPParams era, AlonzoEraScript era) => Spec
spec = do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CBOR deserialization" forall a b. (a -> b) -> a -> b
$ do
    forall era. (AlonzoEraPParams era, AlonzoEraScript era) => Spec
validCostModelProp @era
    forall era. AlonzoEraPParams era => Spec
underspecifiedCostModelProp @era
    forall era. AlonzoEraPParams era => Spec
unknownCostModelProp @era
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"applyPPUpdates" forall a b. (a -> b) -> a -> b
$ \CostModels
valid CostModels
validUpdate Map Word8 [Int64]
unknown Map Word8 [Int64]
unknownUpdate -> do
    CostModels
original <- forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient (CostModels -> Map Word8 [Int64]
flattenCostModels CostModels
valid forall a. Semigroup a => a -> a -> a
<> Map Word8 [Int64]
unknown)
    CostModels
originalUpdate <- forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient (CostModels -> Map Word8 [Int64]
flattenCostModels CostModels
validUpdate forall a. Semigroup a => a -> a -> a
<> Map Word8 [Int64]
unknownUpdate)
    let
      pp :: PParams era
pp = forall era. EraPParams era => PParams era
emptyPParams forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels
original
      ppUpdate :: PParamsUpdate era
ppUpdate = forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust CostModels
originalUpdate
      updated :: PParams era
updated = forall era.
EraPParams era =>
PParams era -> PParamsUpdate era -> PParams era
applyPPUpdates @era PParams era
pp PParamsUpdate era
ppUpdate
    -- Starting with Conway we update CostModel on per-language basis, while before
    -- that CostModels where overwritten completely
    if forall era. Era era => Version
eraProtVerLow @era forall a. Ord a => a -> a -> Bool
>= forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9
      then do
        CostModels
expected <- forall (m :: * -> *).
MonadFail m =>
Map Word8 [Int64] -> m CostModels
mkCostModelsLenient (CostModels -> Map Word8 [Int64]
flattenCostModels CostModels
originalUpdate forall a. Semigroup a => a -> a -> a
<> CostModels -> Map Word8 [Int64]
flattenCostModels CostModels
original)
        PParams era
updated forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (PParams era
pp forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels
expected)
      else PParams era
updated forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (PParams era
pp forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels
originalUpdate)

validCostModelProp ::
  forall era.
  (AlonzoEraPParams era, AlonzoEraScript era) =>
  Spec
validCostModelProp :: forall era. (AlonzoEraPParams era, AlonzoEraScript era) => Spec
validCostModelProp = do
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"valid CostModels deserialize correctly, both independently and within PParamsUpdate" forall a b. (a -> b) -> a -> b
$
    forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall era. AlonzoEraScript era => Gen Language
genEraLanguage @era) forall a b. (a -> b) -> a -> b
$ \(Language
lang :: Language) -> do
      forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow (Language -> Gen Encoding
genValidCostModelEnc Language
lang) (forall era. Era era => Encoding -> String
showEnc @era) forall a b. (a -> b) -> a -> b
$
        \Encoding
validCmEnc -> do
          forall era.
AlonzoEraPParams era =>
Encoding
-> (Either DecoderError CostModels
    -> Either DecoderError (PParamsUpdate era) -> IO ())
-> IO ()
encodeAndCheckDecoded @era Encoding
validCmEnc forall a b. (a -> b) -> a -> b
$
            \Either DecoderError CostModels
cmDecoded Either DecoderError (PParamsUpdate era)
ppuDecoded -> do
              forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight Either DecoderError CostModels
cmDecoded forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` CostModels -> Bool
validCm)
              PParamsUpdate era
ppuRes <- forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight Either DecoderError (PParamsUpdate era)
ppuDecoded
              PParamsUpdate era
ppuRes forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \PParamsUpdate era
ppu -> (CostModels -> Bool
validCm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PParamsUpdate era
ppu forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL) forall a. Eq a => a -> a -> Bool
== forall a. a -> StrictMaybe a
SJust Bool
True
  where
    genValidCostModelEnc :: Language -> Gen Encoding
genValidCostModelEnc Language
lang = Language -> Int -> Gen Encoding
genCostModelEncForLanguage Language
lang (Language -> Int
costModelParamsCount Language
lang)
    validCm :: CostModels -> Bool
validCm CostModels
cms =
      Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CostModels -> Map Language CostModel
costModelsValid CostModels
cms)) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CostModels -> Map Word8 [Int64]
costModelsUnknown CostModels
cms)

-- | Underspecified is a CostModel that has less than the normal number of parameters
underspecifiedCostModelProp ::
  forall era.
  AlonzoEraPParams era =>
  Spec
underspecifiedCostModelProp :: forall era. AlonzoEraPParams era => Spec
underspecifiedCostModelProp = do
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"CostModels with less than expected parameters within PParamsUpdate" forall a b. (a -> b) -> a -> b
$
    \(Language
lang :: Language) -> do
      forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow (Language -> Gen Encoding
genUnderspecifiedCostModelEnc Language
lang) (forall era. Era era => Encoding -> String
showEnc @era) forall a b. (a -> b) -> a -> b
$
        \Encoding
shortCmEnc -> do
          forall era.
AlonzoEraPParams era =>
Encoding
-> (Either DecoderError CostModels
    -> Either DecoderError (PParamsUpdate era) -> IO ())
-> IO ()
encodeAndCheckDecoded @era Encoding
shortCmEnc forall a b. (a -> b) -> a -> b
$
            \Either DecoderError CostModels
cmDecoded Either DecoderError (PParamsUpdate era)
ppuDecoded -> do
              -- pre-Conway we are failing when deserializing underspecified costmodels
              if forall era. Era era => Version
eraProtVerHigh @era forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9
                then do
                  forall t.
(HasCallStack, Show t) =>
Either DecoderError t -> Maybe Text -> IO ()
expectDeserialiseFailure Either DecoderError CostModels
cmDecoded (forall a. a -> Maybe a
Just Text
"CostModels")
                  forall t.
(HasCallStack, Show t) =>
Either DecoderError t -> Maybe Text -> IO ()
expectDeserialiseFailure Either DecoderError (PParamsUpdate era)
ppuDecoded forall a. Maybe a
Nothing
                else do
                  -- post-Conway, we are retaining CostModels that specified less parameters than expected
                  CostModels
cmRes <- forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight Either DecoderError CostModels
cmDecoded
                  CostModels
cmRes forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModels -> Map Language CostModel
costModelsValid
  where
    genUnderspecifiedCostModelEnc :: Language -> Gen Encoding
genUnderspecifiedCostModelEnc Language
lang = do
      let validCount :: Int
validCount = Language -> Int
costModelParamsCount Language
lang
      Int
count <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
validCount forall a. Num a => a -> a -> a
- Int
1)
      Language -> Int -> Gen Encoding
genCostModelEncForLanguage Language
lang Int
count

unknownCostModelProp ::
  forall era.
  AlonzoEraPParams era =>
  Spec
unknownCostModelProp :: forall era. AlonzoEraPParams era => Spec
unknownCostModelProp = do
  forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"unknown CostModels deserialize correctly within PParamsUpdate starting with Conway" forall a b. (a -> b) -> a -> b
$
    forall prop a.
Testable prop =>
Gen a -> (a -> String) -> (a -> prop) -> Property
forAllShow Gen Encoding
genUnknownCostModelEnc (forall era. Era era => Encoding -> String
showEnc @era) forall a b. (a -> b) -> a -> b
$
      \Encoding
unknownCmEnc -> do
        forall era.
AlonzoEraPParams era =>
Encoding
-> (Either DecoderError CostModels
    -> Either DecoderError (PParamsUpdate era) -> IO ())
-> IO ()
encodeAndCheckDecoded @era Encoding
unknownCmEnc forall a b. (a -> b) -> a -> b
$
          \Either DecoderError CostModels
cmDecoded Either DecoderError (PParamsUpdate era)
ppuDecoded -> do
            -- pre-Conway we are failing when deserializing unknown costmodels
            if forall era. Era era => Version
eraProtVerHigh @era forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9
              then do
                forall t.
(HasCallStack, Show t) =>
Either DecoderError t -> Maybe Text -> IO ()
expectDeserialiseFailure Either DecoderError CostModels
cmDecoded (forall a. a -> Maybe a
Just Text
"CostModels")
                forall t.
(HasCallStack, Show t) =>
Either DecoderError t -> Maybe Text -> IO ()
expectDeserialiseFailure Either DecoderError (PParamsUpdate era)
ppuDecoded forall a. Maybe a
Nothing
              else do
                -- post-Conway, we are collecting unknown CostModels
                CostModels
cmRes <- forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight Either DecoderError CostModels
cmDecoded
                CostModels
cmRes forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` CostModels -> Bool
unknownCm
                PParamsUpdate era
ppuRes <- forall a b. (HasCallStack, Show a) => Either a b -> IO b
expectRight Either DecoderError (PParamsUpdate era)
ppuDecoded
                PParamsUpdate era
ppuRes forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` \PParamsUpdate era
ppu -> (CostModels -> Bool
unknownCm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PParamsUpdate era
ppu forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL) forall a. Eq a => a -> a -> Bool
== forall a. a -> StrictMaybe a
SJust Bool
True
  where
    genUnknownCostModelEnc :: Gen Encoding
genUnknownCostModelEnc = do
      let firstUnknownLang :: Int
firstUnknownLang = forall a. Enum a => a -> Int
fromEnum (forall a. Bounded a => a
maxBound @Language) forall a. Num a => a -> a -> a
+ Int
1
      Word8
lang <- forall a. Random a => (a, a) -> Gen a
choose (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
firstUnknownLang, forall a. Bounded a => a
maxBound @Word8)
      NonNegative Int
count <- forall a. Arbitrary a => Gen a
arbitrary
      Word8 -> Int -> Gen Encoding
genCostModelsEnc Word8
lang Int
count
    unknownCm :: CostModels -> Bool
unknownCm CostModels
cms =
      forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CostModels -> Map Language CostModel
costModelsValid CostModels
cms) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CostModels -> Map Word8 [Int64]
costModelsUnknown CostModels
cms))

encodeAndCheckDecoded ::
  forall era.
  AlonzoEraPParams era =>
  Encoding ->
  (Either DecoderError CostModels -> Either DecoderError (PParamsUpdate era) -> IO ()) ->
  IO ()
encodeAndCheckDecoded :: forall era.
AlonzoEraPParams era =>
Encoding
-> (Either DecoderError CostModels
    -> Either DecoderError (PParamsUpdate era) -> IO ())
-> IO ()
encodeAndCheckDecoded Encoding
cmEnc Either DecoderError CostModels
-> Either DecoderError (PParamsUpdate era) -> IO ()
check = do
  let ver :: Version
ver = forall era. Era era => Version
eraProtVerHigh @era
      ppuEnc :: Encoding
ppuEnc = forall a. EncCBOR a => a -> Encoding
encCBOR (forall k a. k -> a -> Map k a
Map.singleton (Int
18 :: Int) Encoding
cmEnc)
      cmBytes :: ByteString
cmBytes = forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
ver Encoding
cmEnc
      ppuBytes :: ByteString
ppuBytes = forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
ver Encoding
ppuEnc
  Either DecoderError CostModels
-> Either DecoderError (PParamsUpdate era) -> IO ()
check
    (forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull @CostModels Version
ver ByteString
cmBytes)
    (forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull @(PParamsUpdate era) Version
ver ByteString
ppuBytes)

genCostModelsEnc :: Word8 -> Int -> Gen Encoding
genCostModelsEnc :: Word8 -> Int -> Gen Encoding
genCostModelsEnc Word8
lang Int
count = do
  [Int]
values <- forall a. Int -> Gen a -> Gen [a]
vectorOf Int
count (forall a. Arbitrary a => Gen a
arbitrary :: Gen Int)
  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 Word8
lang [Int]
values

genCostModelEncForLanguage :: Language -> Int -> Gen Encoding
genCostModelEncForLanguage :: Language -> Int -> Gen Encoding
genCostModelEncForLanguage = Word8 -> Int -> Gen Encoding
genCostModelsEnc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum

expectDeserialiseFailure :: (HasCallStack, Show t) => Either DecoderError t -> Maybe Text -> IO ()
expectDeserialiseFailure :: forall t.
(HasCallStack, Show t) =>
Either DecoderError t -> Maybe Text -> IO ()
expectDeserialiseFailure Either DecoderError t
e Maybe Text
expectedTxt = 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
txt DeserialiseFailure
_ -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== Text
txt) Maybe Text
expectedTxt
    DecoderError
_ -> Bool
False

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