Merge pull request #18 from input-output-hk/deepak/improvetests

Add Test for failure cases and untouched branches

binary/cardano-binary.cabal

@@ -73,6 +73,7 @@ test-suite test
  Test.Cardano.Binary.RoundTrip
  Test.Cardano.Binary.Serialization
  Test.Cardano.Binary.Drop
+ Test.Cardano.Binary.Failure
 
  build-depends: base
  , bytestring

binary/test/Test/Cardano/Binary/Failure.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Test.Cardano.Binary.Failure
+ (tests)
+ where
+
+import Cardano.Binary hiding (Range)
+import Cardano.Prelude
+import qualified Codec.CBOR.Read as CR
+
+import Hedgehog 
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Hedgehog.Internal.Property (failWith)
+
+tests :: IO Bool
+tests = checkParallel $$(discover)
+
+----------------------------------------------------------------------
+------------------------- Generators -----------------------------
+
+genInvalidNonEmptyCBOR :: Gen Encoding -- NonEmpty Bool
+genInvalidNonEmptyCBOR = toCBOR <$> pure ([] ::[Bool])
+
+genInvalidEitherCBOR :: Gen Encoding -- Either Bool Bool
+genInvalidEitherCBOR = do
+ b <- Gen.bool
+ pure (encodeListLen 2 <> encodeWord 3 <> toCBOR b)
+
+----------------------------------------------------------------------
+------------------------- Properties -----------------------------
+
+prop_shouldFailNonEmpty :: Property
+prop_shouldFailNonEmpty = property $ do
+ ne <- forAll genInvalidNonEmptyCBOR
+ assertIsLeft (decode ne :: Either DecoderError (NonEmpty Bool))
+
+prop_shouldFailEither :: Property
+prop_shouldFailEither = property $ do
+ e <- forAll genInvalidEitherCBOR
+ assertIsLeft (decode e :: Either DecoderError (Either Bool Bool))
+
+prop_shouldFailMaybe :: Property
+prop_shouldFailMaybe = property $ do
+ e <- forAll genInvalidEitherCBOR
+ assertIsLeft (decode e :: Either DecoderError (Maybe Bool))
+
+prop_shouldFailSetTag :: Property
+prop_shouldFailSetTag = property $ do
+ set <- forAll genInvalidEitherCBOR
+ let wrongTag = encodeTag 266
+ assertIsLeft (decode (wrongTag <> set) :: Either DecoderError (Set Int))
+
+prop_shouldFailSet :: Property
+prop_shouldFailSet = property $ do
+ ls <- forAll $ Gen.list (Range.constant 0 20) (Gen.int Range.constantBounded)
+ let set = encodeTag 258
+ <> encodeListLen (fromIntegral $ length ls + 2) 
+ <> (mconcat $ toCBOR <$> (4: 3:ls))
+ assertIsLeft (decode set :: Either DecoderError (Set Int))
+
+---------------------------------------------------------------------
+------------------------------- helpers -----------------------------
+
+assertIsLeft :: (HasCallStack, MonadTest m) => Either DecoderError b -> m ()
+assertIsLeft (Right _) = withFrozenCallStack $ failWith Nothing "This should have Left : failed"
+assertIsLeft (Left !x) = case x of
+ DecoderErrorDeserialiseFailure _ (CR.DeserialiseFailure _ str) | length str > 0 -> success
+ DecoderErrorCanonicityViolation _ -> success
+ DecoderErrorCustom _ _ -> success 
+ DecoderErrorEmptyList _ -> success
+ DecoderErrorLeftover _ _ -> success
+ DecoderErrorSizeMismatch _ _ _ -> success
+ DecoderErrorUnknownTag _ i | i > 0 -> success
+ _ -> success
+
+decode :: FromCBOR a => Encoding -> Either DecoderError a
+decode enc = 
+ let encoded = serializeEncoding enc
+ in decodeFull encoded
+

binary/test/Test/Cardano/Binary/Serialization.hs

@@ -45,7 +45,7 @@ data TestStruct = TestStruct
  , tsNonEmptyBool :: !(NonEmpty Bool)
  , tsMaybeBool :: !(Maybe Bool)
  , tsMapBoolBool :: !(Map Bool Bool)
- , tsMapSetBool :: !(Set Bool)
+ , tsSetBool  :: !(Set Bool)
  , tsRaw :: !Raw
  , tsVectorBool :: !(V.Vector Bool)
  , tsLByteString :: BS.Lazy.ByteString
@@ -105,7 +105,7 @@ instance ToCBOR TestStruct where
  <> toCBOR ( tsNonEmptyBool ts) 
  <> toCBOR ( tsMaybeBool ts) 
  <> toCBOR ( tsMapBoolBool ts) 
- <> toCBOR ( tsMapSetBool ts) 
+ <> toCBOR ( tsSetBool  ts) 
  <> toCBOR ( tsRaw ts)
  <> toCBOR ( tsVectorBool ts)
  <> toCBOR ( tsLByteString ts)
@@ -157,3 +157,14 @@ prop_roundTripKnownCBORData = property $ do
  ts <- forAll genTestStruct
  let encoded = serializeEncoding . encodeKnownCborDataItem $ ts
  decodeFullDecoder "" decodeKnownCborDataItem encoded === Right ts
+
+prop_decodeContainerSkelWithReplicate :: Property
+prop_decodeContainerSkelWithReplicate = property $
+ assert $ case decode vec of
+ Right _ -> True
+ _ -> False
+ where
+ decode :: Encoding -> Either DecoderError (V.Vector ())
+ decode enc = decodeFull (serializeEncoding enc)
+
+ vec = encodeListLen 4097 <> mconcat (replicate 4097 encodeNull)

binary/test/cardano-binary-test.cabal

@@ -22,6 +22,7 @@ library
  Test.Cardano.Binary.Helpers.GoldenRoundTrip
  Test.Cardano.Binary.Serialization
  Test.Cardano.Binary.Drop
+ Test.Cardano.Binary.Failure
 
  build-depends: base
  , bytestring

binary/test/test.hs

@@ -5,13 +5,15 @@ import qualified Test.Cardano.Binary.RoundTrip
 import qualified Test.Cardano.Binary.SizeBounds
 import qualified Test.Cardano.Binary.Serialization
 import qualified Test.Cardano.Binary.Drop
+import qualified Test.Cardano.Binary.Failure
 
 -- | Main testing action
 main :: IO ()
-main = do 
+main = do
  runTests
  [ Test.Cardano.Binary.RoundTrip.tests
  , Test.Cardano.Binary.SizeBounds.tests
  , Test.Cardano.Binary.Serialization.tests
  , Test.Cardano.Binary.Drop.tests
+ , Test.Cardano.Binary.Failure.tests
  ]