diff --git a/serialise.cabal b/serialise.cabal --- a/serialise.cabal +++ b/serialise.cabal @@ -1,5 +1,5 @@ name: serialise -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A binary serialisation library for Haskell values. description: This package (formerly @binary-serialise-cbor@) provides pure, efficient @@ -12,6 +12,11 @@ serialised Haskell values have implicit structure outside of the Haskell program itself, meaning they can be inspected or analyzed with custom tools. + . + An implementation of the standard bijection between CBOR and JSON is provided + by the [cborg-json](/package/cborg-json) package. Also see + [cbor-tool](/package/cbor-tool) for a convenient command-line utility for + working with CBOR data. homepage: https://github.com/well-typed/cborg license: BSD3 license-file: LICENSE.txt @@ -38,7 +43,7 @@ -- Flags flag newtime15 - default: False + default: True manual: False description: Use the new time 1.5 library @@ -55,12 +60,13 @@ Codec.Serialise.IO Codec.Serialise.Properties Codec.Serialise.Tutorial + Codec.Serialise.Internal.GeneralisedUTF8 build-depends: array >= 0.4 && < 0.6, base >= 4.6 && < 5.0, bytestring >= 0.10.4 && < 0.11, - cborg == 0.1.*, + cborg == 0.2.*, containers >= 0.5 && < 0.6, ghc-prim >= 0.3 && < 0.6, half >= 0.2.2.3 && < 0.3, @@ -99,20 +105,23 @@ Tests.Negative Tests.Orphanage Tests.Serialise + Tests.Serialise.Canonical Tests.Regress Tests.Regress.Issue13 Tests.Regress.Issue67 Tests.Regress.Issue80 Tests.Regress.Issue106 + Tests.Regress.Issue135 Tests.Regress.FlatTerm Tests.Reference Tests.Reference.Implementation Tests.Deriving + Tests.GeneralisedUTF8 build-depends: array >= 0.4 && < 0.6, base >= 4.6 && < 5.0, - binary >= 0.7 && < 0.9, + binary >= 0.7 && < 0.10, bytestring >= 0.10.4 && < 0.11, directory >= 1.0 && < 1.4, filepath >= 1.0 && < 1.5, @@ -122,19 +131,20 @@ containers >= 0.5 && < 0.6, unordered-containers >= 0.2 && < 0.3, hashable >= 1.2 && < 2.0, + primitive >= 0.5 && < 0.7, cborg, serialise, - aeson >= 0.7 && < 1.2, + aeson >= 0.7 && < 1.3, base64-bytestring >= 1.0 && < 1.1, base16-bytestring >= 0.1 && < 0.2, deepseq >= 1.0 && < 1.5, half >= 0.2.2.3 && < 0.3, - QuickCheck >= 2.9 && < 2.10, + QuickCheck >= 2.9 && < 2.11, scientific >= 0.3 && < 0.4, - tasty >= 0.11 && < 0.12, + tasty >= 0.11 && < 0.13, tasty-hunit >= 0.9 && < 0.10, - tasty-quickcheck >= 0.8 && < 0.9, + tasty-quickcheck >= 0.8 && < 0.10, quickcheck-instances >= 0.3.12 && < 0.4, vector >= 0.10 && < 0.13 @@ -157,14 +167,14 @@ build-depends: base >= 4.6 && < 5.0, - binary >= 0.7 && < 0.9, + binary >= 0.7 && < 0.10, bytestring >= 0.10.4 && < 0.11, vector >= 0.10 && < 0.13, cborg, serialise, deepseq >= 1.0 && < 1.5, - criterion >= 1.0 && < 1.2 + criterion >= 1.0 && < 1.3 if flag(newtime15) build-depends: @@ -201,16 +211,16 @@ build-depends: base >= 4.6 && < 5.0, - binary >= 0.7 && < 0.9, + binary >= 0.7 && < 0.10, bytestring >= 0.10.4 && < 0.11, ghc-prim >= 0.3 && < 0.6, vector >= 0.10 && < 0.13, cborg, serialise, - aeson >= 0.7 && < 1.2, + aeson >= 0.7 && < 1.3, deepseq >= 1.0 && < 1.5, - criterion >= 1.0 && < 1.2, + criterion >= 1.0 && < 1.3, cereal >= 0.5.2.0 && < 0.6, cereal-vector >= 0.2 && < 0.3, store >= 0.4 && < 0.5 @@ -247,7 +257,7 @@ build-depends: array >= 0.4 && < 0.6, base >= 4.6 && < 5.0, - binary >= 0.7 && < 0.9, + binary >= 0.7 && < 0.10, bytestring >= 0.10.4 && < 0.11, directory >= 1.0 && < 1.4, ghc-prim >= 0.3 && < 0.6, @@ -259,13 +269,13 @@ filepath >= 1.0 && < 1.5, containers >= 0.5 && < 0.6, deepseq >= 1.0 && < 1.5, - aeson >= 0.7 && < 1.2, + aeson >= 0.7 && < 1.3, cereal >= 0.5.2.0 && < 0.6, half >= 0.2.2.3 && < 0.3, tar >= 0.4 && < 0.6, zlib >= 0.5 && < 0.7, pretty >= 1.0 && < 1.2, - criterion >= 1.0 && < 1.2, + criterion >= 1.0 && < 1.3, store >= 0.4 && < 0.5 if flag(newtime15) diff --git a/src/Codec/Serialise.hs b/src/Codec/Serialise.hs --- a/src/Codec/Serialise.hs +++ b/src/Codec/Serialise.hs @@ -16,7 +16,7 @@ -- and utilities to help you make your types serialisable. -- -- For a full tutorial on using this module, see --- "Codec.CBOR.Tutorial". +-- "Codec.Serialise.Tutorial". -- module Codec.Serialise ( -- * High level, one-shot API diff --git a/src/Codec/Serialise/Class.hs b/src/Codec/Serialise/Class.hs --- a/src/Codec/Serialise/Class.hs +++ b/src/Codec/Serialise/Class.hs @@ -24,6 +24,8 @@ Serialise(..) , GSerialiseEncode(..) , GSerialiseDecode(..) + , GSerialiseProd(..) + , GSerialiseSum(..) , encodeVector , decodeVector ) where @@ -31,6 +33,7 @@ import Control.Applicative import Control.Monad +import Data.Char import Data.Hashable import Data.Int import Data.Monoid @@ -54,6 +57,7 @@ import qualified Data.Foldable as Foldable import qualified Data.ByteString as BS +import qualified Data.ByteString.Short.Internal as BSS import qualified Data.Text as Text -- TODO FIXME: more instances @@ -68,6 +72,7 @@ import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.Tree as Tree +import qualified Data.Primitive.ByteArray as Prim import qualified Data.Vector as Vector import qualified Data.Vector.Unboxed as Vector.Unboxed import qualified Data.Vector.Storable as Vector.Storable @@ -105,6 +110,9 @@ import Codec.CBOR.Decoding import Codec.CBOR.Encoding import Codec.CBOR.Term +import Codec.Serialise.Internal.GeneralisedUTF8 +import qualified Codec.CBOR.ByteArray as BA +import qualified Codec.CBOR.ByteArray.Sliced as BAS -------------------------------------------------------------------------------- @@ -304,16 +312,37 @@ -- | @since 0.2.0.0 instance Serialise Char where - encode c = encodeString (Text.singleton c) - decode = do t <- decodeString - if Text.length t == 1 - then return $! Text.head t - else fail "expected a single char, found a string" + -- Here we've taken great pains to ensure that surrogate characters, which + -- are not representable in UTF-8 yet still admitted by Char, + -- round-trip properly. We scan the encoded characters during encoding + -- looking for surrogates; if we find any we encode the string as a + -- a list of code-points encoded as words. This is slow, but should be rare. + encode c + | isSurrogate c = encodeWord (fromIntegral $ ord c) + | otherwise = encodeString (Text.singleton c) + decode = do ty <- peekTokenType + case ty of + TypeUInt -> chr . fromIntegral <$> decodeWord + TypeString -> do + t <- decodeString + if Text.length t == 1 + then return $! Text.head t + else fail "expected a single char, found a string" + _ -> fail "expected a word or string" -- For [Char]/String we have a special encoding - encodeList cs = encodeString (Text.pack cs) - decodeList = do txt <- decodeString - return (Text.unpack txt) -- unpack lazily + encodeList cs = + case encodeGenUTF8 cs of + (ba, ConformantUTF8) -> encodeUtf8ByteArray ba + (ba, GeneralisedUTF8) -> encodeByteArray ba + decodeList = do + ty <- peekTokenType + case ty of + TypeBytes -> decodeGenUTF8 . BA.unBA <$> decodeByteArray + TypeString -> do + txt <- decodeString + return (Text.unpack txt) -- unpack lazily + _ -> fail "expected a list or string" -- | @since 0.2.0.0 instance Serialise Text.Text where @@ -325,6 +354,14 @@ encode = encodeBytes decode = decodeBytes +-- | @since 0.2.0.0 +instance Serialise BSS.ShortByteString where + encode sbs@(BSS.SBS ba) = + encodeByteArray $ BAS.SBA (Prim.ByteArray ba) 0 (BSS.length sbs) + decode = do + BA.BA (Prim.ByteArray ba) <- decodeByteArray + return $ BSS.SBS ba + encodeChunked :: Serialise c => Encoding -> ((c -> Encoding -> Encoding) -> Encoding -> a -> Encoding) @@ -1242,7 +1279,7 @@ Just HRefl -> pure rep Nothing -> fail $ unlines [ "Codec.CBOR.Class.decode(TypeRep): Type mismatch" - , " Deserialized type: " ++ show rep + , " Deserialised type: " ++ show rep , " Expected type: " ++ show expected ] where expected = typeRep :: TypeRep a diff --git a/src/Codec/Serialise/Decoding.hs b/src/Codec/Serialise/Decoding.hs --- a/src/Codec/Serialise/Decoding.hs +++ b/src/Codec/Serialise/Decoding.hs @@ -35,8 +35,10 @@ , decodeDouble -- :: Decoder s Double , decodeBytes -- :: Decoder s ByteString , decodeBytesIndef -- :: Decoder s () + , decodeByteArray -- :: Decoder s ByteArray , decodeString -- :: Decoder s Text , decodeStringIndef -- :: Decoder s () + , decodeUtf8ByteArray -- :: Decoder s ByteArray , decodeListLen -- :: Decoder s Int , decodeListLenIndef -- :: Decoder s () , decodeMapLen -- :: Decoder s Int diff --git a/src/Codec/Serialise/Encoding.hs b/src/Codec/Serialise/Encoding.hs --- a/src/Codec/Serialise/Encoding.hs +++ b/src/Codec/Serialise/Encoding.hs @@ -29,8 +29,10 @@ , encodeInteger -- :: Integer -> Encoding , encodeBytes -- :: B.ByteString -> Encoding , encodeBytesIndef -- :: Encoding + , encodeByteArray -- :: ByteArray -> Encoding , encodeString -- :: T.Text -> Encoding , encodeStringIndef -- :: Encoding + , encodeUtf8ByteArray -- :: ByteArray -> Encoding , encodeListLen -- :: Word -> Encoding , encodeListLenIndef -- :: Encoding , encodeMapLen -- :: Word -> Encoding diff --git a/src/Codec/Serialise/Internal/GeneralisedUTF8.hs b/src/Codec/Serialise/Internal/GeneralisedUTF8.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Serialise/Internal/GeneralisedUTF8.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE BangPatterns #-} + +module Codec.Serialise.Internal.GeneralisedUTF8 + ( encodeGenUTF8 + , UTF8Encoding(..) + , decodeGenUTF8 + -- * Utilities + , isSurrogate + , isValid + ) where + +import Control.Monad.ST +import Data.Bits +import Data.Char +import Data.Word +import qualified Codec.CBOR.ByteArray.Sliced as BAS +import Data.Primitive.ByteArray + +data UTF8Encoding = ConformantUTF8 | GeneralisedUTF8 + deriving (Show, Eq) + +-- | Is a 'Char' a UTF-16 surrogate? +isSurrogate :: Char -> Bool +isSurrogate c = c >= '\xd800' && c <= '\xdfff' + +-- | Encode a string as (generalized) UTF-8. In addition to the encoding, we +-- return a flag indicating whether the encoded string contained any surrogate +-- characters, in which case the output is generalized UTF-8. +encodeGenUTF8 :: String -> (BAS.SlicedByteArray, UTF8Encoding) +encodeGenUTF8 st = runST $ do + -- We slightly over-allocate such that we won't need to copy in the + -- ASCII-only case. + ba <- newByteArray (length st + 4) + go ba ConformantUTF8 0 st + where + go :: MutableByteArray s -> UTF8Encoding + -> Int -> [Char] + -> ST s (BAS.SlicedByteArray, UTF8Encoding) + go ba !enc !off [] = do + ba' <- unsafeFreezeByteArray ba + return (BAS.SBA ba' 0 off, enc) + go ba enc off (c:cs) + | off + 4 >= cap = do + -- We ran out of room; reallocate and copy + ba' <- newByteArray (cap + cap `div` 2 + 1) + copyMutableByteArray ba' 0 ba 0 off + go ba' enc off (c:cs) + + | c >= '\x10000' = do + writeByteArray ba (off+0) (0xf0 .|. (0x07 .&. shiftedByte 18)) + writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte 12)) + writeByteArray ba (off+2) (0x80 .|. (0x3f .&. shiftedByte 6)) + writeByteArray ba (off+3) (0x80 .|. (0x3f .&. shiftedByte 0)) + go ba enc (off+4) cs + + | c >= '\x0800' = do + writeByteArray ba (off+0) (0xe0 .|. (0x0f .&. shiftedByte 12)) + writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte 6)) + writeByteArray ba (off+2) (0x80 .|. (0x3f .&. shiftedByte 0)) + + -- Is this a surrogate character? + let enc' + | isSurrogate c = GeneralisedUTF8 + | otherwise = enc + go ba enc' (off+3) cs + + | c >= '\x0080' = do + writeByteArray ba (off+0) (0xc0 .|. (0x1f .&. shiftedByte 6)) + writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte 0)) + go ba enc (off+2) cs + + | c <= '\x007f' = do + writeByteArray ba off (fromIntegral n :: Word8) + go ba enc (off+1) cs + + | otherwise = error "encodeGenUTF8: Impossible" + where + cap = sizeofMutableByteArray ba + n = ord c + shiftedByte :: Int -> Word8 + shiftedByte shft = fromIntegral $ n `shiftR` shft + +decodeGenUTF8 :: ByteArray -> String +decodeGenUTF8 ba = go 0 + where + !len = sizeofByteArray ba + + index :: Int -> Int + index i = fromIntegral (ba `indexByteArray` i :: Word8) + + go !off + | off == len = [] + + | n0 .&. 0xf8 == 0xf0 = + let n1 = index (off + 1) + n2 = index (off + 2) + n3 = index (off + 3) + c = chr $ (n0 .&. 0x07) `shiftL` 18 + .|. (n1 .&. 0x3f) `shiftL` 12 + .|. (n2 .&. 0x3f) `shiftL` 6 + .|. (n3 .&. 0x3f) + in c : go (off + 4) + + | n0 .&. 0xf0 == 0xe0 = + let n1 = index (off + 1) + n2 = index (off + 2) + c = chr $ (n0 .&. 0x0f) `shiftL` 12 + .|. (n1 .&. 0x3f) `shiftL` 6 + .|. (n2 .&. 0x3f) + in c : go (off + 3) + + | n0 .&. 0xe0 == 0xc0 = + let n1 = index (off + 1) + c = chr $ (n0 .&. 0x1f) `shiftL` 6 + .|. (n1 .&. 0x3f) + in c : go (off + 2) + + | otherwise = + let c = chr $ (n0 .&. 0x7f) + in c : go (off + 1) + where !n0 = index off + +-- | Is the given byte sequence valid under the given encoding? +isValid :: UTF8Encoding -> [Word8] -> Bool +isValid encoding = go + where + go [] = True + go (b0:bs) + | inRange 0x00 0x7f b0 = go bs + go (b0:b1:bs) + | inRange 0xc2 0xdf b0 + , inRange 0x80 0xbf b1 = go bs + go (0xe0:b1:b2:bs) + | inRange 0xa0 0xbf b1 + , inRange 0x80 0xbf b2 = go bs + go (0xed:b1:_) + -- surrogate range + | encoding == ConformantUTF8 + , inRange 0xa0 0xbf b1 + = False + go (b0:b1:b2:bs) + | inRange 0xe1 0xef b0 + , inRange 0x80 0xbf b1 + , inRange 0x80 0xbf b2 = go bs + go (0xf0:b1:b2:b3:bs) + | inRange 0x90 0xbf b1 + , inRange 0x80 0xbf b2 + , inRange 0x80 0xbf b3 = go bs + go (b0:b1:b2:b3:bs) + | inRange 0xf1 0xf3 b0 + , inRange 0x80 0xbf b1 + , inRange 0x80 0xbf b2 + , inRange 0x80 0xbf b3 = go bs + go (0xf4:b1:b2:b3:bs) + | inRange 0x80 0x8f b1 + , inRange 0x80 0xbf b2 + , inRange 0x80 0xbf b3 = go bs + go _ = False + +inRange :: Ord a => a -> a -> a -> Bool +inRange lower upper x = lower <= x && x <= upper diff --git a/src/Codec/Serialise/Tutorial.hs b/src/Codec/Serialise/Tutorial.hs --- a/src/Codec/Serialise/Tutorial.hs +++ b/src/Codec/Serialise/Tutorial.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | --- Module : Codec.CBOR.Tutorial +-- Module : Codec.Serialise.Tutorial -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- @@ -53,7 +53,7 @@ As in modern serialisation libraries, @cborg@ offers instance derivation via GHC's 'GHC.Generic' mechanism, -> import Serialise.Cborg +> import Codec.Serialise > import qualified Data.ByteString.Lazy as BSL > > data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int } @@ -162,16 +162,16 @@ {- $encoding For the purposes of encoding, abstract CBOR representations are embodied by the -'Serialise.Cborg.Encoding.Tokens' type. Such a representation can be efficiently -built using the 'Serialise.Cborg.Encoding.Encoding' 'Monoid'. +'Codec.CBOR.Encoding.Tokens' type. Such a representation can be efficiently +built using the 'Codec.CBOR.Encoding.Encoding' 'Monoid'. For instance, to implement an encoder for the @Animal@ type above we might write, > encodeAnimal :: Animal -> Encoding > encodeAnimal (HoppingAnimal name height) = -> encodeListLen 3 <> encodeTag 0 <> encode name <> encode height +> encodeListLen 3 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (WalkingAnimal name speed) = -> encodeListLen 3 <> encodeTag 1 <> encode name <> encode speed +> encodeListLen 3 <> encodeWord 1 <> encode name <> encode speed Here we see that each encoding begins with a /length/, describing how many values belonging to our @Animal@ will follow. We then encode a /tag/, which @@ -182,6 +182,9 @@ the length and tag, to ensure that you have the option to migrate your types later on. +Also note that the recommended encoding represents Haskell constructor indexes +as CBOR words, not CBOR tags. + -} {- $decoding @@ -193,7 +196,7 @@ > decodeAnimal :: Decoder s Animal > decodeAnimal = do > len <- decodeListLen -> tag <- decodeTag +> tag <- decodeWord > case (len, tag) of > (3, 0) -> HoppingAnimal <$> decode <*> decode > (3, 1) -> WalkingAnimal <$> decode <*> decode @@ -232,17 +235,17 @@ > encodeAnimal :: Animal -> Encoding > -- HoppingAnimal, SwimmingAnimal cases are unchanged... > encodeAnimal (HoppingAnimal name height) = -> encodeListLen 3 <> encodeTag 0 <> encode name <> encode height +> encodeListLen 3 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (WalkingAnimal name speed) = -> encodeListLen 3 <> encodeTag 1 <> encode name <> encode speed +> encodeListLen 3 <> encodeWord 1 <> encode name <> encode speed > -- Here is out new case... > encodeAnimal (SwimmingAnimal numberOfFins) = -> encodeListLen 2 <> encodeTag 2 <> encode numberOfFins +> encodeListLen 2 <> encodeWord 2 <> encode numberOfFins > > decodeAnimal :: Decoder s Animal > decodeAnimal = do > len <- decodeListLen -> tag <- decodeTag +> tag <- decodeWord > case (len, tag) of > -- these cases are unchanged... > (3, 0) -> HoppingAnimal <$> decode <*> decode @@ -266,17 +269,17 @@ > encodeAnimal :: Animal -> Encoding > -- HoppingAnimal, SwimmingAnimal cases are unchanged... > encodeAnimal (HoppingAnimal name height) = -> encodeListLen 3 <> encodeTag 0 <> encode name <> encode height +> encodeListLen 3 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (WalkingAnimal name speed) = -> encodeListLen 3 <> encodeTag 1 <> encode name <> encode speed +> encodeListLen 3 <> encodeWord 1 <> encode name <> encode speed > -- This is new... > encodeAnimal (WalkingAnimal animalName walkingSpeed numberOfFeet) = -> encodeListLen 4 <> encodeTag 3 <> encode animalName <> encode walkingSpeed <> encode numberOfFins +> encodeListLen 4 <> encodeWord 3 <> encode animalName <> encode walkingSpeed <> encode numberOfFins > > decodeAnimal :: Decoder s Animal > decodeAnimal = do > len <- decodeListLen -> tag <- decodeTag +> tag <- decodeWord > case (len, tag) of > -- this cases are unchanged... > (3, 0) -> HoppingAnimal <$> decode <*> decode @@ -295,7 +298,7 @@ When working with foreign encodings, it can sometimes be useful to capture a serialised CBOR term verbatim (for instance, so you can later re-serialise it in -some later result). The 'Serialise.Cborg.Term.Term' type provides such a +some later result). The 'Codec.CBOR.Term.Term' type provides such a representation, losslessly capturing a CBOR AST. It can be serialised and deserialised with its 'Serialise' instance. @@ -305,9 +308,9 @@ We can also look In addition to serialisation and deserialisation, @cborg@ provides a variety of tools for representing arbitrary CBOR encodings in the -"Serialise.Cborg.FlatTerm" and "Serialise.Cborg.Pretty" modules. +"Codec.CBOR.FlatTerm" and "Codec.CBOR.Pretty" modules. -The 'Serialise.Cborg.FlatTerm.FlatTerm' type represents a single CBOR /term/, as +The 'Codec.CBOR.FlatTerm.FlatTerm' type represents a single CBOR /term/, as would be found in the ultimate CBOR representation. For instance, we can easily look at the structure of our @Animal@ encoding above, @@ -319,10 +322,10 @@ This can be useful both for understanding external CBOR formats, as well as understanding and testing your own hand-rolled encodings. -The package also includes a pretty-printer in "Serialise.Cborg.Pretty", for +The package also includes a pretty-printer in "Codec.CBOR.Pretty", for visualising the CBOR wire protocol alongside its semantic structure. For instance, ->>> putStrLn $ Serialise.Cborg.Pretty.prettyHexEnc $ encode $ HoppingAnimal "Fred" 42 +>>> putStrLn $ Codec.CBOR.Pretty.prettyHexEnc $ encode $ HoppingAnimal "Fred" 42 83 # list(3) 00 # word(0) 64 46 72 65 64 # text("Fred") diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -10,6 +10,7 @@ import qualified Tests.Serialise as Serialise import qualified Tests.Negative as Negative import qualified Tests.Deriving as Deriving +import qualified Tests.GeneralisedUTF8 as GeneralisedUTF8 main :: IO () main = Reference.loadTestCases >>= \tcs -> defaultMain $ @@ -22,4 +23,5 @@ , IO.testTree , Regress.testTree , Deriving.testTree + , GeneralisedUTF8.testTree ] diff --git a/tests/Tests/CBOR.hs b/tests/Tests/CBOR.hs --- a/tests/Tests/CBOR.hs +++ b/tests/Tests/CBOR.hs @@ -155,9 +155,15 @@ toRefTerm TNull = RefImpl.TNull toRefTerm (TSimple 23) = RefImpl.TUndef toRefTerm (TSimple w) = RefImpl.TSimple (fromIntegral w) -toRefTerm (THalf f) = RefImpl.TFloat16 (Half.toHalf f) -toRefTerm (TFloat f) = RefImpl.TFloat32 f -toRefTerm (TDouble f) = RefImpl.TFloat64 f +toRefTerm (THalf f) = if isNaN f + then RefImpl.TFloat16 RefImpl.canonicalNaN + else RefImpl.TFloat16 (Half.toHalf f) +toRefTerm (TFloat f) = if isNaN f + then RefImpl.TFloat16 RefImpl.canonicalNaN + else RefImpl.TFloat32 f +toRefTerm (TDouble f) = if isNaN f + then RefImpl.TFloat16 RefImpl.canonicalNaN + else RefImpl.TFloat64 f fromRefTerm :: RefImpl.Term -> Term @@ -191,8 +197,12 @@ fromRefTerm RefImpl.TUndef = TSimple 23 fromRefTerm (RefImpl.TSimple w) = TSimple w fromRefTerm (RefImpl.TFloat16 f) = THalf (Half.fromHalf f) -fromRefTerm (RefImpl.TFloat32 f) = TFloat f -fromRefTerm (RefImpl.TFloat64 f) = TDouble f +fromRefTerm (RefImpl.TFloat32 f) = if isNaN f + then THalf (Half.fromHalf RefImpl.canonicalNaN) + else TFloat f +fromRefTerm (RefImpl.TFloat64 f) = if isNaN f + then THalf (Half.fromHalf RefImpl.canonicalNaN) + else TDouble f -- NaNs are so annoying... eqTerm :: Term -> Term -> Bool diff --git a/tests/Tests/GeneralisedUTF8.hs b/tests/Tests/GeneralisedUTF8.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/GeneralisedUTF8.hs @@ -0,0 +1,37 @@ +module Tests.GeneralisedUTF8 where + +import GHC.Exts +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString as BS + +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Codec.CBOR.ByteArray as BA +import Codec.Serialise.Internal.GeneralisedUTF8 + +testEncoder :: String -> Property +testEncoder s = + case encodeGenUTF8 s of + (ba, enc) -> + toList ba === BS.unpack (T.encodeUtf8 $ T.pack s) + .&&. + enc === correctEnc + where + correctEnc + | any isSurrogate s = GeneralisedUTF8 + | otherwise = ConformantUTF8 + +testDecoder :: String -> Property +testDecoder s = + decodeGenUTF8 ba === s + where + BA.BA ba = BA.fromByteString $ T.encodeUtf8 $ T.pack s + +testTree :: TestTree +testTree = + testGroup "Generalised UTF-8 codec" + [ testProperty "encoder" testEncoder + , testProperty "decoder" testDecoder + ] diff --git a/tests/Tests/Orphanage.hs b/tests/Tests/Orphanage.hs --- a/tests/Tests/Orphanage.hs +++ b/tests/Tests/Orphanage.hs @@ -4,26 +4,29 @@ {-# LANGUAGE DeriveDataTypeable #-} module Tests.Orphanage where -#if !MIN_VERSION_base(4,8,0) +#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,10,0) import Control.Applicative import Data.Monoid as Monoid #endif -#if MIN_VERSION_base(4,9,0) +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_QuickCheck(2,10,0) import qualified Data.Semigroup as Semigroup #endif -import Data.Typeable - +import GHC.Fingerprint.Type import Data.Ord +#if !MIN_VERSION_QuickCheck(2,10,0) +import Data.Typeable import Foreign.C.Types import System.Exit (ExitCode(..)) -import GHC.Fingerprint.Type import Test.QuickCheck.Gen +#endif + import Test.QuickCheck.Arbitrary import qualified Data.Vector.Primitive as Vector.Primitive +import qualified Data.ByteString.Short as BSS -------------------------------------------------------------------------------- -- QuickCheck Orphans @@ -35,6 +38,7 @@ -- Foreign C types +#if !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary CChar where arbitrary = CChar <$> arbitrary shrink (CChar x) = CChar <$> shrink x @@ -134,10 +138,11 @@ instance Arbitrary CDouble where arbitrary = CDouble <$> arbitrary shrink (CDouble x) = CDouble <$> shrink x +#endif -- Miscellaneous types from base -#if MIN_VERSION_base(4,9,0) +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary a => Arbitrary (Semigroup.Min a) where arbitrary = fmap Semigroup.Min arbitrary shrink = map Semigroup.Min . shrink . Semigroup.getMin @@ -167,11 +172,13 @@ arbitrary = fmap Down arbitrary shrink = map Down . shrink . (\(Down a) -> a) +#if !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary ExitCode where arbitrary = frequency [(1, return ExitSuccess), (3, fmap ExitFailure arbitrary)] shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] shrink _ = [] +#endif #if !MIN_VERSION_base(4,8,0) deriving instance Typeable Const @@ -188,11 +195,14 @@ deriving instance Eq a => Eq (Const a b) #endif +instance Arbitrary BSS.ShortByteString where + arbitrary = BSS.pack <$> arbitrary + instance (Vector.Primitive.Prim a, Arbitrary a ) => Arbitrary (Vector.Primitive.Vector a) where arbitrary = Vector.Primitive.fromList <$> arbitrary -#if MIN_VERSION_base(4,7,0) +#if MIN_VERSION_base(4,7,0) && !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary (Proxy a) where arbitrary = return Proxy #endif diff --git a/tests/Tests/Reference.hs b/tests/Tests/Reference.hs --- a/tests/Tests/Reference.hs +++ b/tests/Tests/Reference.hs @@ -185,10 +185,8 @@ , ("NaN", [0xf9, 0x7e, 0x00]) , ("-Infinity", [0xf9, 0xfc, 0x00]) , ("Infinity", [0xfa, 0x7f, 0x80, 0x00, 0x00]) - , ("NaN", [0xfa, 0x7f, 0xc0, 0x00, 0x00]) , ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00]) , ("Infinity", [0xfb, 0x7f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) - , ("NaN", [0xfb, 0x7f, 0xf8, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) , ("-Infinity", [0xfb, 0xff, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) , ("false", [0xf4]) diff --git a/tests/Tests/Reference/Implementation.hs b/tests/Tests/Reference/Implementation.hs --- a/tests/Tests/Reference/Implementation.hs +++ b/tests/Tests/Reference/Implementation.hs @@ -38,6 +38,8 @@ decodeTokens, decodeToken, + canonicalNaN, + diagnosticNotation, encodeTerm, @@ -64,7 +66,7 @@ import Data.Bits import Data.Word import Data.Int -import Numeric.Half (Half) +import Numeric.Half (Half(..)) import qualified Numeric.Half as Half import Data.List import Numeric @@ -816,6 +818,12 @@ = TNInt (toUInt (fromIntegral (-1 - n))) | otherwise = TBigInt n canonicaliseTerm (TFloat16 f) = TFloat16 (canonicaliseHalf f) +canonicaliseTerm (TFloat32 f) = if isNaN f + then TFloat16 canonicalNaN + else TFloat32 f +canonicaliseTerm (TFloat64 f) = if isNaN f + then TFloat16 canonicalNaN + else TFloat64 f canonicaliseTerm (TBytess wss) = TBytess (filter (not . null) wss) canonicaliseTerm (TStrings css) = TStrings (filter (not . null) css) canonicaliseTerm (TArray ts) = TArray (map canonicaliseTerm ts) @@ -828,12 +836,16 @@ canonicaliseUInt :: UInt -> UInt canonicaliseUInt = toUInt . fromUInt --- some NaNs do not roundtrip https://github.com/ekmett/half/issues/3 canonicaliseHalf :: Half -> Half -canonicaliseHalf = Half.toHalf . Half.fromHalf +canonicaliseHalf f + | isNaN f = canonicalNaN + | otherwise = f canonicaliseTermPair :: (Term, Term) -> (Term, Term) canonicaliseTermPair (x,y) = (canonicaliseTerm x, canonicaliseTerm y) + +canonicalNaN :: Half +canonicalNaN = Half 0x7e00 ------------------------------------------------------------------------------- diff --git a/tests/Tests/Regress.hs b/tests/Tests/Regress.hs --- a/tests/Tests/Regress.hs +++ b/tests/Tests/Regress.hs @@ -7,7 +7,8 @@ import qualified Tests.Regress.Issue13 as Issue13 import qualified Tests.Regress.Issue67 as Issue67 import qualified Tests.Regress.Issue80 as Issue80 -import qualified Tests.Regress.Issue106 as Issue106 +import qualified Tests.Regress.Issue106 as Issue106 +import qualified Tests.Regress.Issue135 as Issue135 import qualified Tests.Regress.FlatTerm as FlatTerm -------------------------------------------------------------------------------- @@ -20,4 +21,5 @@ , Issue67.testTree , Issue80.testTree , Issue106.testTree + , Issue135.testTree ] diff --git a/tests/Tests/Regress/Issue135.hs b/tests/Tests/Regress/Issue135.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/Issue135.hs @@ -0,0 +1,34 @@ +-- Issue #135: Ensure that surrogate characters round-trip +-- +module Tests.Regress.Issue135 + ( testTree -- :: TestTree + ) where + +import Codec.Serialise + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit + +newtype StringWithSurrogates = StringWithSurrogates String + deriving (Show) + +instance Arbitrary StringWithSurrogates where + arbitrary = + fmap StringWithSurrogates $ listOf1 + $ oneof [choose ('\xd800', '\xdfff'), arbitrary] + +prop_surrogateRoundtrip :: StringWithSurrogates -> Property +prop_surrogateRoundtrip (StringWithSurrogates s) = + s === deserialise (serialise s) + +roundTrips :: (Eq a, Serialise a) => a -> Bool +roundTrips x = x == deserialise (serialise x) + +testTree :: TestTree +testTree = + testGroup "Issue 135 - surrogate characters round-trip" + [ testCase "simple reproduction case" (True @=? all (\c -> c == deserialise (serialise c)) ['\xdc80'..'\xdcff']) + , testCase "all Chars round-trip" ([] @=? filter (not . roundTrips) ['\x0000'..'\x10ffff']) + , testProperty "surrogates round-trip" prop_surrogateRoundtrip + ] diff --git a/tests/Tests/Serialise.hs b/tests/Tests/Serialise.hs --- a/tests/Tests/Serialise.hs +++ b/tests/Tests/Serialise.hs @@ -19,6 +19,7 @@ import qualified Data.Semigroup as Semigroup #endif +import Data.Char (ord) import Data.Complex import Data.Int import Data.Fixed @@ -27,6 +28,7 @@ import Data.Ratio import Data.Time import Data.Word +import GHC.Exts (IsList(..)) import GHC.Float (float2Double) import Data.Version @@ -40,17 +42,21 @@ import Test.QuickCheck.Instances () import Test.Tasty.HUnit import GHC.Generics (Generic) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Text.Lazy -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BS.Lazy +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.Lazy +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString.Short.Internal as BSS import System.Exit (ExitCode(..)) +import qualified Codec.CBOR.ByteArray as CBOR.BA import Codec.CBOR.FlatTerm (toFlatTerm, fromFlatTerm) import Codec.Serialise import Codec.Serialise.Encoding import Codec.Serialise.Decoding -import qualified Codec.Serialise.Properties as Props +import qualified Codec.Serialise.Properties as Props import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet @@ -65,8 +71,10 @@ import qualified Data.Vector.Storable as Vector.Storable import qualified Data.Vector.Primitive as Vector.Primitive import GHC.Fingerprint.Type (Fingerprint(..)) +import Data.Primitive.ByteArray as Prim import Tests.Orphanage() +import Tests.Serialise.Canonical -------------------------------------------------------------------------------- -- Tests and properties @@ -152,9 +160,22 @@ , mkTest (T :: T Word16) , mkTest (T :: T Word32) , mkTest (T :: T Word64) + , mkTest (T :: T (Canonical Int)) + , mkTest (T :: T (Canonical Int8)) + , mkTest (T :: T (Canonical Int16)) + , mkTest (T :: T (Canonical Int32)) + , mkTest (T :: T (Canonical Int64)) + , mkTest (T :: T (Canonical Word)) + , mkTest (T :: T (Canonical Word8)) + , mkTest (T :: T (Canonical Word16)) + , mkTest (T :: T (Canonical Word32)) + , mkTest (T :: T (Canonical Word64)) , mkTest (T :: T Integer) , mkTest (T :: T Float) , mkTest (T :: T Double) + , mkTest (T :: T (Canonical Integer)) + , mkTest (T :: T (Canonical Float)) + , mkTest (T :: T (Canonical Double)) , mkTest (T :: T [()]) #if MIN_VERSION_base(4,9,0) , mkTest (T :: T (NonEmpty ())) @@ -214,6 +235,9 @@ , mkTest (T :: T Text.Lazy.Text) , mkTest (T :: T BS.ByteString) , mkTest (T :: T BS.Lazy.ByteString) + , mkTest (T :: T BSS.ShortByteString) + , mkTest (T :: T BytesByteArray) + , mkTest (T :: T Utf8ByteArray) , mkTest (T :: T [Int]) , mkTest (T :: T UTCTime) , mkTest (T :: T Version) @@ -274,7 +298,7 @@ (TkListLen 3 $ TkWord 0 $ TkInt 12 $ TkFloat32 0.5 $ TkEnd) , format (P3 12 0.5 "asdf") - (TkListLen 4 $ TkWord 0 $ TkInt 12 $ TkFloat32 0.5 $ TkString "asdf" $ TkEnd) + (TkListLen 4 $ TkWord 0 $ TkInt 12 $ TkFloat32 0.5 $ tkStr "asdf" $ TkEnd) , format (C1 12) (TkListLen 2 $ TkWord 0 $ TkInt 12 $ TkEnd) @@ -283,18 +307,20 @@ (TkListLen 3 $ TkWord 1 $ TkInt 12 $ TkFloat32 0.5 $ TkEnd) , format (C3 12 0.5 "asdf") - (TkListLen 4 $ TkWord 2 $ TkInt 12 $ TkFloat32 0.5 $ TkString "asdf" $ TkEnd) + (TkListLen 4 $ TkWord 2 $ TkInt 12 $ TkFloat32 0.5 $ tkStr "asdf" $ TkEnd) , format C4 (TkListLen 1 $ TkWord 3 $ TkEnd) , format (Cons "foo" (Cons "bar" Nil) :: List String) - (TkListLen 3 $ TkWord 0 $ TkString "foo" $ - TkListLen 3 $ TkWord 0 $ TkString "bar" $ + (TkListLen 3 $ TkWord 0 $ tkStr "foo" $ + TkListLen 3 $ TkWord 0 $ tkStr "bar" $ TkListLen 1 $ TkWord 1 $ TkEnd) ] + where tkStr = TkUtf8ByteArray . fromList . map (fromIntegral . ord) + -------------------------------------------------------------------------------- -- Extra machinery @@ -366,3 +392,25 @@ where cnv :: [a] -> List a cnv = foldr Cons Nil + +newtype BytesByteArray = BytesBA CBOR.BA.ByteArray + deriving (Eq, Ord, Show) + +instance Serialise BytesByteArray where + encode (BytesBA ba) = encodeByteArray $ CBOR.BA.toSliced ba + decode = BytesBA <$> decodeByteArray + +instance Arbitrary BytesByteArray where + arbitrary = BytesBA . fromList <$> arbitrary + +newtype Utf8ByteArray = Utf8BA CBOR.BA.ByteArray + deriving (Eq, Ord, Show) + +instance Serialise Utf8ByteArray where + encode (Utf8BA ba) = encodeUtf8ByteArray $ CBOR.BA.toSliced ba + decode = Utf8BA <$> decodeUtf8ByteArray + +instance Arbitrary Utf8ByteArray where + arbitrary = do + BSS.SBS ba <- BSS.toShort . Text.encodeUtf8 <$> arbitrary + return $ Utf8BA $ CBOR.BA.BA $ Prim.ByteArray ba diff --git a/tests/Tests/Serialise/Canonical.hs b/tests/Tests/Serialise/Canonical.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Serialise/Canonical.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +module Tests.Serialise.Canonical where + +import Data.Bits +import Data.Int +import Data.Typeable +import Data.Word +import Test.QuickCheck + +import Codec.CBOR.Decoding +import Codec.CBOR.Encoding as E +import Codec.Serialise.Class + +newtype Canonical a = Canonical { fromCanonical :: a } + deriving (Typeable, Eq, Show) + +-- | Generate "proper" big integers (as standard Arbitrary Integer instance +-- doesn't really do that) to test canonicity. +instance Arbitrary (Canonical Integer) where + arbitrary = do + c <- choose (1, 5) + neg <- arbitrary + Canonical . (if neg then negate else id) . foldr combine 0 + <$> vectorOf c arbitrary + where + combine :: Word64 -> Integer -> Integer + combine v acc = (acc `shiftL` finiteBitSize v) + toInteger v + +deriving instance Arbitrary (Canonical Word) +deriving instance Arbitrary (Canonical Word8) +deriving instance Arbitrary (Canonical Word16) +deriving instance Arbitrary (Canonical Word32) +deriving instance Arbitrary (Canonical Word64) +deriving instance Arbitrary (Canonical Int) +deriving instance Arbitrary (Canonical Int8) +deriving instance Arbitrary (Canonical Int16) +deriving instance Arbitrary (Canonical Int32) +deriving instance Arbitrary (Canonical Int64) +deriving instance Arbitrary (Canonical Float) +deriving instance Arbitrary (Canonical Double) + +---------------------------------------- + +instance Serialise (Canonical Word) where + encode = encodeWord . fromCanonical + decode = Canonical <$> decodeWordCanonical + +instance Serialise (Canonical Word8) where + encode = encodeWord8 . fromCanonical + decode = Canonical <$> decodeWord8Canonical + +instance Serialise (Canonical Word16) where + encode = encodeWord16 . fromCanonical + decode = Canonical <$> decodeWord16Canonical + +instance Serialise (Canonical Word32) where + encode = encodeWord32 . fromCanonical + decode = Canonical <$> decodeWord32Canonical + +instance Serialise (Canonical Word64) where + encode = encodeWord64 . fromCanonical + decode = Canonical <$> decodeWord64Canonical + +instance Serialise (Canonical Int) where + encode = encodeInt . fromCanonical + decode = Canonical <$> decodeIntCanonical + +instance Serialise (Canonical Int8) where + encode = encodeInt8 . fromCanonical + decode = Canonical <$> decodeInt8Canonical + +instance Serialise (Canonical Int16) where + encode = encodeInt16 . fromCanonical + decode = Canonical <$> decodeInt16Canonical + +instance Serialise (Canonical Int32) where + encode = encodeInt32 . fromCanonical + decode = Canonical <$> decodeInt32Canonical + +instance Serialise (Canonical Int64) where + encode = encodeInt64 . fromCanonical + decode = Canonical <$> decodeInt64Canonical + +instance Serialise (Canonical Integer) where + encode = encodeInteger . fromCanonical + decode = Canonical <$> decodeIntegerCanonical + +instance Serialise (Canonical Float) where + encode = E.encodeFloat . fromCanonical + decode = Canonical <$> decodeFloatCanonical + +instance Serialise (Canonical Double) where + encode = encodeDouble . fromCanonical + decode = Canonical <$> decodeDoubleCanonical diff --git a/tests/test-vectors/appendix_a.json b/tests/test-vectors/appendix_a.json --- a/tests/test-vectors/appendix_a.json +++ b/tests/test-vectors/appendix_a.json @@ -210,12 +210,6 @@ "diagnostic": "Infinity" }, { - "cbor": "+n/AAAA=", - "hex": "fa7fc00000", - "roundtrip": false, - "diagnostic": "NaN" - }, - { "cbor": "+v+AAAA=", "hex": "faff800000", "roundtrip": false, @@ -226,12 +220,6 @@ "hex": "fb7ff0000000000000", "roundtrip": false, "diagnostic": "Infinity" - }, - { - "cbor": "+3/4AAAAAAAA", - "hex": "fb7ff8000000000000", - "roundtrip": false, - "diagnostic": "NaN" }, { "cbor": "+//wAAAAAAAA",