{-# 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
  [(Int, Int)]
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
  (Int
a, Int
_) <- [(Int, Int)] -> Gen (Int, Int)
forall a. HasCallStack => [a] -> Gen a
elements [(Int, Int)]
xs -- pick a key to duplicate
  Int
c <- Gen Int
forall a. Arbitrary a => Gen a
arbitrary -- pick a value for duplicate key
  [(Int, Int)] -> Gen [(Int, Int)]
forall a. [a] -> Gen [a]
shuffle ((Int
a, Int
c) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
: [(Int, Int)]
xs)

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

-- | Generate a list with at least one duplicate
genDuplicateList :: Gen [Int]
genDuplicateList :: Gen [Int]
genDuplicateList = do
  [Int]
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
  Int
a <- [Int] -> Gen Int
forall a. HasCallStack => [a] -> Gen a
elements [Int]
xs -- pick an element to duplicate
  [Int] -> Gen [Int]
forall a. [a] -> Gen [a]
shuffle (Int
a Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
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
  [Int]
xs <- Gen [Int]
genDuplicateList
  let definite :: Encoding
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
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
  [Encoding] -> Gen Encoding
forall a. HasCallStack => [a] -> Gen a
elements
    [ Encoding
definite
    , Word -> Encoding
encodeTag Word
258 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
definite
    , Encoding
indefinite
    , Word -> Encoding
encodeTag Word
258 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
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