{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Binary.Failure (spec) where

import Cardano.Ledger.Binary
import Data.Map (Map)
import Data.Proxy (Proxy (Proxy))
import Data.Set (Set)
import Test.Cardano.Ledger.Binary.RoundTrip (Trip (..), embedTripRangeFailureExpectation)
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck

-- | Generate an association list with at least one duplicate key
genDuplicateAssocList :: Gen [(Int, Int)]
genDuplicateAssocList :: Gen [(Int, Int)]
genDuplicateAssocList = do
  xs <- NonEmptyList (Int, Int) -> [(Int, Int)]
forall a. NonEmptyList a -> [a]
getNonEmpty (NonEmptyList (Int, Int) -> [(Int, Int)])
-> Gen (NonEmptyList (Int, Int)) -> Gen [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (NonEmptyList (Int, Int))
forall a. Arbitrary a => Gen a
arbitrary
  (a, _) <- elements xs -- pick a key to duplicate
  c <- arbitrary -- pick a value for duplicate key
  shuffle ((a, c) : xs)

-- | Generate a CBOR encoded association list with at least one duplicate key
genDuplicateAssocListEncoding :: Gen Encoding
genDuplicateAssocListEncoding :: Gen Encoding
genDuplicateAssocListEncoding = do
  xs <- Gen [(Int, Int)]
genDuplicateAssocList
  let flatXs = [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int
a, Int
b] | (Int
a, Int
b) <- [(Int, Int)]
xs]
  oneof
    [ pure $ encodeMapLen (fromIntegral $ Prelude.length xs) <> foldMap encCBOR flatXs
    , pure $ encodeMapLenIndef <> foldMap encCBOR flatXs <> encodeBreak
    ]

-- | Generate a list with at least one duplicate
genDuplicateList :: Gen [Int]
genDuplicateList :: Gen [Int]
genDuplicateList = do
  xs <- NonEmptyList Int -> [Int]
forall a. NonEmptyList a -> [a]
getNonEmpty (NonEmptyList Int -> [Int]) -> Gen (NonEmptyList Int) -> Gen [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (NonEmptyList Int)
forall a. Arbitrary a => Gen a
arbitrary
  a <- elements xs -- pick an element to duplicate
  shuffle (a : xs)

-- | Generate a CBOR encoded list with at least one duplicate, with and with the set tag
genDuplicateListEncoding :: Gen Encoding
genDuplicateListEncoding :: Gen Encoding
genDuplicateListEncoding = do
  xs <- Gen [Int]
genDuplicateList
  let definite = Word -> Encoding
encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Int]
xs) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (Int -> Encoding) -> [Int] -> Encoding
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR [Int]
xs
      indefinite = Encoding
encodeListLenIndef Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (Int -> Encoding) -> [Int] -> Encoding
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR [Int]
xs Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak
  elements
    [ definite
    , encodeTag 258 <> definite
    , indefinite
    , encodeTag 258 <> indefinite
    ]

-- | Starting in version 9, do not accept duplicates in CBOR maps
prop_shouldFailMapWithDupKeys :: Property
prop_shouldFailMapWithDupKeys :: Property
prop_shouldFailMapWithDupKeys =
  Gen Encoding -> (Encoding -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen Encoding
genDuplicateAssocListEncoding ((Encoding -> Property) -> Property)
-> (Encoding -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
    \Encoding
mapEncoding ->
      let trip :: Trip Encoding (Map Int Int)
trip = (Encoding -> Encoding)
-> (forall s. Decoder s (Map Int Int))
-> (forall s. Decoder s ())
-> Trip Encoding (Map Int Int)
forall a b.
(a -> Encoding)
-> (forall s. Decoder s b) -> (forall s. Decoder s ()) -> Trip a b
Trip Encoding -> Encoding
forall a. a -> a
id (forall a s. DecCBOR a => Decoder s a
decCBOR @(Map Int Int)) (Proxy (Map Int Int) -> Decoder s ()
forall s. Proxy (Map Int Int) -> Decoder s ()
forall a s. DecCBOR a => Proxy a -> Decoder s ()
dropCBOR (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Map Int Int)))
       in Expectation -> Property
forall prop. Testable prop => prop -> Property
property (Expectation -> Property) -> Expectation -> Property
forall a b. (a -> b) -> a -> b
$ Trip Encoding (Map Int Int)
-> Version -> Version -> Encoding -> Expectation
forall a b.
(Typeable b, Eq b, HasCallStack) =>
Trip a b -> Version -> Version -> a -> Expectation
embedTripRangeFailureExpectation Trip Encoding (Map Int Int)
trip (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) Version
forall a. Bounded a => a
maxBound Encoding
mapEncoding

-- | Starting in version 9, do not accept duplicates in CBOR sets
prop_shouldFailSetWithDupKeys :: Property
prop_shouldFailSetWithDupKeys :: Property
prop_shouldFailSetWithDupKeys =
  Gen Encoding -> (Encoding -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen Encoding
genDuplicateListEncoding ((Encoding -> Property) -> Property)
-> (Encoding -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
    \Encoding
setEncoding ->
      let trip :: Trip Encoding (Set Int)
trip = (Encoding -> Encoding)
-> (forall s. Decoder s (Set Int))
-> (forall s. Decoder s ())
-> Trip Encoding (Set Int)
forall a b.
(a -> Encoding)
-> (forall s. Decoder s b) -> (forall s. Decoder s ()) -> Trip a b
Trip Encoding -> Encoding
forall a. a -> a
id (forall a s. DecCBOR a => Decoder s a
decCBOR @(Set Int)) (Proxy (Set Int) -> Decoder s ()
forall s. Proxy (Set Int) -> Decoder s ()
forall a s. DecCBOR a => Proxy a -> Decoder s ()
dropCBOR (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Set Int)))
       in Expectation -> Property
forall prop. Testable prop => prop -> Property
property (Expectation -> Property) -> Expectation -> Property
forall a b. (a -> b) -> a -> b
$ Trip Encoding (Set Int)
-> Version -> Version -> Encoding -> Expectation
forall a b.
(Typeable b, Eq b, HasCallStack) =>
Trip a b -> Version -> Version -> a -> Expectation
embedTripRangeFailureExpectation Trip Encoding (Set Int)
trip (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) Version
forall a. Bounded a => a
maxBound Encoding
setEncoding

spec :: Spec
spec :: Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Failures" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"map duplicates are not allowed starting v9" Property
prop_shouldFailMapWithDupKeys
    String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"set duplicates are not allowed starting v9" Property
prop_shouldFailSetWithDupKeys