{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Test.Cardano.Ledger.Binary.Vintage.Failure (tests) where

import Cardano.Ledger.Binary hiding (Range)
import Data.List.NonEmpty (NonEmpty)
import Data.Set (Set)
import GHC.Stack (HasCallStack, withFrozenCallStack)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import Hedgehog.Internal.Property (failWith)
import qualified Hedgehog.Range as Range
import Numeric.Natural (Natural)

{- HLINT ignore "Use record patterns" -}

tests :: IO Bool
tests :: IO Bool
tests = Group -> IO Bool
forall (m :: * -> *). MonadIO m => Group -> m Bool
checkParallel $$(discover)

----------------------------------------------------------------------
-------------------------   Generators   -----------------------------

data VEncoding = VEncoding Version Encoding

mkByronEncoding :: Encoding -> VEncoding
mkByronEncoding :: Encoding -> VEncoding
mkByronEncoding = Version -> Encoding -> VEncoding
VEncoding Version
byronProtVer

instance Show VEncoding where
  show :: VEncoding -> String
show (VEncoding Version
v Encoding
enc) = Encoding -> String
forall a. Show a => a -> String
show (Version -> Encoding -> Encoding
toPlainEncoding Version
v Encoding
enc)

genInvalidNonEmptyCBOR :: Gen VEncoding -- NonEmpty Bool
genInvalidNonEmptyCBOR :: Gen VEncoding
genInvalidNonEmptyCBOR = VEncoding -> Gen VEncoding
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Encoding -> VEncoding
mkByronEncoding ([Bool] -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ([] :: [Bool])))

genInvalidEitherCBOR :: Gen VEncoding -- Either Bool Bool
genInvalidEitherCBOR :: Gen VEncoding
genInvalidEitherCBOR = do
  Bool
b <- GenT Identity Bool
forall (m :: * -> *). MonadGen m => m Bool
Gen.bool
  VEncoding -> Gen VEncoding
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Encoding -> VEncoding
mkByronEncoding (Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
encodeWord Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Bool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Bool
b))

genNegativeInteger :: Gen Integer
genNegativeInteger :: Gen Integer
genNegativeInteger =
  Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> (Word64 -> Integer) -> Word64 -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> GenT Identity Word64 -> Gen Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Word64 -> GenT Identity Word64
forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (Word64 -> Word64 -> Range Word64
forall a. Integral a => a -> a -> Range a
Range.exponential Word64
1 Word64
forall a. Bounded a => a
maxBound)

----------------------------------------------------------------------
-------------------------   Properties   -----------------------------

prop_shouldFailNonEmpty :: Property
prop_shouldFailNonEmpty :: Property
prop_shouldFailNonEmpty = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  VEncoding Version
v Encoding
ne <- Gen VEncoding -> PropertyT IO VEncoding
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen VEncoding
genInvalidNonEmptyCBOR
  Either DecoderError (NonEmpty Bool) -> PropertyT IO ()
forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (Version -> Encoding -> Either DecoderError (NonEmpty Bool)
forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
v Encoding
ne :: Either DecoderError (NonEmpty Bool))

prop_shouldFailEither :: Property
prop_shouldFailEither :: Property
prop_shouldFailEither = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  VEncoding Version
v Encoding
e <- Gen VEncoding -> PropertyT IO VEncoding
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen VEncoding
genInvalidEitherCBOR
  Either DecoderError (Either Bool Bool) -> PropertyT IO ()
forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (Version -> Encoding -> Either DecoderError (Either Bool Bool)
forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
v Encoding
e :: Either DecoderError (Either Bool Bool))

prop_shouldFailMaybe :: Property
prop_shouldFailMaybe :: Property
prop_shouldFailMaybe = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  VEncoding Version
v Encoding
e <- Gen VEncoding -> PropertyT IO VEncoding
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen VEncoding
genInvalidEitherCBOR
  Either DecoderError (Maybe Bool) -> PropertyT IO ()
forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (Version -> Encoding -> Either DecoderError (Maybe Bool)
forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
v Encoding
e :: Either DecoderError (Maybe Bool))

prop_shouldFailSetTag :: Property
prop_shouldFailSetTag :: Property
prop_shouldFailSetTag = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  VEncoding Version
v Encoding
set <- Gen VEncoding -> PropertyT IO VEncoding
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen VEncoding
genInvalidEitherCBOR
  let wrongTag :: Encoding
wrongTag = Word -> Encoding
encodeTag Word
266
  Either DecoderError (Set Int) -> PropertyT IO ()
forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (Version -> Encoding -> Either DecoderError (Set Int)
forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
v (Encoding
wrongTag Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
set) :: Either DecoderError (Set Int))

prop_shouldFailSet :: Property
prop_shouldFailSet :: Property
prop_shouldFailSet = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  [Int]
ls <- Gen [Int] -> PropertyT IO [Int]
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen [Int] -> PropertyT IO [Int])
-> Gen [Int] -> PropertyT IO [Int]
forall a b. (a -> b) -> a -> b
$ Range Int -> GenT Identity Int -> Gen [Int]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. a -> a -> Range a
Range.constant Int
0 Int
20) (Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int Range Int
forall a. (Bounded a, Num a) => Range a
Range.constantBounded)
  let set :: Encoding
set =
        Word -> Encoding
encodeTag Word
258
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ls Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat (Int -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Int -> Encoding) -> [Int] -> [Encoding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int
4 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int
3 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ls))
  Either DecoderError (Set Int) -> PropertyT IO ()
forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (Version -> Encoding -> Either DecoderError (Set Int)
forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
byronProtVer Encoding
set :: Either DecoderError (Set Int))

prop_shouldFailNegativeNatural :: Property
prop_shouldFailNegativeNatural :: Property
prop_shouldFailNegativeNatural = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  Integer
n <- Gen Integer -> PropertyT IO Integer
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Integer
genNegativeInteger
  Either DecoderError Natural -> PropertyT IO ()
forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (Version -> Encoding -> Either DecoderError Natural
forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
byronProtVer (Integer -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Integer
n) :: Either DecoderError Natural)

---------------------------------------------------------------------
------------------------------- helpers -----------------------------

assertIsLeft :: (HasCallStack, MonadTest m) => Either DecoderError b -> m ()
assertIsLeft :: forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (Right b
_) = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Diff -> String -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing String
"This should have Left : failed"
assertIsLeft (Left !DecoderError
x) = case DecoderError
x of
  DecoderErrorDeserialiseFailure Text
_ (DeserialiseFailure ByteOffset
_ String
str) | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str) -> m ()
forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorCanonicityViolation Text
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorCustom Text
_ Text
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorEmptyList Text
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorLeftover Text
_ ByteString
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorSizeMismatch Text
_ Int
_ Int
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorUnknownTag Text
_ Word8
i | Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
0 -> m ()
forall (m :: * -> *). MonadTest m => m ()
success
  DecoderError
_ -> m ()
forall (m :: * -> *). MonadTest m => m ()
success

decode :: DecCBOR a => Version -> Encoding -> Either DecoderError a
decode :: forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
version Encoding
enc =
  let encoded :: ByteString
encoded = Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version Encoding
enc
   in Version -> ByteString -> Either DecoderError a
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
version ByteString
encoded