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

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

import qualified Codec.CBOR.Read as CR

import Data.List.NonEmpty (NonEmpty)
import Data.Set (Set)
import GHC.Stack (HasCallStack, withFrozenCallStack)
import Numeric.Natural (Natural)

import Cardano.Binary hiding (Range)

import Hedgehog
import qualified Hedgehog.Gen as Gen
import Hedgehog.Internal.Property (failWith)
import qualified Hedgehog.Range as Range

{- HLINT ignore "Use record patterns" -}

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

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

genInvalidNonEmptyCBOR :: Gen Encoding -- NonEmpty Bool
genInvalidNonEmptyCBOR :: Gen Encoding
genInvalidNonEmptyCBOR = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. ToCBOR a => a -> Encoding
toCBOR ([] :: [Bool]))

genInvalidEitherCBOR :: Gen Encoding -- Either Bool Bool
genInvalidEitherCBOR :: Gen Encoding
genInvalidEitherCBOR = do
  Bool
b <- forall (m :: * -> *). MonadGen m => m Bool
Gen.bool
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (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. ToCBOR a => a -> Encoding
toCBOR 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
  Encoding
ne <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Encoding
genInvalidNonEmptyCBOR
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (forall a. FromCBOR a => Encoding -> Either DecoderError a
decode 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
  Encoding
e <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Encoding
genInvalidEitherCBOR
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (forall a. FromCBOR a => Encoding -> Either DecoderError a
decode 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
  Encoding
e <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Encoding
genInvalidEitherCBOR
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (forall a. FromCBOR a => Encoding -> Either DecoderError a
decode 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
  Encoding
set <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen Encoding
genInvalidEitherCBOR
  let wrongTag :: Encoding
wrongTag = Word -> Encoding
encodeTag Word
266
  forall (m :: * -> *) b.
(HasCallStack, MonadTest m) =>
Either DecoderError b -> m ()
assertIsLeft (forall a. FromCBOR a => Encoding -> Either DecoderError a
decode (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. ToCBOR a => a -> Encoding
toCBOR 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. FromCBOR a => Encoding -> Either DecoderError a
decode 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. FromCBOR a => Encoding -> Either DecoderError a
decode (forall a. ToCBOR a => a -> Encoding
toCBOR 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
_ (CR.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 :: FromCBOR a => Encoding -> Either DecoderError a
decode :: forall a. FromCBOR a => Encoding -> Either DecoderError a
decode Encoding
enc =
  let encoded :: ByteString
encoded = forall a. ToCBOR a => a -> ByteString
serialize Encoding
enc
   in forall a. FromCBOR a => ByteString -> Either DecoderError a
decodeFull ByteString
encoded