{-# 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 <- forall a. NonEmptyList a -> [a]
getNonEmpty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  (Int
a, Int
_) <- forall a. HasCallStack => [a] -> Gen a
elements [(Int, Int)]
xs -- pick a key to duplicate
  Int
c <- forall a. Arbitrary a => Gen a
arbitrary -- pick a value for duplicate key
  forall a. [a] -> Gen [a]
shuffle ((Int
a, Int
c) 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int
a, Int
b] | (Int
a, Int
b) <- [(Int, Int)]
xs]
  forall a. HasCallStack => [Gen a] -> Gen a
oneof
    [ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word -> Encoding
encodeMapLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [(Int, Int)]
xs) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. EncCBOR a => a -> Encoding
encCBOR [Int]
flatXs
    , forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Encoding
encodeMapLenIndef forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. EncCBOR a => a -> Encoding
encCBOR [Int]
flatXs 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 <- forall a. NonEmptyList a -> [a]
getNonEmpty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
  Int
a <- forall a. HasCallStack => [a] -> Gen a
elements [Int]
xs -- pick an element to duplicate
  forall a. [a] -> Gen [a]
shuffle (Int
a 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Int]
xs) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. EncCBOR a => a -> Encoding
encCBOR [Int]
xs
      indefinite :: Encoding
indefinite = Encoding
encodeListLenIndef forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. EncCBOR a => a -> Encoding
encCBOR [Int]
xs forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak
  forall a. HasCallStack => [a] -> Gen a
elements
    [ Encoding
definite
    , Word -> Encoding
encodeTag Word
258 forall a. Semigroup a => a -> a -> a
<> Encoding
definite
    , Encoding
indefinite
    , Word -> Encoding
encodeTag Word
258 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 =
  forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen Encoding
genDuplicateAssocListEncoding forall a b. (a -> b) -> a -> b
$
    \Encoding
mapEncoding ->
      let trip :: Trip Encoding (Map Int Int)
trip = forall a b.
(a -> Encoding)
-> (forall s. Decoder s b) -> (forall s. Decoder s ()) -> Trip a b
Trip forall a. a -> a
id (forall a s. DecCBOR a => Decoder s a
decCBOR @(Map Int Int)) (forall a s. DecCBOR a => Proxy a -> Decoder s ()
dropCBOR (forall {k} (t :: k). Proxy t
Proxy @(Map Int Int)))
       in forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ 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) 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 =
  forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen Encoding
genDuplicateListEncoding forall a b. (a -> b) -> a -> b
$
    \Encoding
setEncoding ->
      let trip :: Trip Encoding (Set Int)
trip = forall a b.
(a -> Encoding)
-> (forall s. Decoder s b) -> (forall s. Decoder s ()) -> Trip a b
Trip forall a. a -> a
id (forall a s. DecCBOR a => Decoder s a
decCBOR @(Set Int)) (forall a s. DecCBOR a => Proxy a -> Decoder s ()
dropCBOR (forall {k} (t :: k). Proxy t
Proxy @(Set Int)))
       in forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ 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) forall a. Bounded a => a
maxBound Encoding
setEncoding

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