{-# 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 = 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) = forall a. Show a => a -> String
show (Version -> Encoding -> Encoding
toPlainEncoding Version
v Encoding
enc)

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

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

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

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

prop_shouldFailNonEmpty :: Property
prop_shouldFailNonEmpty :: Property
prop_shouldFailNonEmpty = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  VEncoding Version
v Encoding
ne <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen VEncoding
genInvalidNonEmptyCBOR
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (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
property forall a b. (a -> b) -> a -> b
$ do
  VEncoding Version
v Encoding
e <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen VEncoding
genInvalidEitherCBOR
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (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
property forall a b. (a -> b) -> a -> b
$ do
  VEncoding Version
v Encoding
e <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen VEncoding
genInvalidEitherCBOR
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (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
property forall a b. (a -> b) -> a -> b
$ do
  VEncoding Version
v Encoding
set <- 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
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
v (Encoding
wrongTag 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
property forall a b. (a -> b) -> a -> b
$ do
  [Int]
ls <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (forall a. a -> a -> Range a
Range.constant Int
0 Int
20) (forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int forall a. (Bounded a, Num a) => Range a
Range.constantBounded)
  let set :: Encoding
set =
        Word -> Encoding
encodeTag Word
258
          forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
encodeListLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ls forall a. Num a => a -> a -> a
+ Int
2))
          forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. EncCBOR a => a -> Encoding
encCBOR forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int
4 forall a. a -> [a] -> [a]
: Int
3 forall a. a -> [a] -> [a]
: [Int]
ls))
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (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
property forall a b. (a -> b) -> a -> b
$ do
  Integer
n <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Integer
genNegativeInteger
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (forall a. DecCBOR a => Version -> Encoding -> Either DecoderError a
decode Version
byronProtVer (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
_) = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
failWith 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str) -> forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorCanonicityViolation Text
_ -> forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorCustom Text
_ Text
_ -> forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorEmptyList Text
_ -> forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorLeftover Text
_ ByteString
_ -> forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorSizeMismatch Text
_ Int
_ Int
_ -> forall (m :: * -> *). MonadTest m => m ()
success
  DecoderErrorUnknownTag Text
_ Word8
i | Word8
i forall a. Ord a => a -> a -> Bool
> Word8
0 -> forall (m :: * -> *). MonadTest m => m ()
success
  DecoderError
_ -> 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 = forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
version Encoding
enc
   in forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull Version
version ByteString
encoded