diff --git a/cborg.cabal b/cborg.cabal --- a/cborg.cabal +++ b/cborg.cabal @@ -1,5 +1,5 @@ name: cborg -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Concise Binary Object Representation license: BSD3 license-file: LICENSE.txt @@ -17,11 +17,15 @@ description: This package (formerly @binary-serialise-cbor@) provides an efficient implementation of the Concise Binary Object Representation (CBOR), as - specified by RFC 7049. + specified by [RFC 7049](https://tools.ietf.org/html/rfc7049). . If you are looking for a library for serialisation of Haskell values, - have a look at the @serialise@ package, which is built upon this library. - + have a look at the [serialise](/package/serialise) package, which is + built upon this library. + . + 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. extra-source-files: src/cbits/cbor.h @@ -56,6 +60,11 @@ Codec.CBOR.Read Codec.CBOR.Write Codec.CBOR.Term + Codec.CBOR.ByteArray + Codec.CBOR.ByteArray.Sliced + + other-modules: + Codec.CBOR.ByteArray.Internal other-extensions: CPP, ForeignFunctionInterface, MagicHash, diff --git a/src/Codec/CBOR.hs b/src/Codec/CBOR.hs --- a/src/Codec/CBOR.hs +++ b/src/Codec/CBOR.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- | -- Module : Codec.CBOR -- Copyright : (c) Duncan Coutts 2015-2017 @@ -10,5 +12,102 @@ -- A library for working with CBOR. -- module Codec.CBOR - ( + ( -- $intro + -- * Library Structure + -- $structure ) where + +-- used by Haddocks +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import Codec.CBOR.FlatTerm (FlatTerm) +import Codec.CBOR.Term (Term, encodeTerm, decodeTerm) + +{- $intro + +The @cborg@ library is a low-level parsing and encoding library for the +Compact Binary Object Representation (CBOR) defined in RFC 7049. CBOR is a +language-agnostic, extensible, and size- and computation-efficient encoding +for arbitrary data, with a well-defined bijection to the ubiquitous JSON format +and a precisely specified canonical form. + +Note, however, that @cborg@ does not itself aim to be a serialisation +library; it merely serves as the substrate on which such a library might be +built. See the [serialise](/package/serialise) library if you are looking for +convenient serialisation of Haskell values. + +Instead, @cborg@ targets cases where precise control over the CBOR object +structure is needed such as when working with externally-specified CBOR formats. + +-} + +{- $structure + +The library is split into a number of modules, + +* Decoding + + * "Codec.CBOR.Decoding" defines the machinery for decoding primitive CBOR terms + into Haskell values. In particular, the 'Decoder' type and associated decoders, + + @ + data 'Decoder' s a + + -- for, e.g., safe in-place mutation during decoding + liftST :: ST s a -> 'Decoder' s a + + -- primitive decoders + decodeWord :: 'Decoder' s Word + decodeBytes :: 'Decoder' s ByteString + -- et cetera + @ + * "Codec.CBOR.Read" defines the low-level wire-format decoder, e.g. + + @ + 'Codec.CBOR.Read.deserialiseFromBytes' :: 'Decoder' a + -> ByteString + -> Either String (ByteString, a) + @ + +* Encoding + + * "Codec.CBOR.Encoding" defines the 'Encoding' type, which is in essence + difference-list of CBOR tokens and is used to construct CBOR encodings. + + @ + data 'Encoding' + instance Monoid 'Encoding' + + encodeWord :: Word -> Encoding + encodeBytes :: ByteString -> Encoding + -- et cetera + @ + + * "Codec.CBOR.Write" defines the low-level wire-format encoder, e.g. + + @ + 'Codec.CBOR.Write.toBuilder' :: 'Encoding' a -> Data.ByteString.Builder.Builder + @ + +* Capturing arbitrary terms + + * "Codec.CBOR.Term" provides the 'Term' type, which provides a type for + capturing arbitrary CBOR terms. 'Term's can be encoded and decoded with, + + @ + data 'Term' + = TInt Int + | TBytes ByteString + -- et cetera + + 'encodeTerm' :: 'Term' -> 'Encoding' + 'decodeTerm' :: 'Decoder' 'Term' + @ + +* Debugging + + * "Codec.CBOR.FlatTerm" contains the 'FlatTerm' type, which provides a + concrete AST for capturing primitive CBOR wire encodings. This can be + useful when testing decoders and encoders. + +-} diff --git a/src/Codec/CBOR/ByteArray.hs b/src/Codec/CBOR/ByteArray.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/ByteArray.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Codec.CBOR.ByteArray +-- Copyright : (c) Ben Gamari 2017-2018 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- A ByteArray with more instances than 'Data.Primitive.ByteArray.ByteArray'. +-- Some day when these instances are reliably available from @primitive@ we can +-- likely replace this with 'Data.Primitive.ByteArray.ByteArray'. +-- +module Codec.CBOR.ByteArray + ( -- * Simple byte arrays + ByteArray(..) + , sizeofByteArray + -- * Conversions + , fromShortByteString + , toShortByteString + , fromByteString + , toBuilder + , toSliced + ) where + +import Data.Char (ord) +import Data.Word +import GHC.Exts (IsList(..), IsString(..)) + +import qualified Data.Primitive.ByteArray as Prim +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString.Short.Internal as BSS +import qualified Data.ByteString.Builder as BSB + +import qualified Codec.CBOR.ByteArray.Sliced as Sliced +import Codec.CBOR.ByteArray.Internal + +newtype ByteArray = BA {unBA :: Prim.ByteArray} + +sizeofByteArray :: ByteArray -> Int +{-# INLINE sizeofByteArray #-} +sizeofByteArray (BA ba) = Prim.sizeofByteArray ba + +fromShortByteString :: BSS.ShortByteString -> ByteArray +fromShortByteString (BSS.SBS ba) = BA (Prim.ByteArray ba) + +toShortByteString :: ByteArray -> BSS.ShortByteString +toShortByteString (BA (Prim.ByteArray ba)) = BSS.SBS ba + +fromByteString :: BS.ByteString -> ByteArray +fromByteString = fromShortByteString . BSS.toShort + +toBuilder :: ByteArray -> BSB.Builder +toBuilder = Sliced.toBuilder . toSliced + +toSliced :: ByteArray -> Sliced.SlicedByteArray +toSliced ba@(BA arr) = Sliced.SBA arr 0 (sizeofByteArray ba) + +instance Show ByteArray where + showsPrec _ = shows . toSliced + +instance Eq ByteArray where + ba1 == ba2 = toSliced ba1 == toSliced ba2 + +instance Ord ByteArray where + ba1 `compare` ba2 = toSliced ba1 `compare` toSliced ba2 + +instance IsString ByteArray where + fromString = fromList . map checkedOrd + where + checkedOrd c + | c > '\xff' = error "IsString(Codec.CBOR.ByteArray): Non-ASCII character" + | otherwise = fromIntegral $ ord c + +instance IsList ByteArray where + type Item ByteArray = Word8 + fromList xs = fromListN (Prelude.length xs) xs + fromListN n xs = + let arr = mkByteArray n xs + in BA arr + toList ba@(BA arr) = + foldrByteArray (:) [] 0 (sizeofByteArray ba) arr diff --git a/src/Codec/CBOR/ByteArray/Internal.hs b/src/Codec/CBOR/ByteArray/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/ByteArray/Internal.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Codec.CBOR.ByteArray.Internal +-- Copyright : (c) Ben Gamari 2017-2018 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Various bytearray utilities +-- +module Codec.CBOR.ByteArray.Internal + ( foldrByteArray + , copyToAddr + , isTrue# + , sameByteArray + , mkByteArray + , isByteArrayPinned + , touch + ) where + +import Control.Monad.ST +import Control.Monad +import GHC.IO (IO(..)) +import GHC.Exts +import GHC.Word + +import qualified Data.Primitive.ByteArray as Prim + +foldrByteArray :: (Word8 -> a -> a) -> a + -> Int -- ^ offset + -> Int -- ^ length + -> Prim.ByteArray -- ^ array + -> a +foldrByteArray f z off0 len ba = go off0 + where + go !off + | off == len = z + | otherwise = + let x = Prim.indexByteArray ba off + in f x (go (off+1)) + +copyToAddr :: Prim.ByteArray -> Int -> Ptr a -> Int -> IO () +copyToAddr (Prim.ByteArray ba) (I# off) (Ptr addr) (I# len) = + IO (\s -> case copyByteArrayToAddr# ba off addr len s of + s' -> (# s', () #)) + +#if __GLASGOW_HASKELL__ < 706 +isTrue# :: Bool -> Bool +isTrue# = id +#endif + +sameByteArray :: Prim.ByteArray -> Prim.ByteArray -> Bool +sameByteArray (Prim.ByteArray ba1#) (Prim.ByteArray ba2#) = + case reallyUnsafePtrEquality# (unsafeCoerce# ba1# :: ()) (unsafeCoerce# ba2# :: ()) of + r -> isTrue# r + +-- | @mkByteArray n xs@ forms a 'Prim.ByteArray' with contents @xs@. Note that +-- @n@ must be the precise length of @xs@. +mkByteArray :: Int -> [Word8] -> Prim.ByteArray +mkByteArray n xs = runST $ do + arr <- Prim.newByteArray n + zipWithM_ (Prim.writeByteArray arr) [0..n-1] (take n $ xs ++ repeat 0) + Prim.unsafeFreezeByteArray arr + +-- | A conservative estimate of pinned-ness. +isByteArrayPinned :: Prim.ByteArray -> Bool +isByteArrayPinned (Prim.ByteArray ba) = +#if __GLASGOW_HASKELL__ > 800 + case isByteArrayPinned# ba of + 0# -> False + _ -> True +#else + False +#endif + +touch :: a -> IO () +touch x = IO $ \s -> case touch# x s of s' -> (# s', () #) diff --git a/src/Codec/CBOR/ByteArray/Sliced.hs b/src/Codec/CBOR/ByteArray/Sliced.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/ByteArray/Sliced.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Codec.CBOR.ByteArray.Sliced +-- Copyright : (c) Ben Gamari 2017-2018 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- A ByteArray with more instances than 'Data.Primitive.ByteArray.ByteArray'. +-- Some day when these instances are reliably available from @primitive@ we can +-- likely replace this with 'Data.Primitive.ByteArray.ByteArray'. +-- +module Codec.CBOR.ByteArray.Sliced + ( SlicedByteArray(..) + -- * Conversions + , sizeofSlicedByteArray + , fromShortByteString + , fromByteString + , fromByteArray + , toByteString + , toBuilder + ) where + +import GHC.Exts +import Data.Char (chr, ord) +import Data.Word +import Foreign.Ptr +import Control.Monad.ST +import System.IO.Unsafe + +import qualified Data.Primitive.ByteArray as Prim +import Data.Primitive.Types (Addr(..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString.Short.Internal as BSS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Builder.Internal as BSB + +import Codec.CBOR.ByteArray.Internal + +data SlicedByteArray = SBA {unSBA :: !Prim.ByteArray, offset :: !Int, length :: !Int} + +fromShortByteString :: BSS.ShortByteString -> SlicedByteArray +fromShortByteString (BSS.SBS ba) = fromByteArray (Prim.ByteArray ba) + +fromByteString :: BS.ByteString -> SlicedByteArray +fromByteString = fromShortByteString . BSS.toShort + +fromByteArray :: Prim.ByteArray -> SlicedByteArray +fromByteArray ba = SBA ba 0 (Prim.sizeofByteArray ba) + +sizeofSlicedByteArray :: SlicedByteArray -> Int +sizeofSlicedByteArray (SBA _ _ len) = len + +-- | Note that this may require a copy. +toByteString :: SlicedByteArray -> BS.ByteString +toByteString sba = + unsafePerformIO + $ BS.unsafePackCStringFinalizer ptr (sizeofSlicedByteArray sba) (touch pinned) + where + pinned = toPinned sba + !(Addr addr#) = Prim.byteArrayContents pinned + ptr = Ptr addr# + +toPinned :: SlicedByteArray -> Prim.ByteArray +toPinned (SBA ba off len) + | isByteArrayPinned ba = ba + | otherwise = runST $ do + ba' <- Prim.newPinnedByteArray len + Prim.copyByteArray ba' 0 ba off len + Prim.unsafeFreezeByteArray ba' + +toBuilder :: SlicedByteArray -> BSB.Builder +toBuilder = \(SBA ba off len) -> BSB.builder (go ba off len) + where + go ba !ip !ipe !k (BSB.BufferRange op ope) + | inpRemaining <= outRemaining = do + copyToAddr ba ip op inpRemaining + let !br' = BSB.BufferRange (op `plusPtr` inpRemaining) ope + k br' + | otherwise = do + copyToAddr ba ip op outRemaining + let !ip' = ip + outRemaining + return $ BSB.bufferFull 1 ope (go ba ip' ipe k) + where + outRemaining = ope `minusPtr` op + inpRemaining = ipe - ip + +instance IsString SlicedByteArray where + fromString = fromList . map checkedOrd + where + checkedOrd c + | c > '\xff' = error "IsString(Codec.CBOR.ByteArray.Sliced): Non-ASCII character" + | otherwise = fromIntegral $ ord c + +instance IsList SlicedByteArray where + type Item SlicedByteArray = Word8 + fromList xs = fromListN (Prelude.length xs) xs + -- Note that we make no attempt to behave sensibly if @n /= length xs@. + -- The class definition allows this. + fromListN n xs = + let arr = mkByteArray n xs + in SBA arr 0 n + toList (SBA arr off len) = + foldrByteArray (:) [] off len arr + +instance Show SlicedByteArray where + showsPrec _ = shows . map (chr . fromIntegral) . toList + +instance Eq SlicedByteArray where + SBA arr1 off1 len1 == SBA arr2 off2 len2 + | len1 /= len2 + = False + + | sameByteArray arr1 arr2 + , off1 == off2 + , len1 == len2 + = True + + | otherwise + = let (!) :: Prim.ByteArray -> Int -> Word8 + (!) = Prim.indexByteArray + go i1 i2 + | i1 == len1 && i2 == len2 = True + | i1 == len1 || i2 == len2 = False + | (arr1 ! i1) == (arr2 ! i2) = go (i1+1) (i2+1) + | otherwise = False + in go off1 off2 + +instance Ord SlicedByteArray where + SBA arr1 off1 len1 `compare` SBA arr2 off2 len2 + | sameByteArray arr1 arr2 + , off1 == off2 + , len1 == len2 + = EQ + + | otherwise + = let (!) :: Prim.ByteArray -> Int -> Word8 + (!) = Prim.indexByteArray + go i1 i2 + | i1 == len1 && i2 == len2 = EQ + | i1 == len1 || i2 == len2 = len1 `compare` len2 + | EQ <- o = go (i1+1) (i2+1) + | otherwise = o + where o = (arr1 ! i1) `compare` (arr2 ! i2) + in go off1 off2 diff --git a/src/Codec/CBOR/Decoding.hs b/src/Codec/CBOR/Decoding.hs --- a/src/Codec/CBOR/Decoding.hs +++ b/src/Codec/CBOR/Decoding.hs @@ -36,26 +36,51 @@ , decodeInt16 -- :: Decoder s Int16 , decodeInt32 -- :: Decoder s Int32 , decodeInt64 -- :: Decoder s Int64 + , decodeWordCanonical -- :: Decoder s Word + , decodeWord8Canonical -- :: Decoder s Word8 + , decodeWord16Canonical -- :: Decoder s Word16 + , decodeWord32Canonical -- :: Decoder s Word32 + , decodeWord64Canonical -- :: Decoder s Word64 + , decodeNegWordCanonical -- :: Decoder s Word + , decodeNegWord64Canonical -- :: Decoder s Word64 + , decodeIntCanonical -- :: Decoder s Int + , decodeInt8Canonical -- :: Decoder s Int8 + , decodeInt16Canonical -- :: Decoder s Int16 + , decodeInt32Canonical -- :: Decoder s Int32 + , decodeInt64Canonical -- :: Decoder s Int64 , decodeInteger -- :: Decoder s Integer , decodeFloat -- :: Decoder s Float , 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 + , decodeListLenCanonical -- :: Decoder s Int , decodeListLenIndef -- :: Decoder s () , decodeMapLen -- :: Decoder s Int + , decodeMapLenCanonical -- :: Decoder s Int , decodeMapLenIndef -- :: Decoder s () , decodeTag -- :: Decoder s Word , decodeTag64 -- :: Decoder s Word64 + , decodeTagCanonical -- :: Decoder s Word + , decodeTag64Canonical -- :: Decoder s Word64 , decodeBool -- :: Decoder s Bool , decodeNull -- :: Decoder s () , decodeSimple -- :: Decoder s Word8 + , decodeIntegerCanonical -- :: Decoder s Integer + , decodeFloat16Canonical -- :: Decoder s Float + , decodeFloatCanonical -- :: Decoder s Float + , decodeDoubleCanonical -- :: Decoder s Double + , decodeSimpleCanonical -- :: Decoder s Word8 -- ** Specialised Read input token operations , decodeWordOf -- :: Word -> Decoder s () , decodeListLenOf -- :: Int -> Decoder s () + , decodeWordCanonicalOf -- :: Word -> Decoder s () + , decodeListLenCanonicalOf -- :: Int -> Decoder s () -- ** Branching operations --, decodeBytesOrIndef @@ -89,6 +114,8 @@ import Control.Monad.ST import qualified Control.Monad.Fail as Fail +import Codec.CBOR.ByteArray (ByteArray) + import Prelude hiding (decodeFloat) @@ -121,6 +148,19 @@ | ConsumeMapLen (Int# -> ST s (DecodeAction s a)) | ConsumeTag (Word# -> ST s (DecodeAction s a)) + | ConsumeWordCanonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord8Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord16Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeWord32Canonical (Word# -> ST s (DecodeAction s a)) + | ConsumeNegWordCanonical (Word# -> ST s (DecodeAction s a)) + | ConsumeIntCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt8Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt16Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeInt32Canonical (Int# -> ST s (DecodeAction s a)) + | ConsumeListLenCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeMapLenCanonical (Int# -> ST s (DecodeAction s a)) + | ConsumeTagCanonical (Word# -> ST s (DecodeAction s a)) + -- 64bit variants for 32bit machines #if defined(ARCH_32bit) | ConsumeWord64 (Word64# -> ST s (DecodeAction s a)) @@ -129,16 +169,31 @@ | ConsumeListLen64 (Int64# -> ST s (DecodeAction s a)) | ConsumeMapLen64 (Int64# -> ST s (DecodeAction s a)) | ConsumeTag64 (Word64# -> ST s (DecodeAction s a)) + + | ConsumeWord64Canonical (Word64# -> ST s (DecodeAction s a)) + | ConsumeNegWord64Canonical (Word64# -> ST s (DecodeAction s a)) + | ConsumeInt64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeListLen64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeMapLen64Canonical (Int64# -> ST s (DecodeAction s a)) + | ConsumeTag64Canonical (Word64# -> ST s (DecodeAction s a)) #endif - | ConsumeInteger (Integer -> ST s (DecodeAction s a)) - | ConsumeFloat (Float# -> ST s (DecodeAction s a)) - | ConsumeDouble (Double# -> ST s (DecodeAction s a)) - | ConsumeBytes (ByteString -> ST s (DecodeAction s a)) - | ConsumeString (Text -> ST s (DecodeAction s a)) - | ConsumeBool (Bool -> ST s (DecodeAction s a)) - | ConsumeSimple (Word# -> ST s (DecodeAction s a)) + | ConsumeInteger (Integer -> ST s (DecodeAction s a)) + | ConsumeFloat (Float# -> ST s (DecodeAction s a)) + | ConsumeDouble (Double# -> ST s (DecodeAction s a)) + | ConsumeBytes (ByteString-> ST s (DecodeAction s a)) + | ConsumeByteArray (ByteArray -> ST s (DecodeAction s a)) + | ConsumeString (Text -> ST s (DecodeAction s a)) + | ConsumeUtf8ByteArray (ByteArray -> ST s (DecodeAction s a)) + | ConsumeBool (Bool -> ST s (DecodeAction s a)) + | ConsumeSimple (Word# -> ST s (DecodeAction s a)) + | ConsumeIntegerCanonical (Integer -> ST s (DecodeAction s a)) + | ConsumeFloat16Canonical (Float# -> ST s (DecodeAction s a)) + | ConsumeFloatCanonical (Float# -> ST s (DecodeAction s a)) + | ConsumeDoubleCanonical (Double# -> ST s (DecodeAction s a)) + | ConsumeSimpleCanonical (Word# -> ST s (DecodeAction s a)) + | ConsumeBytesIndef (ST s (DecodeAction s a)) | ConsumeStringIndef (ST s (DecodeAction s a)) | ConsumeListLenIndef (ST s (DecodeAction s a)) @@ -220,6 +275,10 @@ instance Fail.MonadFail (Decoder s) where fail msg = Decoder $ \_ -> return (Fail msg) +-- | Lift an @ST@ action into a @Decoder@. Useful for, e.g., leveraging +-- in-place mutation to efficiently build a deserialised value. +-- +-- @since 0.2.0.0 liftST :: ST s a -> Decoder s a liftST m = Decoder $ \k -> m >>= k @@ -333,6 +392,105 @@ Decoder (\k -> return (ConsumeInt64 (\n64# -> k (I64# n64#)))) #endif +-- | Decode canonical representation of a @'Word'@. +-- +-- @since 0.2.0.0 +decodeWordCanonical :: Decoder s Word +decodeWordCanonical = Decoder (\k -> return (ConsumeWordCanonical (\w# -> k (W# w#)))) +{-# INLINE decodeWordCanonical #-} + +-- | Decode canonical representation of a @'Word8'@. +-- +-- @since 0.2.0.0 +decodeWord8Canonical :: Decoder s Word8 +decodeWord8Canonical = Decoder (\k -> return (ConsumeWord8Canonical (\w# -> k (W8# w#)))) +{-# INLINE decodeWord8Canonical #-} + +-- | Decode canonical representation of a @'Word16'@. +-- +-- @since 0.2.0.0 +decodeWord16Canonical :: Decoder s Word16 +decodeWord16Canonical = Decoder (\k -> return (ConsumeWord16Canonical (\w# -> k (W16# w#)))) +{-# INLINE decodeWord16Canonical #-} + +-- | Decode canonical representation of a @'Word32'@. +-- +-- @since 0.2.0.0 +decodeWord32Canonical :: Decoder s Word32 +decodeWord32Canonical = Decoder (\k -> return (ConsumeWord32Canonical (\w# -> k (W32# w#)))) +{-# INLINE decodeWord32Canonical #-} + +-- | Decode canonical representation of a @'Word64'@. +-- +-- @since 0.2.0.0 +decodeWord64Canonical :: Decoder s Word64 +{-# INLINE decodeWord64Canonical #-} +decodeWord64Canonical = +#if defined(ARCH_64bit) + Decoder (\k -> return (ConsumeWordCanonical (\w# -> k (W64# w#)))) +#else + Decoder (\k -> return (ConsumeWord64Canonical (\w64# -> k (W64# w64#)))) +#endif + +-- | Decode canonical representation of a negative @'Word'@. +-- +-- @since 0.2.0.0 +decodeNegWordCanonical :: Decoder s Word +decodeNegWordCanonical = Decoder (\k -> return (ConsumeNegWordCanonical (\w# -> k (W# w#)))) +{-# INLINE decodeNegWordCanonical #-} + +-- | Decode canonical representation of a negative @'Word64'@. +-- +-- @since 0.2.0.0 +decodeNegWord64Canonical :: Decoder s Word64 +{-# INLINE decodeNegWord64Canonical #-} +decodeNegWord64Canonical = +#if defined(ARCH_64bit) + Decoder (\k -> return (ConsumeNegWordCanonical (\w# -> k (W64# w#)))) +#else + Decoder (\k -> return (ConsumeNegWord64Canonical (\w64# -> k (W64# w64#)))) +#endif + +-- | Decode canonical representation of an @'Int'@. +-- +-- @since 0.2.0.0 +decodeIntCanonical :: Decoder s Int +decodeIntCanonical = Decoder (\k -> return (ConsumeIntCanonical (\n# -> k (I# n#)))) +{-# INLINE decodeIntCanonical #-} + +-- | Decode canonical representation of an @'Int8'@. +-- +-- @since 0.2.0.0 +decodeInt8Canonical :: Decoder s Int8 +decodeInt8Canonical = Decoder (\k -> return (ConsumeInt8Canonical (\w# -> k (I8# w#)))) +{-# INLINE decodeInt8Canonical #-} + +-- | Decode canonical representation of an @'Int16'@. +-- +-- @since 0.2.0.0 +decodeInt16Canonical :: Decoder s Int16 +decodeInt16Canonical = Decoder (\k -> return (ConsumeInt16Canonical (\w# -> k (I16# w#)))) +{-# INLINE decodeInt16Canonical #-} + +-- | Decode canonical representation of an @'Int32'@. +-- +-- @since 0.2.0.0 +decodeInt32Canonical :: Decoder s Int32 +decodeInt32Canonical = Decoder (\k -> return (ConsumeInt32Canonical (\w# -> k (I32# w#)))) +{-# INLINE decodeInt32Canonical #-} + +-- | Decode canonical representation of an @'Int64'@. +-- +-- @since 0.2.0.0 +decodeInt64Canonical :: Decoder s Int64 +{-# INLINE decodeInt64Canonical #-} +decodeInt64Canonical = +#if defined(ARCH_64bit) + Decoder (\k -> return (ConsumeIntCanonical (\n# -> k (I64# n#)))) +#else + Decoder (\k -> return (ConsumeInt64Canonical (\n64# -> k (I64# n64#)))) +#endif + -- | Decode an @'Integer'@. -- -- @since 0.2.0.0 @@ -369,6 +527,17 @@ decodeBytesIndef = Decoder (\k -> return (ConsumeBytesIndef (k ()))) {-# INLINE decodeBytesIndef #-} +-- | Decode a string of bytes as a 'ByteArray'. +-- +-- Also note that this will eagerly copy the content out of the input +-- to ensure that the input does not leak in the event that the 'ByteArray' is +-- live but not forced. +-- +-- @since 0.2.0.0 +decodeByteArray :: Decoder s ByteArray +decodeByteArray = Decoder (\k -> return (ConsumeByteArray k)) +{-# INLINE decodeByteArray #-} + -- | Decode a textual string as a piece of @'Text'@. -- -- @since 0.2.0.0 @@ -384,6 +553,18 @@ decodeStringIndef = Decoder (\k -> return (ConsumeStringIndef (k ()))) {-# INLINE decodeStringIndef #-} +-- | Decode a textual string as UTF-8 encoded 'ByteArray'. Note that +-- the result is not validated to be well-formed UTF-8. +-- +-- Also note that this will eagerly copy the content out of the input +-- to ensure that the input does not leak in the event that the 'ByteArray' is +-- live but not forced. +-- +-- @since 0.2.0.0 +decodeUtf8ByteArray :: Decoder s ByteArray +decodeUtf8ByteArray = Decoder (\k -> return (ConsumeUtf8ByteArray k)) +{-# INLINE decodeUtf8ByteArray #-} + -- | Decode the length of a list. -- -- @since 0.2.0.0 @@ -391,6 +572,13 @@ decodeListLen = Decoder (\k -> return (ConsumeListLen (\n# -> k (I# n#)))) {-# INLINE decodeListLen #-} +-- | Decode canonical representation of the length of a list. +-- +-- @since 0.2.0.0 +decodeListLenCanonical :: Decoder s Int +decodeListLenCanonical = Decoder (\k -> return (ConsumeListLenCanonical (\n# -> k (I# n#)))) +{-# INLINE decodeListLenCanonical #-} + -- | Decode a token marking the beginning of a list of indefinite -- length. -- @@ -406,6 +594,13 @@ decodeMapLen = Decoder (\k -> return (ConsumeMapLen (\n# -> k (I# n#)))) {-# INLINE decodeMapLen #-} +-- | Decode canonical representation of the length of a map. +-- +-- @since 0.2.0.0 +decodeMapLenCanonical :: Decoder s Int +decodeMapLenCanonical = Decoder (\k -> return (ConsumeMapLenCanonical (\n# -> k (I# n#)))) +{-# INLINE decodeMapLenCanonical #-} + -- | Decode a token marking the beginning of a map of indefinite -- length. -- @@ -433,6 +628,27 @@ Decoder (\k -> return (ConsumeTag64 (\w64# -> k (W64# w64#)))) #endif +-- | Decode canonical representation of an arbitrary tag and return it as a +-- @'Word'@. +-- +-- @since 0.2.0.0 +decodeTagCanonical :: Decoder s Word +decodeTagCanonical = Decoder (\k -> return (ConsumeTagCanonical (\w# -> k (W# w#)))) +{-# INLINE decodeTagCanonical #-} + +-- | Decode canonical representation of an arbitrary 64-bit tag and return it as +-- a @'Word64'@. +-- +-- @since 0.2.0.0 +decodeTag64Canonical :: Decoder s Word64 +{-# INLINE decodeTag64Canonical #-} +decodeTag64Canonical = +#if defined(ARCH_64bit) + Decoder (\k -> return (ConsumeTagCanonical (\w# -> k (W64# w#)))) +#else + Decoder (\k -> return (ConsumeTag64Canonical (\w64# -> k (W64# w64#)))) +#endif + -- | Decode a bool. -- -- @since 0.2.0.0 @@ -455,7 +671,42 @@ decodeSimple = Decoder (\k -> return (ConsumeSimple (\w# -> k (W8# w#)))) {-# INLINE decodeSimple #-} +-- | Decode canonical representation of an @'Integer'@. +-- +-- @since 0.2.0.0 +decodeIntegerCanonical :: Decoder s Integer +decodeIntegerCanonical = Decoder (\k -> return (ConsumeIntegerCanonical (\n -> k n))) +{-# INLINE decodeIntegerCanonical #-} +-- | Decode canonical representation of a half-precision @'Float'@. +-- +-- @since 0.2.0.0 +decodeFloat16Canonical :: Decoder s Float +decodeFloat16Canonical = Decoder (\k -> return (ConsumeFloat16Canonical (\f# -> k (F# f#)))) +{-# INLINE decodeFloat16Canonical #-} + +-- | Decode canonical representation of a @'Float'@. +-- +-- @since 0.2.0.0 +decodeFloatCanonical :: Decoder s Float +decodeFloatCanonical = Decoder (\k -> return (ConsumeFloatCanonical (\f# -> k (F# f#)))) +{-# INLINE decodeFloatCanonical #-} + +-- | Decode canonical representation of a @'Double'@. +-- +-- @since 0.2.0.0 +decodeDoubleCanonical :: Decoder s Double +decodeDoubleCanonical = Decoder (\k -> return (ConsumeDoubleCanonical (\f# -> k (D# f#)))) +{-# INLINE decodeDoubleCanonical #-} + +-- | Decode canonical representation of a 'simple' CBOR value and give back a +-- @'Word8'@. You probably don't ever need to use this. +-- +-- @since 0.2.0.0 +decodeSimpleCanonical :: Decoder s Word8 +decodeSimpleCanonical = Decoder (\k -> return (ConsumeSimpleCanonical (\w# -> k (W8# w#)))) +{-# INLINE decodeSimpleCanonical #-} + -------------------------------------------------------------- -- Specialised read operations: expect a token with a specific value -- @@ -466,10 +717,7 @@ -- @since 0.2.0.0 decodeWordOf :: Word -- ^ Expected value of the decoded word -> Decoder s () -decodeWordOf n = do - n' <- decodeWord - if n == n' then return () - else fail $ "expected word " ++ show n +decodeWordOf = decodeWordOfHelper decodeWord {-# INLINE decodeWordOf #-} -- | Attempt to decode a list length using @'decodeListLen'@, and @@ -477,12 +725,40 @@ -- -- @since 0.2.0.0 decodeListLenOf :: Int -> Decoder s () -decodeListLenOf len = do - len' <- decodeListLen +decodeListLenOf = decodeListLenOfHelper decodeListLen +{-# INLINE decodeListLenOf #-} + +-- | Attempt to decode canonical representation of a word with @'decodeWordCanonical'@, +-- and ensure the word is exactly as expected, or fail. +-- +-- @since 0.2.0.0 +decodeWordCanonicalOf :: Word -- ^ Expected value of the decoded word + -> Decoder s () +decodeWordCanonicalOf = decodeWordOfHelper decodeWordCanonical +{-# INLINE decodeWordCanonicalOf #-} + +-- | Attempt to decode canonical representation of a list length using +-- @'decodeListLenCanonical'@, and ensure it is exactly the specified length, or +-- fail. +-- +-- @since 0.2.0.0 +decodeListLenCanonicalOf :: Int -> Decoder s () +decodeListLenCanonicalOf = decodeListLenOfHelper decodeListLenCanonical +{-# INLINE decodeListLenCanonicalOf #-} + +decodeListLenOfHelper :: (Show a, Eq a, Monad m) => m a -> a -> m () +decodeListLenOfHelper decodeFun = \len -> do + len' <- decodeFun if len == len' then return () else fail $ "expected list of length " ++ show len -{-# INLINE decodeListLenOf #-} +{-# INLINE decodeListLenOfHelper #-} +decodeWordOfHelper :: (Show a, Eq a, Monad m) => m a -> a -> m () +decodeWordOfHelper decodeFun = \n -> do + n' <- decodeFun + if n == n' then return () + else fail $ "expected word " ++ show n +{-# INLINE decodeWordOfHelper #-} -------------------------------------------------------------- -- Branching operations diff --git a/src/Codec/CBOR/Encoding.hs b/src/Codec/CBOR/Encoding.hs --- a/src/Codec/CBOR/Encoding.hs +++ b/src/Codec/CBOR/Encoding.hs @@ -31,8 +31,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 @@ -58,6 +60,8 @@ import qualified Data.ByteString as B import qualified Data.Text as T +import Codec.CBOR.ByteArray.Sliced (SlicedByteArray) + import Prelude hiding (encodeFloat) import {-# SOURCE #-} qualified Codec.CBOR.FlatTerm as FlatTerm @@ -95,10 +99,12 @@ | TkInt64 {-# UNPACK #-} !Int64 Tokens -- Bytes and string (type 2,3) - | TkBytes {-# UNPACK #-} !B.ByteString Tokens - | TkBytesBegin Tokens - | TkString {-# UNPACK #-} !T.Text Tokens - | TkStringBegin Tokens + | TkBytes {-# UNPACK #-} !B.ByteString Tokens + | TkBytesBegin Tokens + | TkByteArray {-# UNPACK #-} !SlicedByteArray Tokens + | TkString {-# UNPACK #-} !T.Text Tokens + | TkUtf8ByteArray {-# UNPACK #-} !SlicedByteArray Tokens + | TkStringBegin Tokens -- Structures (type 4,5) | TkListLen {-# UNPACK #-} !Word Tokens @@ -214,6 +220,12 @@ encodeBytes :: B.ByteString -> Encoding encodeBytes = Encoding . TkBytes +-- | Encode a bytestring in a flattened format. +-- +-- @since 0.2.0.0 +encodeByteArray :: SlicedByteArray -> Encoding +encodeByteArray = Encoding . TkByteArray + -- | Encode a token specifying the beginning of a string of bytes of -- indefinite length. In reality, this specifies a stream of many -- occurrences of `encodeBytes`, each specifying a single chunk of the @@ -235,6 +247,13 @@ -- @since 0.2.0.0 encodeStringIndef :: Encoding encodeStringIndef = Encoding TkStringBegin + +-- | Encode a UTF-8 string in a flattened format. Note that the contents +-- is not validated to be well-formed UTF-8. +-- +-- @since 0.2.0.0 +encodeUtf8ByteArray :: SlicedByteArray -> Encoding +encodeUtf8ByteArray = Encoding . TkUtf8ByteArray -- | Encode the length of a list, used to indicate that the following -- tokens represent the list values. diff --git a/src/Codec/CBOR/FlatTerm.hs b/src/Codec/CBOR/FlatTerm.hs --- a/src/Codec/CBOR/FlatTerm.hs +++ b/src/Codec/CBOR/FlatTerm.hs @@ -43,6 +43,8 @@ import Codec.CBOR.Encoding (Encoding(..)) import qualified Codec.CBOR.Encoding as Enc import Codec.CBOR.Decoding as Dec +import qualified Codec.CBOR.ByteArray as BA +import qualified Codec.CBOR.ByteArray.Sliced as BAS import Data.Int #if defined(ARCH_32bit) @@ -56,6 +58,7 @@ import Data.Word import Data.Text (Text) +import qualified Data.Text.Encoding as TE import Data.ByteString (ByteString) import Control.Monad.ST @@ -118,8 +121,12 @@ | otherwise = TkInteger n : convFlatTerm ts convFlatTerm (Enc.TkBytes bs ts) = TkBytes bs : convFlatTerm ts convFlatTerm (Enc.TkBytesBegin ts) = TkBytesBegin : convFlatTerm ts +convFlatTerm (Enc.TkByteArray a ts) + = TkBytes (BAS.toByteString a) : convFlatTerm ts convFlatTerm (Enc.TkString st ts) = TkString st : convFlatTerm ts convFlatTerm (Enc.TkStringBegin ts) = TkStringBegin : convFlatTerm ts +convFlatTerm (Enc.TkUtf8ByteArray a ts) + = TkString (TE.decodeUtf8 $ BAS.toByteString a) : convFlatTerm ts convFlatTerm (Enc.TkListLen n ts) = TkListLen n : convFlatTerm ts convFlatTerm (Enc.TkListBegin ts) = TkListBegin : convFlatTerm ts convFlatTerm (Enc.TkMapLen n ts) = TkMapLen n : convFlatTerm ts @@ -196,6 +203,52 @@ go (TkTag n : ts) (ConsumeTag k) | n <= maxWord = k (unW# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeWordCanonical k) + | n >= 0 = k (unW# (fromIntegral n)) >>= go ts + go (TkInteger n : ts) (ConsumeWordCanonical k) + | n >= 0 = k (unW# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeWord8Canonical k) + | n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts + go (TkInteger n : ts) (ConsumeWord8Canonical k) + | n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeWord16Canonical k) + | n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts + go (TkInteger n : ts) (ConsumeWord16Canonical k) + | n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeWord32Canonical k) + -- NOTE: we have to be very careful about this branch + -- on 32 bit machines, because maxBound :: Int < maxBound :: Word32 + | intIsValidWord32 n = k (unW# (fromIntegral n)) >>= go ts + go (TkInteger n : ts) (ConsumeWord32Canonical k) + | n >= 0 && n <= maxWord32 = k (unW# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeNegWordCanonical k) + | n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts + go (TkInteger n : ts) (ConsumeNegWordCanonical k) + | n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts + go (TkInt n : ts) (ConsumeIntCanonical k) = k (unI# n) >>= go ts + go (TkInteger n : ts) (ConsumeInt k) + | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeInt8Canonical k) + | n >= minInt8 && n <= maxInt8 = k (unI# n) >>= go ts + go (TkInteger n : ts) (ConsumeInt8Canonical k) + | n >= minInt8 && n <= maxInt8 = k (unI# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeInt16Canonical k) + | n >= minInt16 && n <= maxInt16 = k (unI# n) >>= go ts + go (TkInteger n : ts) (ConsumeInt16Canonical k) + | n >= minInt16 && n <= maxInt16 = k (unI# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeInt32Canonical k) + | n >= minInt32 && n <= maxInt32 = k (unI# n) >>= go ts + go (TkInteger n : ts) (ConsumeInt32Canonical k) + | n >= minInt32 && n <= maxInt32 = k (unI# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeIntegerCanonical k) = k (fromIntegral n) >>= go ts + go (TkInteger n : ts) (ConsumeIntegerCanonical k) = k n >>= go ts + go (TkListLen n : ts) (ConsumeListLenCanonical k) + | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts + go (TkMapLen n : ts) (ConsumeMapLenCanonical k) + | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts + go (TkTag n : ts) (ConsumeTagCanonical k) + | n <= maxWord = k (unW# (fromIntegral n)) >>= go ts + #if defined(ARCH_32bit) -- 64bit variants for 32bit machines go (TkInt n : ts) (ConsumeWord64 k) @@ -212,22 +265,47 @@ go (TkTag n : ts) (ConsumeTag64 k) = k (unW64# n) >>= go ts + go (TkInt n : ts) (ConsumeWord64Canonical k) + | n >= 0 = k (unW64# (fromIntegral n)) >>= go ts + go (TkInteger n : ts) (ConsumeWord64Canonical k) + | n >= 0 = k (unW64# (fromIntegral n)) >>= go ts + go (TkInt n : ts) (ConsumeNegWord64Canonical k) + | n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts + go (TkInteger n : ts) (ConsumeNegWord64Canonical k) + | n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts + + go (TkInt n : ts) (ConsumeInt64Canonical k) = k (unI64# (fromIntegral n)) >>= go ts + go (TkInteger n : ts) (ConsumeInt64Canonical k) = k (unI64# (fromIntegral n)) >>= go ts + + go (TkTag n : ts) (ConsumeTag64Canonical k) = k (unW64# n) >>= go ts + + -- TODO FIXME (aseipp/dcoutts): are these going to be utilized? -- see fallthrough case below if/when fixed. - go ts (ConsumeListLen64 _) = unexpected "decodeListLen64" ts - go ts (ConsumeMapLen64 _) = unexpected "decodeMapLen64" ts + go ts (ConsumeListLen64 _) = unexpected "decodeListLen64" ts + go ts (ConsumeMapLen64 _) = unexpected "decodeMapLen64" ts + go ts (ConsumeListLen64Canonical _) = unexpected "decodeListLen64Canonical" ts + go ts (ConsumeMapLen64Canonical _) = unexpected "decodeMapLen64Canonical" ts #endif - go (TkFloat16 f : ts) (ConsumeFloat k) = k (unF# f) >>= go ts - go (TkFloat32 f : ts) (ConsumeFloat k) = k (unF# f) >>= go ts - go (TkFloat16 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts - go (TkFloat32 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts - go (TkFloat64 f : ts) (ConsumeDouble k) = k (unD# f) >>= go ts - go (TkBytes bs : ts) (ConsumeBytes k) = k bs >>= go ts - go (TkString st : ts) (ConsumeString k) = k st >>= go ts - go (TkBool b : ts) (ConsumeBool k) = k b >>= go ts - go (TkSimple n : ts) (ConsumeSimple k) = k (unW8# n) >>= go ts + go (TkFloat16 f : ts) (ConsumeFloat k) = k (unF# f) >>= go ts + go (TkFloat32 f : ts) (ConsumeFloat k) = k (unF# f) >>= go ts + go (TkFloat16 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts + go (TkFloat32 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts + go (TkFloat64 f : ts) (ConsumeDouble k) = k (unD# f) >>= go ts + go (TkBytes bs : ts) (ConsumeBytes k) = k bs >>= go ts + go (TkBytes bs : ts) (ConsumeByteArray k) = k (BA.fromByteString bs) >>= go ts + go (TkString st : ts) (ConsumeString k) = k st >>= go ts + go (TkString st : ts) (ConsumeUtf8ByteArray k) = k (BA.fromByteString $ TE.encodeUtf8 st) + >>= go ts + go (TkBool b : ts) (ConsumeBool k) = k b >>= go ts + go (TkSimple n : ts) (ConsumeSimple k) = k (unW8# n) >>= go ts + go (TkFloat16 f : ts) (ConsumeFloat16Canonical k) = k (unF# f) >>= go ts + go (TkFloat32 f : ts) (ConsumeFloatCanonical k) = k (unF# f) >>= go ts + go (TkFloat64 f : ts) (ConsumeDoubleCanonical k) = k (unD# f) >>= go ts + go (TkSimple n : ts) (ConsumeSimpleCanonical k) = k (unW8# n) >>= go ts + go (TkBytesBegin : ts) (ConsumeBytesIndef da) = da >>= go ts go (TkStringBegin : ts) (ConsumeStringIndef da) = da >>= go ts go (TkListBegin : ts) (ConsumeListLenIndef da) = da >>= go ts @@ -269,13 +347,35 @@ go ts (ConsumeMapLen _) = unexpected "decodeMapLen" ts go ts (ConsumeTag _) = unexpected "decodeTag" ts + go ts (ConsumeWordCanonical _) = unexpected "decodeWordCanonical" ts + go ts (ConsumeWord8Canonical _) = unexpected "decodeWord8Canonical" ts + go ts (ConsumeWord16Canonical _) = unexpected "decodeWord16Canonical" ts + go ts (ConsumeWord32Canonical _) = unexpected "decodeWord32Canonical" ts + go ts (ConsumeNegWordCanonical _) = unexpected "decodeNegWordCanonical" ts + go ts (ConsumeIntCanonical _) = unexpected "decodeIntCanonical" ts + go ts (ConsumeInt8Canonical _) = unexpected "decodeInt8Canonical" ts + go ts (ConsumeInt16Canonical _) = unexpected "decodeInt16Canonical" ts + go ts (ConsumeInt32Canonical _) = unexpected "decodeInt32Canonical" ts + go ts (ConsumeIntegerCanonical _) = unexpected "decodeIntegerCanonical" ts + + go ts (ConsumeListLenCanonical _) = unexpected "decodeListLenCanonical" ts + go ts (ConsumeMapLenCanonical _) = unexpected "decodeMapLenCanonical" ts + go ts (ConsumeTagCanonical _) = unexpected "decodeTagCanonical" ts + go ts (ConsumeFloat _) = unexpected "decodeFloat" ts go ts (ConsumeDouble _) = unexpected "decodeDouble" ts go ts (ConsumeBytes _) = unexpected "decodeBytes" ts + go ts (ConsumeByteArray _) = unexpected "decodeByteArray" ts go ts (ConsumeString _) = unexpected "decodeString" ts + go ts (ConsumeUtf8ByteArray _) = unexpected "decodeUtf8ByteArray" ts go ts (ConsumeBool _) = unexpected "decodeBool" ts go ts (ConsumeSimple _) = unexpected "decodeSimple" ts + go ts (ConsumeFloat16Canonical _) = unexpected "decodeFloat16Canonical" ts + go ts (ConsumeFloatCanonical _) = unexpected "decodeFloatCanonical" ts + go ts (ConsumeDoubleCanonical _) = unexpected "decodeDoubleCanonical" ts + go ts (ConsumeSimpleCanonical _) = unexpected "decodeSimpleCanonical" ts + #if defined(ARCH_32bit) -- 64bit variants for 32bit machines go ts (ConsumeWord64 _) = unexpected "decodeWord64" ts @@ -284,6 +384,13 @@ go ts (ConsumeTag64 _) = unexpected "decodeTag64" ts --go ts (ConsumeListLen64 _) = unexpected "decodeListLen64" ts --go ts (ConsumeMapLen64 _) = unexpected "decodeMapLen64" ts + + go ts (ConsumeWord64Canonical _) = unexpected "decodeWord64Canonical" ts + go ts (ConsumeNegWord64Canonical _) = unexpected "decodeNegWord64Canonical" ts + go ts (ConsumeInt64Canonical _) = unexpected "decodeInt64Canonical" ts + go ts (ConsumeTag64Canonical _) = unexpected "decodeTag64Canonical" ts + --go ts (ConsumeListLen64Canonical _) = unexpected "decodeListLen64Canonical" ts + --go ts (ConsumeMapLen64Canonical _) = unexpected "decodeMapLen64Canonical" ts #endif go ts (ConsumeBytesIndef _) = unexpected "decodeBytesIndef" ts diff --git a/src/Codec/CBOR/Magic.hs b/src/Codec/CBOR/Magic.hs --- a/src/Codec/CBOR/Magic.hs +++ b/src/Codec/CBOR/Magic.hs @@ -236,13 +236,8 @@ -- with it. withBsPtr :: (Ptr b -> a) -> ByteString -> a withBsPtr f (BS.PS x off _) = -#if MIN_VERSION_bytestring(0,10,6) - BS.accursedUnutterablePerformIO $ withForeignPtr x $ - \(Ptr addr#) -> return $! (f (Ptr addr# `plusPtr` off)) -#else unsafeDupablePerformIO $ withForeignPtr x $ \(Ptr addr#) -> return $! (f (Ptr addr# `plusPtr` off)) -#endif {-# INLINE withBsPtr #-} -------------------------------------------------------------------------------- diff --git a/src/Codec/CBOR/Pretty.hs b/src/Codec/CBOR/Pretty.hs --- a/src/Codec/CBOR/Pretty.hs +++ b/src/Codec/CBOR/Pretty.hs @@ -279,8 +279,10 @@ unconsToken (TkInt64 i tks) = Just (TkInt64 i TkEnd,tks) unconsToken (TkBytes bs tks) = Just (TkBytes bs TkEnd,tks) unconsToken (TkBytesBegin tks) = Just (TkBytesBegin TkEnd,tks) +unconsToken (TkByteArray a tks) = Just (TkByteArray a TkEnd,tks) unconsToken (TkString t tks) = Just (TkString t TkEnd,tks) unconsToken (TkStringBegin tks) = Just (TkStringBegin TkEnd,tks) +unconsToken (TkUtf8ByteArray a tks) = Just (TkUtf8ByteArray a TkEnd,tks) unconsToken (TkListLen len tks) = Just (TkListLen len TkEnd,tks) unconsToken (TkListBegin tks) = Just (TkListBegin TkEnd,tks) unconsToken (TkMapLen len tks) = Just (TkMapLen len TkEnd,tks) diff --git a/src/Codec/CBOR/Read.hs b/src/Codec/CBOR/Read.hs --- a/src/Codec/CBOR/Read.hs +++ b/src/Codec/CBOR/Read.hs @@ -2,11 +2,14 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} +#if __GLASGOW_HASKELL__ > 706 -- Bump up from the default 1.5, otherwise our decoder fast path is no good. -- We went over the threshold when we switched to using ST. {-# OPTIONS_GHC -funfolding-keeness-factor=2.0 #-} +#endif -- | -- Module : Codec.CBOR.Read @@ -21,8 +24,9 @@ -- back into ordinary values. -- module Codec.CBOR.Read - ( deserialiseFromBytes -- :: Decoder a -> ByteString -> Either String (ByteString, a) - , deserialiseIncremental -- :: Decoder a -> ST s (IDecode s a) + ( deserialiseFromBytes -- :: Decoder a -> ByteString -> Either String (ByteString, a) + , deserialiseFromBytesWithSize -- :: Decoder a -> ByteString -> Either String (ByteString, ByteOffset, a) + , deserialiseIncremental -- :: Decoder a -> ST s (IDecode s a) , DeserialiseFailure(..) , IDecode(..) , ByteOffset @@ -51,11 +55,15 @@ import qualified Data.Text.Encoding as T import Data.Word import GHC.Word +#if defined(ARCH_32bit) +import GHC.IntWord64 +#endif import GHC.Exts import GHC.Float (float2Double) import Data.Typeable import Control.Exception +import qualified Codec.CBOR.ByteArray as BA import Codec.CBOR.Decoding hiding (DecodeAction(Done, Fail)) import Codec.CBOR.Decoding (DecodeAction) import qualified Codec.CBOR.Decoding as D @@ -108,22 +116,37 @@ -> LBS.ByteString -> Either DeserialiseFailure (LBS.ByteString, a) deserialiseFromBytes d lbs = - runIDecode (deserialiseIncremental d) lbs + fmap f $ runIDecode (deserialiseIncremental d) lbs + where f (rest, _, x) = (rest, x) +-- | Given a @'Decoder'@ and some @'LBS.ByteString'@ representing +-- an encoded CBOR value, return @'Either'@ the decoded CBOR value +-- or an error. In addition to the decoded value return any remaining input +-- content and the number of bytes consumed. +-- +-- @since 0.2.0.0 +deserialiseFromBytesWithSize :: (forall s. Decoder s a) + -> LBS.ByteString + -> Either DeserialiseFailure (LBS.ByteString, ByteOffset, a) +deserialiseFromBytesWithSize d lbs = + runIDecode (deserialiseIncremental d) lbs runIDecode :: (forall s. ST s (IDecode s a)) -> LBS.ByteString - -> Either DeserialiseFailure (LBS.ByteString, a) + -> Either DeserialiseFailure (LBS.ByteString, ByteOffset, a) runIDecode d lbs = runST (go lbs =<< d) where go :: LBS.ByteString -> IDecode s a - -> ST s (Either DeserialiseFailure (LBS.ByteString, a)) - go _ (Fail _ _ err) = return (Left err) - go lbs' (Done bs _ x) = return (Right (LBS.Chunk bs lbs', x)) - go LBS.Empty (Partial k) = k Nothing >>= go LBS.Empty - go (LBS.Chunk bs lbs') (Partial k) = k (Just bs) >>= go lbs' + -> ST s (Either DeserialiseFailure (LBS.ByteString, ByteOffset, a)) + go _ (Fail _ _ err) = return (Left err) + go lbs' (Done bs off x) = let rest + | BS.null bs = lbs' + | otherwise = LBS.Chunk bs lbs' + in return (Right (rest, off, x)) + go LBS.Empty (Partial k) = k Nothing >>= go LBS.Empty + go (LBS.Chunk bs lbs') (Partial k) = k (Just bs) >>= go lbs' -- | Run a @'Decoder'@ incrementally, returning a continuation -- representing the result of the incremental decode. @@ -208,11 +231,13 @@ -- of tokens spanning a chunk boundary. -- data SlowPath s a - = FastDone {-# UNPACK #-} !ByteString a - | SlowConsumeTokenString {-# UNPACK #-} !ByteString (T.Text -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int - | SlowConsumeTokenBytes {-# UNPACK #-} !ByteString (ByteString -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int - | SlowDecodeAction {-# UNPACK #-} !ByteString (DecodeAction s a) - | SlowFail {-# UNPACK #-} !ByteString String + = FastDone {-# UNPACK #-} !ByteString a + | SlowConsumeTokenBytes {-# UNPACK #-} !ByteString (ByteString -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int + | SlowConsumeTokenByteArray {-# UNPACK #-} !ByteString (BA.ByteArray -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int + | SlowConsumeTokenString {-# UNPACK #-} !ByteString (T.Text -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int + | SlowConsumeTokenUtf8ByteArray {-# UNPACK #-} !ByteString (BA.ByteArray -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int + | SlowDecodeAction {-# UNPACK #-} !ByteString (DecodeAction s a) + | SlowFail {-# UNPACK #-} !ByteString String -- The main fast path. The fast path itself is actually split into two parts @@ -313,7 +338,113 @@ DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs) +go_fast !bs da@(ConsumeWordCanonical k) = + case tryConsumeWord (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W# w#) + | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeWord8Canonical k) = + case tryConsumeWord (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W# w#) -> + case gtWord# w# 0xff## of + 0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + _ -> go_fast_end bs da + +go_fast !bs da@(ConsumeWord16Canonical k) = + case tryConsumeWord (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W# w#) -> + case gtWord# w# 0xffff## of + 0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + _ -> go_fast_end bs da + +go_fast !bs da@(ConsumeWord32Canonical k) = + case tryConsumeWord (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W# w#) -> + case w_out_of_range w# of + 0# | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + _ -> go_fast_end bs da + where + w_out_of_range _w# = #if defined(ARCH_32bit) + 0# +#else + gtWord# _w# 0xffffffff## +#endif + +go_fast !bs da@(ConsumeNegWordCanonical k) = + case tryConsumeNegWord (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W# w#) + | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeIntCanonical k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I# n#) + | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeInt8Canonical k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I# n#) -> + case (n# ># 0x7f#) `orI#` (n# <# -0x80#) of + 0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) + _ -> go_fast_end bs da + +go_fast !bs da@(ConsumeInt16Canonical k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I# n#) -> + case (n# ># 0x7fff#) `orI#` (n# <# -0x8000#) of + 0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) + _ -> go_fast_end bs da + +go_fast !bs da@(ConsumeInt32Canonical k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I# n#) -> + case n_out_of_range n# of + 0# | isIntCanonical sz n# -> k n# >>= go_fast (BS.unsafeDrop sz bs) + _ -> go_fast_end bs da + where + n_out_of_range _n# = +#if defined(ARCH_32bit) + 0# +#else + (_n# ># 0x7fffffff#) `orI#` (_n# <# -0x80000000#) +#endif + +go_fast !bs da@(ConsumeListLenCanonical k) = + case tryConsumeListLen (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I# n#) + -- List length can't be negative, cast it to Word#. + | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeMapLenCanonical k) = + case tryConsumeMapLen (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I# n#) + -- Map length can't be negative, cast it to Word#. + | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeTagCanonical k) = + case tryConsumeTag (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W# w#) + | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +#if defined(ARCH_32bit) go_fast !bs da@(ConsumeWord64 k) = case tryConsumeWord64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da @@ -343,12 +474,56 @@ case tryConsumeTag64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W64# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs) + +go_fast !bs da@(ConsumeWord64Canonical k) = + case tryConsumeWord64 (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W64# w#) + | isWord64Canonical -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeNegWord64Canonical k) = + case tryConsumeNegWord64 (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W64# w#) + | isWord64Canonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeInt64Canonical k) = + case tryConsumeInt64 (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I64# i#) + | isInt64Canonical sz i# -> k i# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeListLen64Canonical k) = + case tryConsumeListLen64 (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I64# i#) + -- List length can't be negative, cast it to Word64#. + | isWord64Canonical sz (int64ToWord64 i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeMapLen64Canonical k) = + case tryConsumeMapLen64 (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (I64# i#) + -- Map length can't be negative, cast it to Word64#. + | isWord64Canonical sz (int64ToWord64 i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeTag64Canonical k) = + case tryConsumeTag64 (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W64# w#) + | isWord64Canonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da #endif go_fast !bs da@(ConsumeInteger k) = case tryConsumeInteger (BS.unsafeHead bs) bs of - DecodedToken sz (BigIntToken n) -> k n >>= go_fast (BS.unsafeDrop sz bs) - _ -> go_fast_end bs da + DecodedToken sz (BigIntToken _ n) -> k n >>= go_fast (BS.unsafeDrop sz bs) + _ -> go_fast_end bs da go_fast !bs da@(ConsumeFloat k) = case tryConsumeFloat (BS.unsafeHead bs) bs of @@ -366,12 +541,26 @@ DecodedToken sz (Fits bstr) -> k bstr >>= go_fast (BS.unsafeDrop sz bs) DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len +go_fast !bs da@(ConsumeByteArray k) = + case tryConsumeBytes (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (Fits str) -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len + go_fast !bs da@(ConsumeString k) = case tryConsumeString (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da - DecodedToken sz (Fits str) -> k str >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz (Fits str) -> case T.decodeUtf8' str of + Right t -> k t >>= go_fast (BS.unsafeDrop sz bs) + Left e -> return $! SlowFail bs (show e) DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len +go_fast !bs da@(ConsumeUtf8ByteArray k) = + case tryConsumeString (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (Fits str) -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len + go_fast !bs da@(ConsumeBool k) = case tryConsumeBool (BS.unsafeHead bs) of DecodeFailure -> go_fast_end bs da @@ -382,6 +571,40 @@ DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs) +go_fast !bs da@(ConsumeIntegerCanonical k) = + case tryConsumeInteger (BS.unsafeHead bs) bs of + DecodedToken sz (BigIntToken True n) -> k n >>= go_fast (BS.unsafeDrop sz bs) + _ -> go_fast_end bs da + + +go_fast !bs da@(ConsumeFloat16Canonical k) = + case tryConsumeFloat (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (F# f#) + | isFloat16Canonical sz -> k f# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeFloatCanonical k) = + case tryConsumeFloat (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz f@(F# f#) + | isFloatCanonical sz bs f -> k f# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeDoubleCanonical k) = + case tryConsumeDouble (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz f@(D# f#) + | isDoubleCanonical sz bs f -> k f# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + +go_fast !bs da@(ConsumeSimpleCanonical k) = + case tryConsumeSimple (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (W# w#) + | isWordCanonical sz w# -> k w# >>= go_fast (BS.unsafeDrop sz bs) + | otherwise -> go_fast_end bs da + go_fast !bs da@(ConsumeBytesIndef k) = case tryConsumeBytesIndef (BS.unsafeHead bs) of DecodeFailure -> go_fast_end bs da @@ -554,7 +777,116 @@ DecodeFailure -> return $! SlowFail bs "expected tag" DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) +go_fast_end !bs (ConsumeWordCanonical k) = + case tryConsumeWord (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected word" + DecodedToken sz (W# w#) + | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical word" + +go_fast_end !bs (ConsumeWord8Canonical k) = + case tryConsumeWord (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected word8" + DecodedToken sz (W# w#) -> case gtWord# w# 0xff## of + 0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical word8" + _ -> return $! SlowFail bs "expected word8" + +go_fast_end !bs (ConsumeWord16Canonical k) = + case tryConsumeWord (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected word16" + DecodedToken sz (W# w#) -> case gtWord# w# 0xffff## of + 0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical word16" + _ -> return $! SlowFail bs "expected word16" + +go_fast_end !bs (ConsumeWord32Canonical k) = + case tryConsumeWord (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected word32" + DecodedToken sz (W# w#) -> case w_out_of_range w# of + 0# | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical word32" + _ -> return $! SlowFail bs "expected word32" + where + w_out_of_range _w# = #if defined(ARCH_32bit) + 0# +#else + gtWord# _w# 0xffffffff## +#endif + +go_fast_end !bs (ConsumeNegWordCanonical k) = + case tryConsumeNegWord (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected negative int" + DecodedToken sz (W# w#) + | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical negative int" + +go_fast_end !bs (ConsumeIntCanonical k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected int" + DecodedToken sz (I# n#) + | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical int" + +go_fast_end !bs (ConsumeInt8Canonical k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected int8" + DecodedToken sz (I# n#) -> + case (n# ># 0x7f#) `orI#` (n# <# -0x80#) of + 0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical int8" + _ -> return $! SlowFail bs "expected int8" + +go_fast_end !bs (ConsumeInt16Canonical k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected int16" + DecodedToken sz (I# n#) -> + case (n# ># 0x7fff#) `orI#` (n# <# -0x8000#) of + 0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical int16" + _ -> return $! SlowFail bs "expected int16" + +go_fast_end !bs (ConsumeInt32Canonical k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected int32" + DecodedToken sz (I# n#) -> + case n_out_of_range n# of + 0# | isIntCanonical sz n# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical int32" + _ -> return $! SlowFail bs "expected int32" + where + n_out_of_range _n# = +#if defined(ARCH_32bit) + 0# +#else + (_n# ># 0x7fffffff#) `orI#` (_n# <# -0x80000000#) +#endif + +go_fast_end !bs (ConsumeListLenCanonical k) = + case tryConsumeListLen (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected list len" + DecodedToken sz (I# n#) + -- List length can't be negative, cast it to Word#. + | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical list len" + +go_fast_end !bs (ConsumeMapLenCanonical k) = + case tryConsumeMapLen (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected map len" + DecodedToken sz (I# n#) + -- Map length can't be negative, cast it to Word#. + | isWordCanonical sz (int2Word# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical map len" + +go_fast_end !bs (ConsumeTagCanonical k) = + case tryConsumeTag (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected tag" + DecodedToken sz (W# w#) + | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical tag" + +#if defined(ARCH_32bit) go_fast_end !bs (ConsumeWord64 k) = case tryConsumeWord64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word64" @@ -589,7 +921,7 @@ go_fast_end !bs (ConsumeInteger k) = case tryConsumeInteger (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected integer" - DecodedToken sz (BigIntToken n) -> k n >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz (BigIntToken _ n) -> k n >>= go_fast_end (BS.unsafeDrop sz bs) DecodedToken sz (BigUIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigUIntNeedBody k) len DecodedToken sz (BigNIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigNIntNeedBody k) len DecodedToken sz BigUIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContBigUIntNeedHeader k) @@ -611,12 +943,26 @@ DecodedToken sz (Fits bstr) -> k bstr >>= go_fast_end (BS.unsafeDrop sz bs) DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len +go_fast_end !bs (ConsumeByteArray k) = + case tryConsumeBytes (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected string" + DecodedToken sz (Fits str) -> (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len + go_fast_end !bs (ConsumeString k) = case tryConsumeString (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected string" - DecodedToken sz (Fits str) -> k str >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz (Fits str) -> case T.decodeUtf8' str of + Right t -> k t >>= go_fast_end (BS.unsafeDrop sz bs) + Left e -> return $! SlowFail bs (show e) DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len +go_fast_end !bs (ConsumeUtf8ByteArray k) = + case tryConsumeString (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected string" + DecodedToken sz (Fits str) -> (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len + go_fast_end !bs (ConsumeBool k) = case tryConsumeBool (BS.unsafeHead bs) of DecodeFailure -> return $! SlowFail bs "expected bool" @@ -627,6 +973,45 @@ DecodeFailure -> return $! SlowFail bs "expected simple" DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) +go_fast_end !bs (ConsumeIntegerCanonical k) = + case tryConsumeInteger (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected integer" + DecodedToken sz (BigIntToken canonical n) + | canonical -> k n >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical integer" + DecodedToken sz (BigUIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigUIntNeedBody k) len + DecodedToken sz (BigNIntNeedBody len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContBigNIntNeedBody k) len + DecodedToken sz BigUIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContBigUIntNeedHeader k) + DecodedToken sz BigNIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContBigNIntNeedHeader k) + +go_fast_end !bs (ConsumeFloat16Canonical k) = + case tryConsumeFloat (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected float" + DecodedToken sz (F# f#) + | isFloat16Canonical sz -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical float16" + +go_fast_end !bs (ConsumeFloatCanonical k) = + case tryConsumeFloat (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected float" + DecodedToken sz f@(F# f#) + | isFloatCanonical sz bs f -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical float" + +go_fast_end !bs (ConsumeDoubleCanonical k) = + case tryConsumeDouble (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected double" + DecodedToken sz f@(D# f#) + | isDoubleCanonical sz bs f -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical double" + +go_fast_end !bs (ConsumeSimpleCanonical k) = + case tryConsumeSimple (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected simple" + DecodedToken sz (W# w#) + | isWordCanonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) + | otherwise -> return $! SlowFail bs "non-canonical simple" + go_fast_end !bs (ConsumeBytesIndef k) = case tryConsumeBytesIndef (BS.unsafeHead bs) of DecodeFailure -> return $! SlowFail bs "expected bytes start" @@ -685,6 +1070,13 @@ where !offset' = offset + fromIntegral (BS.length bs - BS.length bs') + SlowConsumeTokenByteArray bs' k len -> do + (bstr, bs'') <- getTokenVarLen len bs' offset' + let !str = BA.fromByteString bstr + lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len) + where + !offset' = offset + fromIntegral (BS.length bs - BS.length bs') + SlowConsumeTokenString bs' k len -> do (bstr, bs'') <- getTokenVarLen len bs' offset' let !str = T.decodeUtf8 bstr -- TODO FIXME: utf8 validation @@ -692,6 +1084,13 @@ where !offset' = offset + fromIntegral (BS.length bs - BS.length bs') + SlowConsumeTokenUtf8ByteArray bs' k len -> do + (bstr, bs'') <- getTokenVarLen len bs' offset' + let !str = BA.fromByteString bstr + lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len) + where + !offset' = offset + fromIntegral (BS.length bs - BS.length bs') + -- we didn't have enough input in the buffer SlowDecodeAction bs' da' | BS.null bs' -> do -- in this case we're exactly out of input @@ -783,32 +1182,39 @@ assert (BS.null bs_empty) $ return (bs', offset', x) - SlowConsumeTokenBytes bs_empty k len -> - assert (BS.null bs_empty) $ do - (bstr, bs'') <- if BS.length bs' < len - then getTokenVarLen len bs' offset' - else let !bstr = BS.take len bs' - !bs'' = BS.drop len bs' - in return (bstr, bs'') - lift (k bstr) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len) + SlowConsumeTokenBytes bs_empty k len -> consume id bs' offset' bs_empty k len - SlowConsumeTokenString bs_empty k len -> + SlowConsumeTokenByteArray bs_empty k len -> consume BA.fromByteString bs' offset' bs_empty k len + + SlowConsumeTokenString bs_empty k len -> consume T.decodeUtf8 bs' offset' bs_empty k len + -- TODO FIXME: utf8 validation + + SlowConsumeTokenUtf8ByteArray bs_empty k len -> consume BA.fromByteString bs' offset' bs_empty k len + + SlowFail bs_unconsumed msg -> + decodeFail (bs_unconsumed <> bs') offset'' msg + where + !offset'' = offset + fromIntegral (sz - BS.length bs_unconsumed) + where + {-# INLINE consume #-} + consume :: (BS.ByteString -> a) + -> BS.ByteString -- bs' + -> Int64 -- offset' + -> BS.ByteString -- bs_empty + -> (a -> ST s (DecodeAction s r)) -- continuation + -> Int -- length + -> IncrementalDecoder s (ByteString, ByteOffset, r) + consume pack bs' offset' bs_empty k len = assert (BS.null bs_empty) $ do (bstr, bs'') <- if BS.length bs' < len then getTokenVarLen len bs' offset' else let !bstr = BS.take len bs' !bs'' = BS.drop len bs' in return (bstr, bs'') - let !str = T.decodeUtf8 bstr -- TODO FIXME: utf8 validation + let !str = pack bstr lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len) - SlowFail bs_unconsumed msg -> - decodeFail (bs_unconsumed <> bs') offset'' msg - where - !offset'' = offset + fromIntegral (sz - BS.length bs_unconsumed) - - -- TODO FIXME: we can do slightly better here. If we're returning a -- lazy string (String, lazy Text, lazy ByteString) then we don't have -- to strictify here and if we're returning a strict string perhaps we @@ -907,14 +1313,66 @@ encodeHeader :: Word -> Word -> Word8 encodeHeader mt ai = fromIntegral (mt `shiftL` 5 .|. ai) - data DecodedToken a = DecodedToken !Int !a | DecodeFailure deriving Show data LongToken a = Fits !a | TooLong !Int deriving Show +{-# INLINE isFloat16Canonical #-} +isFloat16Canonical :: Int -> Bool +isFloat16Canonical sz + | sz == 3 = True + | otherwise = False +{-# INLINE isFloatCanonical #-} +isFloatCanonical :: Int -> BS.ByteString -> Float -> Bool +isFloatCanonical sz bs f + | isNaN f = sz == 3 && "\xf9\x7e\x00" `BS.isPrefixOf` bs + | otherwise = sz == 5 + +{-# INLINE isDoubleCanonical #-} +isDoubleCanonical :: Int -> BS.ByteString -> Double -> Bool +isDoubleCanonical sz bs f + | isNaN f = sz == 3 && "\xf9\x7e\x00" `BS.isPrefixOf` bs + | otherwise = sz == 9 + +{-# INLINE isWordCanonical #-} +isWordCanonical :: Int -> Word# -> Bool +isWordCanonical sz w# + | sz == 2 && isTrue# (w# `leWord#` 0x17##) = False + | sz == 3 && isTrue# (w# `leWord#` 0xff##) = False + | sz == 5 && isTrue# (w# `leWord#` 0xffff##) = False + | sz == 9 && isTrue# (w# `leWord#` 0xffffffff##) = False + | otherwise = True + +{-# INLINE isIntCanonical #-} +isIntCanonical :: Int -> Int# -> Bool +isIntCanonical sz i# + | isTrue# (i# <# 0#) = isWordCanonical sz (not# w#) + | otherwise = isWordCanonical sz w# + where + w# = int2Word# i# + +#if defined(ARCH_32bit) +{-# INLINE isWord64Canonical #-} +isWord64Canonical :: Int -> Word64# -> Bool +isWord64Canonical sz w# + | sz == 2 && isTrue# (w# `leWord64#` 0x17##) = False + | sz == 3 && isTrue# (w# `leWord64#` 0xff##) = False + | sz == 5 && isTrue# (w# `leWord64#` 0xffff##) = False + | sz == 9 && isTrue# (w# `leWord64#` 0xffffffff##) = False + | otherwise = True + +{-# INLINE isInt64Canonical #-} +isInt64Canonical :: Int -> Int64# -> Bool +isInt64Canonical sz i# + | isTrue# (i# <# 0#) = isWord64Canonical sz (not64# w#) + | otherwise = isWord64Canonical sz w# + where + w# = int64ToWord64# i# +#endif + -- TODO FIXME: check with 7.10 and file ticket: -- a case analysis against 0x00 .. 0xff :: Word8 turns into a huge chain -- of >= tests. It could use a jump table, or at least it could use a binary @@ -1060,64 +1518,89 @@ tryConsumeInteger hdr !bs = case fromIntegral hdr :: Word of -- Positive integers (type 0) - 0x00 -> DecodedToken 1 (BigIntToken 0) - 0x01 -> DecodedToken 1 (BigIntToken 1) - 0x02 -> DecodedToken 1 (BigIntToken 2) - 0x03 -> DecodedToken 1 (BigIntToken 3) - 0x04 -> DecodedToken 1 (BigIntToken 4) - 0x05 -> DecodedToken 1 (BigIntToken 5) - 0x06 -> DecodedToken 1 (BigIntToken 6) - 0x07 -> DecodedToken 1 (BigIntToken 7) - 0x08 -> DecodedToken 1 (BigIntToken 8) - 0x09 -> DecodedToken 1 (BigIntToken 9) - 0x0a -> DecodedToken 1 (BigIntToken 10) - 0x0b -> DecodedToken 1 (BigIntToken 11) - 0x0c -> DecodedToken 1 (BigIntToken 12) - 0x0d -> DecodedToken 1 (BigIntToken 13) - 0x0e -> DecodedToken 1 (BigIntToken 14) - 0x0f -> DecodedToken 1 (BigIntToken 15) - 0x10 -> DecodedToken 1 (BigIntToken 16) - 0x11 -> DecodedToken 1 (BigIntToken 17) - 0x12 -> DecodedToken 1 (BigIntToken 18) - 0x13 -> DecodedToken 1 (BigIntToken 19) - 0x14 -> DecodedToken 1 (BigIntToken 20) - 0x15 -> DecodedToken 1 (BigIntToken 21) - 0x16 -> DecodedToken 1 (BigIntToken 22) - 0x17 -> DecodedToken 1 (BigIntToken 23) - 0x18 -> DecodedToken 2 (BigIntToken (fromIntegral (eatTailWord8 bs))) - 0x19 -> DecodedToken 3 (BigIntToken (fromIntegral (eatTailWord16 bs))) - 0x1a -> DecodedToken 5 (BigIntToken (fromIntegral (eatTailWord32 bs))) - 0x1b -> DecodedToken 9 (BigIntToken (fromIntegral (eatTailWord64 bs))) + 0x00 -> DecodedToken 1 (BigIntToken True 0) + 0x01 -> DecodedToken 1 (BigIntToken True 1) + 0x02 -> DecodedToken 1 (BigIntToken True 2) + 0x03 -> DecodedToken 1 (BigIntToken True 3) + 0x04 -> DecodedToken 1 (BigIntToken True 4) + 0x05 -> DecodedToken 1 (BigIntToken True 5) + 0x06 -> DecodedToken 1 (BigIntToken True 6) + 0x07 -> DecodedToken 1 (BigIntToken True 7) + 0x08 -> DecodedToken 1 (BigIntToken True 8) + 0x09 -> DecodedToken 1 (BigIntToken True 9) + 0x0a -> DecodedToken 1 (BigIntToken True 10) + 0x0b -> DecodedToken 1 (BigIntToken True 11) + 0x0c -> DecodedToken 1 (BigIntToken True 12) + 0x0d -> DecodedToken 1 (BigIntToken True 13) + 0x0e -> DecodedToken 1 (BigIntToken True 14) + 0x0f -> DecodedToken 1 (BigIntToken True 15) + 0x10 -> DecodedToken 1 (BigIntToken True 16) + 0x11 -> DecodedToken 1 (BigIntToken True 17) + 0x12 -> DecodedToken 1 (BigIntToken True 18) + 0x13 -> DecodedToken 1 (BigIntToken True 19) + 0x14 -> DecodedToken 1 (BigIntToken True 20) + 0x15 -> DecodedToken 1 (BigIntToken True 21) + 0x16 -> DecodedToken 1 (BigIntToken True 22) + 0x17 -> DecodedToken 1 (BigIntToken True 23) + 0x18 -> let !w@(W# w#) = eatTailWord8 bs + sz = 2 + in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (fromIntegral w)) + 0x19 -> let !w@(W# w#) = eatTailWord16 bs + sz = 3 + in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (fromIntegral w)) + 0x1a -> let !w@(W# w#) = eatTailWord32 bs + sz = 5 + in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (fromIntegral w)) + 0x1b -> let !w@(W64# w#) = eatTailWord64 bs + sz = 9 +#if defined(ARCH_32bit) + in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (fromIntegral w)) +#else + in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (fromIntegral w)) +#endif + -- Negative integers (type 1) - 0x20 -> DecodedToken 1 (BigIntToken (-1)) - 0x21 -> DecodedToken 1 (BigIntToken (-2)) - 0x22 -> DecodedToken 1 (BigIntToken (-3)) - 0x23 -> DecodedToken 1 (BigIntToken (-4)) - 0x24 -> DecodedToken 1 (BigIntToken (-5)) - 0x25 -> DecodedToken 1 (BigIntToken (-6)) - 0x26 -> DecodedToken 1 (BigIntToken (-7)) - 0x27 -> DecodedToken 1 (BigIntToken (-8)) - 0x28 -> DecodedToken 1 (BigIntToken (-9)) - 0x29 -> DecodedToken 1 (BigIntToken (-10)) - 0x2a -> DecodedToken 1 (BigIntToken (-11)) - 0x2b -> DecodedToken 1 (BigIntToken (-12)) - 0x2c -> DecodedToken 1 (BigIntToken (-13)) - 0x2d -> DecodedToken 1 (BigIntToken (-14)) - 0x2e -> DecodedToken 1 (BigIntToken (-15)) - 0x2f -> DecodedToken 1 (BigIntToken (-16)) - 0x30 -> DecodedToken 1 (BigIntToken (-17)) - 0x31 -> DecodedToken 1 (BigIntToken (-18)) - 0x32 -> DecodedToken 1 (BigIntToken (-19)) - 0x33 -> DecodedToken 1 (BigIntToken (-20)) - 0x34 -> DecodedToken 1 (BigIntToken (-21)) - 0x35 -> DecodedToken 1 (BigIntToken (-22)) - 0x36 -> DecodedToken 1 (BigIntToken (-23)) - 0x37 -> DecodedToken 1 (BigIntToken (-24)) - 0x38 -> DecodedToken 2 (BigIntToken (-1 - fromIntegral (eatTailWord8 bs))) - 0x39 -> DecodedToken 3 (BigIntToken (-1 - fromIntegral (eatTailWord16 bs))) - 0x3a -> DecodedToken 5 (BigIntToken (-1 - fromIntegral (eatTailWord32 bs))) - 0x3b -> DecodedToken 9 (BigIntToken (-1 - fromIntegral (eatTailWord64 bs))) + 0x20 -> DecodedToken 1 (BigIntToken True (-1)) + 0x21 -> DecodedToken 1 (BigIntToken True (-2)) + 0x22 -> DecodedToken 1 (BigIntToken True (-3)) + 0x23 -> DecodedToken 1 (BigIntToken True (-4)) + 0x24 -> DecodedToken 1 (BigIntToken True (-5)) + 0x25 -> DecodedToken 1 (BigIntToken True (-6)) + 0x26 -> DecodedToken 1 (BigIntToken True (-7)) + 0x27 -> DecodedToken 1 (BigIntToken True (-8)) + 0x28 -> DecodedToken 1 (BigIntToken True (-9)) + 0x29 -> DecodedToken 1 (BigIntToken True (-10)) + 0x2a -> DecodedToken 1 (BigIntToken True (-11)) + 0x2b -> DecodedToken 1 (BigIntToken True (-12)) + 0x2c -> DecodedToken 1 (BigIntToken True (-13)) + 0x2d -> DecodedToken 1 (BigIntToken True (-14)) + 0x2e -> DecodedToken 1 (BigIntToken True (-15)) + 0x2f -> DecodedToken 1 (BigIntToken True (-16)) + 0x30 -> DecodedToken 1 (BigIntToken True (-17)) + 0x31 -> DecodedToken 1 (BigIntToken True (-18)) + 0x32 -> DecodedToken 1 (BigIntToken True (-19)) + 0x33 -> DecodedToken 1 (BigIntToken True (-20)) + 0x34 -> DecodedToken 1 (BigIntToken True (-21)) + 0x35 -> DecodedToken 1 (BigIntToken True (-22)) + 0x36 -> DecodedToken 1 (BigIntToken True (-23)) + 0x37 -> DecodedToken 1 (BigIntToken True (-24)) + 0x38 -> let !w@(W# w#) = eatTailWord8 bs + sz = 2 + in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - fromIntegral w)) + 0x39 -> let !w@(W# w#) = eatTailWord16 bs + sz = 3 + in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - fromIntegral w)) + 0x3a -> let !w@(W# w#) = eatTailWord32 bs + sz = 5 + in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - fromIntegral w)) + 0x3b -> let !w@(W64# w#) = eatTailWord64 bs + sz = 9 +#if defined(ARCH_32bit) + in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (-1 - fromIntegral w)) +#else + in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - fromIntegral w)) +#endif 0xc2 -> readBigUInt bs 0xc3 -> readBigNInt bs @@ -1162,38 +1645,38 @@ {-# INLINE tryConsumeString #-} -tryConsumeString :: Word8 -> ByteString -> DecodedToken (LongToken T.Text) +tryConsumeString :: Word8 -> ByteString -> DecodedToken (LongToken BS.ByteString) tryConsumeString hdr !bs = case fromIntegral hdr :: Word of -- Strings (type 3) - 0x60 -> readStringSmall 0 bs - 0x61 -> readStringSmall 1 bs - 0x62 -> readStringSmall 2 bs - 0x63 -> readStringSmall 3 bs - 0x64 -> readStringSmall 4 bs - 0x65 -> readStringSmall 5 bs - 0x66 -> readStringSmall 6 bs - 0x67 -> readStringSmall 7 bs - 0x68 -> readStringSmall 8 bs - 0x69 -> readStringSmall 9 bs - 0x6a -> readStringSmall 10 bs - 0x6b -> readStringSmall 11 bs - 0x6c -> readStringSmall 12 bs - 0x6d -> readStringSmall 13 bs - 0x6e -> readStringSmall 14 bs - 0x6f -> readStringSmall 15 bs - 0x70 -> readStringSmall 16 bs - 0x71 -> readStringSmall 17 bs - 0x72 -> readStringSmall 18 bs - 0x73 -> readStringSmall 19 bs - 0x74 -> readStringSmall 20 bs - 0x75 -> readStringSmall 21 bs - 0x76 -> readStringSmall 22 bs - 0x77 -> readStringSmall 23 bs - 0x78 -> readString8 bs - 0x79 -> readString16 bs - 0x7a -> readString32 bs - 0x7b -> readString64 bs + 0x60 -> readBytesSmall 0 bs + 0x61 -> readBytesSmall 1 bs + 0x62 -> readBytesSmall 2 bs + 0x63 -> readBytesSmall 3 bs + 0x64 -> readBytesSmall 4 bs + 0x65 -> readBytesSmall 5 bs + 0x66 -> readBytesSmall 6 bs + 0x67 -> readBytesSmall 7 bs + 0x68 -> readBytesSmall 8 bs + 0x69 -> readBytesSmall 9 bs + 0x6a -> readBytesSmall 10 bs + 0x6b -> readBytesSmall 11 bs + 0x6c -> readBytesSmall 12 bs + 0x6d -> readBytesSmall 13 bs + 0x6e -> readBytesSmall 14 bs + 0x6f -> readBytesSmall 15 bs + 0x70 -> readBytesSmall 16 bs + 0x71 -> readBytesSmall 17 bs + 0x72 -> readBytesSmall 18 bs + 0x73 -> readBytesSmall 19 bs + 0x74 -> readBytesSmall 20 bs + 0x75 -> readBytesSmall 21 bs + 0x76 -> readBytesSmall 22 bs + 0x77 -> readBytesSmall 23 bs + 0x78 -> readBytes8 bs + 0x79 -> readBytes16 bs + 0x7a -> readBytes32 bs + 0x7b -> readBytes64 bs _ -> DecodeFailure @@ -1782,78 +2265,6 @@ -- TODO FIXME: int overflow n = fromIntegral (eatTailWord64 bs) - -readStringSmall :: Int -> ByteString -> DecodedToken (LongToken T.Text) -readStringSmall n bs - -- if n <= bound then ok return it all - | n + hdrsz <= BS.length bs - = DecodedToken (n+hdrsz) $ Fits $ - T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) - -- TODO FIXME: utf8 validation - - -- if n > bound then slow path, multi-chunk - | otherwise - = DecodedToken hdrsz $ TooLong n - where - hdrsz = 1 - -readString8, readString16, - readString32, readString64 :: ByteString -> DecodedToken (LongToken T.Text) -readString8 bs - | n <= BS.length bs - hdrsz - = DecodedToken (n+hdrsz) $ Fits $ - T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) - -- TODO FIXME: utf8 validation - - -- if n > bound then slow path, multi-chunk - | otherwise - = DecodedToken hdrsz $ TooLong n - where - hdrsz = 2 - n = fromIntegral (eatTailWord8 bs) - -readString16 bs - | n <= BS.length bs - hdrsz - = DecodedToken (n+hdrsz) $ Fits $ - T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) - -- TODO FIXME: utf8 validation - - -- if n > bound then slow path, multi-chunk - | otherwise - = DecodedToken hdrsz $ TooLong n - where - hdrsz = 3 - n = fromIntegral (eatTailWord16 bs) - -readString32 bs - | n <= BS.length bs - hdrsz - = DecodedToken (n+hdrsz) $ Fits $ - T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) - -- TODO FIXME: utf8 validation - - -- if n > bound then slow path, multi-chunk - | otherwise - = DecodedToken hdrsz $ TooLong n - where - hdrsz = 5 - -- TODO FIXME: int overflow - n = fromIntegral (eatTailWord32 bs) - -readString64 bs - | n <= BS.length bs - hdrsz - = DecodedToken (n+hdrsz) $ Fits $ - T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) - -- TODO FIXME: utf8 validation - - -- if n > bound then slow path, multi-chunk - | otherwise - = DecodedToken hdrsz $ TooLong n - where - hdrsz = 5 - -- TODO FIXME: int overflow - n = fromIntegral (eatTailWord64 bs) - - ------------------------------------------------------------------------------ -- Reading big integers -- @@ -1883,7 +2294,7 @@ -- decoding a big int across an input buffer boundary ought to be rare, and -- allocating a new continuation closure isn't that expensive. -data BigIntToken a = BigIntToken Integer +data BigIntToken a = BigIntToken Bool {- canonical? -} Integer | BigUIntNeedBody Int | BigNIntNeedBody Int | BigUIntNeedHeader @@ -1930,7 +2341,8 @@ , BS.length bs' >= tokenSize hdr = case tryConsumeBytes hdr bs' of DecodeFailure -> DecodeFailure - DecodedToken sz (Fits bstr) -> DecodedToken (1+sz) (BigIntToken (uintegerFromBytes bstr)) + DecodedToken sz (Fits bstr) -> DecodedToken (1+sz) + (BigIntToken (isBigIntRepCanonical bstr) (uintegerFromBytes bstr)) DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigUIntNeedBody len) | otherwise @@ -1945,8 +2357,16 @@ , BS.length bs' >= tokenSize hdr = case tryConsumeBytes hdr bs' of DecodeFailure -> DecodeFailure - DecodedToken sz (Fits bstr) -> DecodedToken (1+sz) (BigIntToken (nintegerFromBytes bstr)) + DecodedToken sz (Fits bstr) -> DecodedToken (1+sz) + (BigIntToken (isBigIntRepCanonical bstr) (nintegerFromBytes bstr)) DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigNIntNeedBody len) | otherwise = DecodedToken 1 BigNIntNeedHeader + +-- Binary representation of a big integer is canonical if it's at least 9 bytes +-- long (as for smaller values the canonical representation is the same one as +-- for Int) and the leading byte is not zero (meaning that it's the smallest +-- representation for the number in question). +isBigIntRepCanonical :: ByteString -> Bool +isBigIntRepCanonical bstr = BS.length bstr > 8 && BS.unsafeHead bstr /= 0x00 diff --git a/src/Codec/CBOR/Write.hs b/src/Codec/CBOR/Write.hs --- a/src/Codec/CBOR/Write.hs +++ b/src/Codec/CBOR/Write.hs @@ -50,6 +50,7 @@ #endif #endif +import qualified Codec.CBOR.ByteArray.Sliced as BAS import Codec.CBOR.Encoding import Codec.CBOR.Magic @@ -93,7 +94,9 @@ TkBytes x vs' -> BI.runBuilderWith (bytesMP x) (step vs' k) (BI.BufferRange op ope0) TkBytesBegin vs' -> PI.runB bytesBeginMP () op >>= go vs' + TkByteArray x vs' -> BI.runBuilderWith (byteArrayMP x) (step vs' k) (BI.BufferRange op ope0) + TkUtf8ByteArray x vs' -> BI.runBuilderWith (utf8ByteArrayMP x) (step vs' k) (BI.BufferRange op ope0) TkString x vs' -> BI.runBuilderWith (stringMP x) (step vs' k) (BI.BufferRange op ope0) TkStringBegin vs'-> PI.runB stringBeginMP () op >>= go vs' @@ -351,6 +354,10 @@ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0x59 P.word16BE) $ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x5a P.word32BE) $ (fromIntegral >$< withConstHeader 0x5b P.word64BE) +byteArrayMP :: BAS.SlicedByteArray -> B.Builder +byteArrayMP ba = + P.primBounded bytesLenMP n <> BAS.toBuilder ba + where n = fromIntegral $ BAS.sizeofSlicedByteArray ba bytesBeginMP :: P.BoundedPrim () bytesBeginMP = constHeader 0x5f @@ -388,6 +395,12 @@ stringBeginMP :: P.BoundedPrim () stringBeginMP = constHeader 0x7f +utf8ByteArrayMP :: BAS.SlicedByteArray -> B.Builder +utf8ByteArrayMP t = + P.primBounded stringLenMP n <> BAS.toBuilder t + where + n = fromIntegral $ BAS.sizeofSlicedByteArray t + {- Major type 4: an array of data items. Arrays are also called lists, sequences, or tuples. The array's length follows the rules for @@ -518,15 +531,22 @@ undefMP :: P.BoundedPrim () undefMP = constHeader 0xf7 +-- Canonical encoding of a NaN as per RFC 7049, section 3.9. +canonicalNaN :: PI.BoundedPrim a +canonicalNaN = P.liftFixedToBounded $ const (0xf9, (0x7e, 0x00)) + >$< P.word8 >*< P.word8 >*< P.word8 + halfMP :: P.BoundedPrim Float -halfMP = floatToWord16 >$< - withConstHeader 0xf9 P.word16BE +halfMP = condB isNaN canonicalNaN + (floatToWord16 >$< withConstHeader 0xf9 P.word16BE) floatMP :: P.BoundedPrim Float -floatMP = withConstHeader 0xfa P.floatBE +floatMP = condB isNaN canonicalNaN + (withConstHeader 0xfa P.floatBE) doubleMP :: P.BoundedPrim Double -doubleMP = withConstHeader 0xfb P.doubleBE +doubleMP = condB isNaN canonicalNaN + (withConstHeader 0xfb P.doubleBE) breakMP :: P.BoundedPrim () breakMP = constHeader 0xff