1{-# LANGUAGE CPP #-} 2{-# LANGUAGE ScopedTypeVariables #-} 3{-# LANGUAGE RankNTypes #-} 4 5module Tests.Canonical (testTree) where 6 7import Prelude hiding (decodeFloat, encodeFloat) 8 9#if !MIN_VERSION_base(4,8,0) 10import Control.Applicative 11#endif 12 13import qualified Data.ByteString.Lazy as LBS 14import Data.Proxy 15 16import Codec.CBOR.Read (deserialiseFromBytes) 17import Codec.CBOR.Decoding 18 19import Test.Tasty (TestTree, testGroup) 20import Test.Tasty.QuickCheck (testProperty) 21import Test.QuickCheck 22 23import Tests.Properties hiding (testTree) 24 25 26-- | This is a version of 'prop_decodeRefdecodeImp' but where we restrict the 27-- encoded input to non-canonical forms. These forms are covered by the 28-- original property. This property just ensures that we have good coverage of 29-- this case. 30-- 31prop_decode_nonCanonical :: forall t. Token t => t -> Property 32prop_decode_nonCanonical x = 33 let enc = serialiseRef x 34 y = deserialiseRef t enc 35 y' = deserialiseImp t enc 36 enc' = serialiseImp t y' 37 isCanonical = enc == enc' 38 in not isCanonical ==> 39 -- This property holds without this pre-condition, as demonstrated by 40 -- prop_decodeRefdecodeImp, but using it ensures we get good coverage 41 -- of the non-canonical cases 42 y' `eq` fromRef y 43 44 where 45 eq = eqImp t 46 t = Proxy :: Proxy t 47 48 49-- | Check that the special checked canonical form decoder primitives work. 50-- 51-- We decode with the normal and canonical decoder, and check that they agree 52-- in the canonical cases, and that the canonical decoder rejects the 53-- non-canonical cases. 54-- 55-- We have a QC coverage check to make sure we are covering enough of both 56-- canonical and non-canonical cases. 57-- 58prop_decodeCanonical :: forall t. Token t 59 => (forall s. Decoder s (Imp t)) 60 -> t -> Property 61prop_decodeCanonical decodeCanonical x = 62 classify isCanonical "canonical" $ 63 case deserialiseFromBytes decodeCanonical enc of 64 Left _failure -> not isCanonical 65 Right (trailing, y') -> isCanonical 66 && eqImp t y y' 67 && LBS.null trailing 68 where 69 enc = serialiseRef x 70 y = deserialiseImp t enc 71 -- It is canonical if it re-encodes to the same bytes we decoded 72 isCanonical = serialiseImp t y == enc 73 t = Proxy :: Proxy t 74 75 76 77prop_decodeCanonical_Word :: TokWord -> Property 78prop_decodeCanonical_Word = prop_decodeCanonical decodeWordCanonical 79 80prop_decodeCanonical_Word8 :: TokWord8 -> Property 81prop_decodeCanonical_Word8 = prop_decodeCanonical decodeWord8Canonical 82 83prop_decodeCanonical_Word16 :: TokWord16 -> Property 84prop_decodeCanonical_Word16 = prop_decodeCanonical decodeWord16Canonical 85 86prop_decodeCanonical_Word32 :: TokWord32 -> Property 87prop_decodeCanonical_Word32 = prop_decodeCanonical decodeWord32Canonical 88 89prop_decodeCanonical_Word64 :: TokWord64 -> Property 90prop_decodeCanonical_Word64 = prop_decodeCanonical decodeWord64Canonical 91 92--prop_decodeCanonical_NegWord :: TokNegWord -> Property 93--prop_decodeCanonical_NegWord = prop_decodeCanonical decodeNegWordCanonical 94 95prop_decodeCanonical_Int :: TokInt -> Property 96prop_decodeCanonical_Int = prop_decodeCanonical decodeIntCanonical 97 98prop_decodeCanonical_Int8 :: TokInt8 -> Property 99prop_decodeCanonical_Int8 = prop_decodeCanonical decodeInt8Canonical 100 101prop_decodeCanonical_Int16 :: TokInt16 -> Property 102prop_decodeCanonical_Int16 = prop_decodeCanonical decodeInt16Canonical 103 104prop_decodeCanonical_Int32 :: TokInt32 -> Property 105prop_decodeCanonical_Int32 = prop_decodeCanonical decodeInt32Canonical 106 107prop_decodeCanonical_Int64 :: TokInt64 -> Property 108prop_decodeCanonical_Int64 = prop_decodeCanonical decodeInt64Canonical 109 110prop_decodeCanonical_Integer :: TokInteger -> Property 111prop_decodeCanonical_Integer = prop_decodeCanonical decodeIntegerCanonical 112 113prop_decodeCanonical_Half :: TokHalf -> Property 114prop_decodeCanonical_Half = prop_decodeCanonical decodeFloat16Canonical 115 116prop_decodeCanonical_Float :: TokFloat -> Property 117prop_decodeCanonical_Float = prop_decodeCanonical decodeFloatCanonical 118 119prop_decodeCanonical_Double :: TokDouble -> Property 120prop_decodeCanonical_Double = prop_decodeCanonical decodeDoubleCanonical 121 122prop_decodeCanonical_Tag :: TokTag -> Property 123prop_decodeCanonical_Tag = prop_decodeCanonical decodeTagCanonical 124 125prop_decodeCanonical_Tag64 :: TokTag64 -> Property 126prop_decodeCanonical_Tag64 = prop_decodeCanonical decodeTag64Canonical 127 128prop_decodeCanonical_Simple :: Simple -> Property 129prop_decodeCanonical_Simple = prop_decodeCanonical decodeSimpleCanonical 130 131 132{- 133 , decodeNegWordCanonical -- :: Decoder s Word 134 , decodeNegWord64Canonical -- :: Decoder s Word64 135 , decodeBytesCanonical -- :: Decoder s ByteString 136 , decodeByteArrayCanonical -- :: Decoder s ByteArray 137 , decodeStringCanonical -- :: Decoder s Text 138 , decodeUtf8ByteArrayCanonical -- :: Decoder s ByteArray 139 , decodeListLenCanonical -- :: Decoder s Int 140 , decodeMapLenCanonical -- :: Decoder s Int 141-} 142 143-------------------------------------------------------------------------------- 144-- TestTree API 145 146testTree :: TestTree 147testTree = 148 testGroup "properties" 149 [ testGroup "decode non-canonical encoding" 150 [ testProperty "Word8" (prop_decode_nonCanonical :: TokWord8 -> Property) 151 , testProperty "Word16" (prop_decode_nonCanonical :: TokWord16 -> Property) 152 , testProperty "Word32" (prop_decode_nonCanonical :: TokWord32 -> Property) 153 , testProperty "Word64" (prop_decode_nonCanonical :: TokWord64 -> Property) 154 , testProperty "Word" (prop_decode_nonCanonical :: TokWord -> Property) 155-- , testProperty "NegWord" (prop_decode_nonCanonical :: TokNegWord -> Property) 156 , testProperty "Int8" (prop_decode_nonCanonical :: TokInt8 -> Property) 157 , testProperty "Int16" (prop_decode_nonCanonical :: TokInt16 -> Property) 158 , testProperty "Int32" (prop_decode_nonCanonical :: TokInt32 -> Property) 159 , testProperty "Int64" (prop_decode_nonCanonical :: TokInt64 -> Property) 160 , testProperty "Int" (prop_decode_nonCanonical :: TokInt -> Property) 161 , testProperty "Integer" (prop_decode_nonCanonical :: TokInteger -> Property) 162 , testProperty "Half" (prop_decode_nonCanonical :: TokHalf -> Property) 163 , testProperty "Float" (prop_decode_nonCanonical :: TokFloat -> Property) 164 , testProperty "Double" (prop_decode_nonCanonical :: TokDouble -> Property) 165 , testProperty "Tag" (prop_decode_nonCanonical :: TokTag -> Property) 166 , testProperty "Tag64" (prop_decode_nonCanonical :: TokTag64 -> Property) 167 , testProperty "Simple" (prop_decode_nonCanonical :: Simple -> Property) 168 , testProperty "Term" (prop_decode_nonCanonical :: Term -> Property) 169 ] 170 171 , testGroup "canonical decoding" 172 [ testProperty "Word" prop_decodeCanonical_Word 173 , testProperty "Word8" prop_decodeCanonical_Word8 174 , testProperty "Word16" prop_decodeCanonical_Word16 175 , testProperty "Word32" prop_decodeCanonical_Word32 176 , testProperty "Word64" prop_decodeCanonical_Word64 177 , testProperty "Int" prop_decodeCanonical_Int 178 , testProperty "Int8" prop_decodeCanonical_Int8 179 , testProperty "Int16" prop_decodeCanonical_Int16 180 , testProperty "Int32" prop_decodeCanonical_Int32 181 , testProperty "Int64" prop_decodeCanonical_Int64 182 , testProperty "Integer" prop_decodeCanonical_Integer 183 , testProperty "Half" prop_decodeCanonical_Half 184 , testProperty "Float" prop_decodeCanonical_Float 185 , testProperty "Double" prop_decodeCanonical_Double 186 , testProperty "Tag" prop_decodeCanonical_Tag 187 , testProperty "Tag64" prop_decodeCanonical_Tag64 188 , testProperty "Simple" prop_decodeCanonical_Simple 189 ] 190 ] 191 192