cborg-0.2.1.0/0000755000000000000000000000000013357736054011147 5ustar0000000000000000cborg-0.2.1.0/ChangeLog.md0000644000000000000000000000063413357736054013323 0ustar0000000000000000# Revision history for cborg ## 0.2.1.0 -- 2018-10-11 * Bounds bumps and GHC 8.6 compatibility ## 0.2.0.0 -- 2017-11-30 * Improved robustness of non-UTF-8 strings * Add encoders and decoders for `ByteArray` * Add decoding variants that check for canonical encodings * Expose `Codec.CBOR.Read.deserialiseFromBytesWithSize` ## 0.1.0.0 -- 2017-06-28 * First version. Released on an unsuspecting world. cborg-0.2.1.0/LICENSE.txt0000644000000000000000000000310613357736054012772 0ustar0000000000000000Copyright (c) 2015-2017 Duncan Coutts, 2015-2017 Well-Typed LLP, 2015 IRIS Connect Ltd. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Duncan Coutts nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cborg-0.2.1.0/cborg.cabal0000644000000000000000000001061013357736054013225 0ustar0000000000000000name: cborg version: 0.2.1.0 synopsis: Concise Binary Object Representation license: BSD3 license-file: LICENSE.txt author: Duncan Coutts maintainer: duncan@community.haskell.org, ben@smart-cactus.org bug-reports: https://github.com/well-typed/cborg/issues copyright: 2015-2017 Duncan Coutts, 2015-2017 Well-Typed LLP, 2015 IRIS Connect Ltd category: Codec build-type: Simple cabal-version: >= 1.10 tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 extra-source-files: ChangeLog.md description: This package (formerly @binary-serialise-cbor@) provides an efficient implementation of the Concise Binary Object Representation (CBOR), as 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/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 tests/test-vectors/appendix_a.json tests/test-vectors/README.md source-repository head type: git location: https://github.com/well-typed/cborg.git -------------------------------------------------------------------------------- -- Flags flag optimize-gmp default: True manual: False description: Use optimized code paths for integer-gmp -------------------------------------------------------------------------------- -- Library library default-language: Haskell2010 ghc-options: -Wall include-dirs: src/cbits hs-source-dirs: src exposed-modules: Codec.CBOR Codec.CBOR.Decoding Codec.CBOR.Encoding Codec.CBOR.FlatTerm Codec.CBOR.Magic Codec.CBOR.Pretty 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, UnboxedTuples, BangPatterns, DeriveDataTypeable, RankNTypes build-depends: array >= 0.4 && < 0.6, base >= 4.6 && < 5.0, bytestring >= 0.10.4 && < 0.11, containers >= 0.5 && < 0.7, deepseq >= 1.0 && < 1.5, ghc-prim >= 0.3.1.0 && < 0.6, half >= 0.2.2.3 && < 0.4, primitive >= 0.5 && < 0.7, text >= 1.1 && < 1.3 if flag(optimize-gmp) cpp-options: -DFLAG_OPTIMIZE_GMP build-depends: integer-gmp if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances else -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 build-depends: fail == 4.9.*, semigroups == 0.18.* test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Main.hs default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans -threaded -rtsopts "-with-rtsopts=-N2" other-modules: Tests.CBOR Tests.Boundary Tests.Regress Tests.Regress.Issue160 Tests.Regress.Issue162 Tests.Regress.FlatTerm Tests.Reference Tests.Reference.Implementation Tests.UTF8 Tests.Util build-depends: array >= 0.4 && < 0.6, base >= 4.6 && < 5.0, bytestring >= 0.10.4 && < 0.11, text >= 1.1 && < 1.3, cborg, aeson >= 0.7 && < 1.5, base64-bytestring >= 1.0 && < 1.1, base16-bytestring >= 0.1 && < 0.2, deepseq >= 1.0 && < 1.5, fail >= 4.9.0.0 && < 4.10, half >= 0.2.2.3 && < 0.4, QuickCheck >= 2.9 && < 2.13, scientific >= 0.3 && < 0.4, tasty >= 0.11 && < 1.2, tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11, vector >= 0.10 && < 0.13 cborg-0.2.1.0/Setup.hs0000644000000000000000000000005613357736054012604 0ustar0000000000000000import Distribution.Simple main = defaultMain cborg-0.2.1.0/src/0000755000000000000000000000000013357736054011736 5ustar0000000000000000cborg-0.2.1.0/src/Codec/0000755000000000000000000000000013357736054012753 5ustar0000000000000000cborg-0.2.1.0/src/Codec/CBOR.hs0000644000000000000000000000640613357736054014042 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | -- Module : Codec.CBOR -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- 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. -} cborg-0.2.1.0/src/Codec/CBOR/0000755000000000000000000000000013357736054013500 5ustar0000000000000000cborg-0.2.1.0/src/Codec/CBOR/Encoding.hs-boot0000644000000000000000000000013513357736054016522 0ustar0000000000000000module Codec.CBOR.Encoding where newtype Encoding = Encoding (Tokens -> Tokens) data Tokenscborg-0.2.1.0/src/Codec/CBOR/Write.hs0000644000000000000000000006106613357736054015137 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Codec.CBOR.Write -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- Tools for writing out CBOR @'Encoding'@ values in -- a variety of forms. -- module Codec.CBOR.Write ( toBuilder -- :: Encoding -> B.Builder , toLazyByteString -- :: Encoding -> L.ByteString , toStrictByteString -- :: Encoding -> S.ByteString ) where #include "cbor.h" import Data.Bits import Data.Int #if ! MIN_VERSION_base(4,11,0) import Data.Monoid #endif import Data.Word import Foreign.Ptr import qualified Data.ByteString as S import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Internal as BI import Data.ByteString.Builder.Prim (condB, (>$<), (>*<)) import qualified Data.ByteString.Builder.Prim as P import qualified Data.ByteString.Builder.Prim.Internal as PI import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Data.Text.Encoding as T #if defined(OPTIMIZE_GMP) import Control.Exception.Base (assert) import GHC.Exts import qualified GHC.Integer.GMP.Internals as Gmp #if __GLASGOW_HASKELL__ < 710 import GHC.Word #endif #endif import qualified Codec.CBOR.ByteArray.Sliced as BAS import Codec.CBOR.Encoding import Codec.CBOR.Magic -------------------------------------------------------------------------------- -- | Turn an @'Encoding'@ into a lazy @'L.ByteString'@ in CBOR binary -- format. -- -- @since 0.2.0.0 toLazyByteString :: Encoding -- ^ The @'Encoding'@ of a CBOR value. -> L.ByteString -- ^ The encoded CBOR value. toLazyByteString = B.toLazyByteString . toBuilder -- | Turn an @'Encoding'@ into a strict @'S.ByteString'@ in CBOR binary -- format. -- -- @since 0.2.0.0 toStrictByteString :: Encoding -- ^ The @'Encoding'@ of a CBOR value. -> S.ByteString -- ^ The encoded value. toStrictByteString = L.toStrict . B.toLazyByteString . toBuilder -- | Turn an @'Encoding'@ into a @'L.ByteString'@ @'B.Builder'@ in CBOR -- binary format. -- -- @since 0.2.0.0 toBuilder :: Encoding -- ^ The @'Encoding'@ of a CBOR value. -> B.Builder -- ^ The encoded value as a @'B.Builder'@. toBuilder = \(Encoding vs0) -> BI.builder (step (vs0 TkEnd)) where step vs1 k (BI.BufferRange op0 ope0) = go vs1 op0 where go vs !op | op `plusPtr` bound <= ope0 = case vs of TkWord x vs' -> PI.runB wordMP x op >>= go vs' TkWord64 x vs' -> PI.runB word64MP x op >>= go vs' TkInt x vs' -> PI.runB intMP x op >>= go vs' TkInt64 x vs' -> PI.runB int64MP x op >>= go vs' 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' TkListLen x vs' -> PI.runB arrayLenMP x op >>= go vs' TkListBegin vs' -> PI.runB arrayBeginMP () op >>= go vs' TkMapLen x vs' -> PI.runB mapLenMP x op >>= go vs' TkMapBegin vs' -> PI.runB mapBeginMP () op >>= go vs' TkTag x vs' -> PI.runB tagMP x op >>= go vs' TkTag64 x vs' -> PI.runB tag64MP x op >>= go vs' #if defined(OPTIMIZE_GMP) -- This code is specialized for GMP implementation of Integer. By -- looking directly at the constructors we can avoid some checks. -- S# hold an Int, so we can just use intMP. TkInteger (Gmp.S# i) vs' -> PI.runB intMP (I# i) op >>= go vs' -- Jp# is guaranteed to be > 0. TkInteger integer@(Gmp.Jp# bigNat) vs' | integer <= fromIntegral (maxBound :: Word64) -> PI.runB word64MP (fromIntegral integer) op >>= go vs' | otherwise -> let buffer = BI.BufferRange op ope0 in BI.runBuilderWith (bigNatMP bigNat) (step vs' k) buffer -- Jn# is guaranteed to be < 0. TkInteger integer@(Gmp.Jn# bigNat) vs' | integer >= -1 - fromIntegral (maxBound :: Word64) -> PI.runB negInt64MP (fromIntegral (-1 - integer)) op >>= go vs' | otherwise -> let buffer = BI.BufferRange op ope0 in BI.runBuilderWith (negBigNatMP bigNat) (step vs' k) buffer #else TkInteger x vs' | x >= 0 , x <= fromIntegral (maxBound :: Word64) -> PI.runB word64MP (fromIntegral x) op >>= go vs' | x < 0 , x >= -1 - fromIntegral (maxBound :: Word64) -> PI.runB negInt64MP (fromIntegral (-1 - x)) op >>= go vs' | otherwise -> BI.runBuilderWith (integerMP x) (step vs' k) (BI.BufferRange op ope0) #endif TkBool False vs' -> PI.runB falseMP () op >>= go vs' TkBool True vs' -> PI.runB trueMP () op >>= go vs' TkNull vs' -> PI.runB nullMP () op >>= go vs' TkUndef vs' -> PI.runB undefMP () op >>= go vs' TkSimple w vs' -> PI.runB simpleMP w op >>= go vs' TkFloat16 f vs' -> PI.runB halfMP f op >>= go vs' TkFloat32 f vs' -> PI.runB floatMP f op >>= go vs' TkFloat64 f vs' -> PI.runB doubleMP f op >>= go vs' TkBreak vs' -> PI.runB breakMP () op >>= go vs' TkEnd -> k (BI.BufferRange op ope0) | otherwise = return $ BI.bufferFull bound op (step vs k) -- The maximum size in bytes of the fixed-size encodings bound :: Int bound = 9 header :: P.BoundedPrim Word8 header = P.liftFixedToBounded P.word8 constHeader :: Word8 -> P.BoundedPrim () constHeader h = P.liftFixedToBounded (const h >$< P.word8) withHeader :: P.FixedPrim a -> P.BoundedPrim (Word8, a) withHeader p = P.liftFixedToBounded (P.word8 >*< p) withConstHeader :: Word8 -> P.FixedPrim a -> P.BoundedPrim a withConstHeader h p = P.liftFixedToBounded ((,) h >$< (P.word8 >*< p)) {- From RFC 7049: Major type 0: an unsigned integer. The 5-bit additional information is either the integer itself (for additional information values 0 through 23) or the length of additional data. Additional information 24 means the value is represented in an additional uint8_t, 25 means a uint16_t, 26 means a uint32_t, and 27 means a uint64_t. For example, the integer 10 is denoted as the one byte 0b000_01010 (major type 0, additional information 10). The integer 500 would be 0b000_11001 (major type 0, additional information 25) followed by the two bytes 0x01f4, which is 500 in decimal. -} {-# INLINE wordMP #-} wordMP :: P.BoundedPrim Word wordMP = condB (<= 0x17) (fromIntegral >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 24 P.word8) $ condB (<= 0xffff) (fromIntegral >$< withConstHeader 25 P.word16BE) $ #if defined(ARCH_64bit) condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 26 P.word32BE) $ (fromIntegral >$< withConstHeader 27 P.word64BE) #else (fromIntegral >$< withConstHeader 26 P.word32BE) #endif {-# INLINE word64MP #-} word64MP :: P.BoundedPrim Word64 word64MP = condB (<= 0x17) (fromIntegral >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 24 P.word8) $ condB (<= 0xffff) (fromIntegral >$< withConstHeader 25 P.word16BE) $ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 26 P.word32BE) $ (fromIntegral >$< withConstHeader 27 P.word64BE) {- From RFC 7049: Major type 1: a negative integer. The encoding follows the rules for unsigned integers (major type 0), except that the value is then -1 minus the encoded unsigned integer. For example, the integer -500 would be 0b001_11001 (major type 1, additional information 25) followed by the two bytes 0x01f3, which is 499 in decimal. -} negInt64MP :: P.BoundedPrim Word64 negInt64MP = condB (<= 0x17) (fromIntegral . (0x20 +) >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 0x38 P.word8) $ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0x39 P.word16BE) $ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x3a P.word32BE) $ (fromIntegral >$< withConstHeader 0x3b P.word64BE) {- Major types 0 and 1 are designed in such a way that they can be encoded in C from a signed integer without actually doing an if-then- else for positive/negative (Figure 2). This uses the fact that (-1-n), the transformation for major type 1, is the same as ~n (bitwise complement) in C unsigned arithmetic; ~n can then be expressed as (-1)^n for the negative case, while 0^n leaves n unchanged for non-negative. The sign of a number can be converted to -1 for negative and 0 for non-negative (0 or positive) by arithmetic- shifting the number by one bit less than the bit length of the number (for example, by 63 for 64-bit numbers). void encode_sint(int64_t n) { uint64t ui = n >> 63; // extend sign to whole length mt = ui & 0x20; // extract major type ui ^= n; // complement negatives if (ui < 24) *p++ = mt + ui; else if (ui < 256) { *p++ = mt + 24; *p++ = ui; } else ... Figure 2: Pseudocode for Encoding a Signed Integer -} {-# INLINE intMP #-} intMP :: P.BoundedPrim Int intMP = prep >$< ( condB ((<= 0x17) . snd) (encIntSmall >$< header) $ condB ((<= 0xff) . snd) (encInt8 >$< withHeader P.word8) $ condB ((<= 0xffff) . snd) (encInt16 >$< withHeader P.word16BE) $ #if defined(ARCH_64bit) condB ((<= 0xffffffff) . snd) (encInt32 >$< withHeader P.word32BE) (encInt64 >$< withHeader P.word64BE) #else (encInt32 >$< withHeader P.word32BE) #endif ) where prep :: Int -> (Word8, Word) prep n = (mt, ui) where sign :: Word -- extend sign to whole length sign = fromIntegral (n `unsafeShiftR` intBits) #if MIN_VERSION_base(4,7,0) intBits = finiteBitSize (undefined :: Int) - 1 #else intBits = bitSize (undefined :: Int) - 1 #endif mt :: Word8 -- select major type mt = fromIntegral (sign .&. 0x20) ui :: Word -- complement negatives ui = fromIntegral n `xor` sign encIntSmall :: (Word8, Word) -> Word8 encIntSmall (mt, ui) = mt + fromIntegral ui encInt8 (mt, ui) = (mt + 24, fromIntegral ui) encInt16 (mt, ui) = (mt + 25, fromIntegral ui) encInt32 (mt, ui) = (mt + 26, fromIntegral ui) #if defined(ARCH_64bit) encInt64 (mt, ui) = (mt + 27, fromIntegral ui) #endif {-# INLINE int64MP #-} int64MP :: P.BoundedPrim Int64 int64MP = prep >$< ( condB ((<= 0x17) . snd) (encIntSmall >$< header) $ condB ((<= 0xff) . snd) (encInt8 >$< withHeader P.word8) $ condB ((<= 0xffff) . snd) (encInt16 >$< withHeader P.word16BE) $ condB ((<= 0xffffffff) . snd) (encInt32 >$< withHeader P.word32BE) (encInt64 >$< withHeader P.word64BE) ) where prep :: Int64 -> (Word8, Word64) prep n = (mt, ui) where sign :: Word64 -- extend sign to whole length sign = fromIntegral (n `unsafeShiftR` intBits) #if MIN_VERSION_base(4,7,0) intBits = finiteBitSize (undefined :: Int64) - 1 #else intBits = bitSize (undefined :: Int64) - 1 #endif mt :: Word8 -- select major type mt = fromIntegral (sign .&. 0x20) ui :: Word64 -- complement negatives ui = fromIntegral n `xor` sign encIntSmall (mt, ui) = mt + fromIntegral ui encInt8 (mt, ui) = (mt + 24, fromIntegral ui) encInt16 (mt, ui) = (mt + 25, fromIntegral ui) encInt32 (mt, ui) = (mt + 26, fromIntegral ui) encInt64 (mt, ui) = (mt + 27, fromIntegral ui) {- Major type 2: a byte string. The string's length in bytes is represented following the rules for positive integers (major type 0). For example, a byte string whose length is 5 would have an initial byte of 0b010_00101 (major type 2, additional information 5 for the length), followed by 5 bytes of binary content. A byte string whose length is 500 would have 3 initial bytes of 0b010_11001 (major type 2, additional information 25 to indicate a two-byte length) followed by the two bytes 0x01f4 for a length of 500, followed by 500 bytes of binary content. -} bytesMP :: S.ByteString -> B.Builder bytesMP bs = P.primBounded bytesLenMP (fromIntegral $ S.length bs) <> B.byteString bs bytesLenMP :: P.BoundedPrim Word bytesLenMP = condB (<= 0x17) (fromIntegral . (0x40 +) >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 0x58 P.word8) $ 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 {- Major type 3: a text string, specifically a string of Unicode characters that is encoded as UTF-8 [RFC3629]. The format of this type is identical to that of byte strings (major type 2), that is, as with major type 2, the length gives the number of bytes. This type is provided for systems that need to interpret or display human-readable text, and allows the differentiation between unstructured bytes and text that has a specified repertoire and encoding. In contrast to formats such as JSON, the Unicode characters in this type are never escaped. Thus, a newline character (U+000A) is always represented in a string as the byte 0x0a, and never as the bytes 0x5c6e (the characters "\" and "n") or as 0x5c7530303061 (the characters "\", "u", "0", "0", "0", and "a"). -} stringMP :: T.Text -> B.Builder stringMP t = P.primBounded stringLenMP (fromIntegral $ S.length bs) <> B.byteString bs where bs = T.encodeUtf8 t stringLenMP :: P.BoundedPrim Word stringLenMP = condB (<= 0x17) (fromIntegral . (0x60 +) >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 0x78 P.word8) $ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0x79 P.word16BE) $ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x7a P.word32BE) $ (fromIntegral >$< withConstHeader 0x7b P.word64BE) 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 byte strings (major type 2), except that the length denotes the number of data items, not the length in bytes that the array takes up. Items in an array do not need to all be of the same type. For example, an array that contains 10 items of any type would have an initial byte of 0b100_01010 (major type of 4, additional information of 10 for the length) followed by the 10 remaining items. -} arrayLenMP :: P.BoundedPrim Word arrayLenMP = condB (<= 0x17) (fromIntegral . (0x80 +) >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 0x98 P.word8) $ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0x99 P.word16BE) $ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0x9a P.word32BE) $ (fromIntegral >$< withConstHeader 0x9b P.word64BE) arrayBeginMP :: P.BoundedPrim () arrayBeginMP = constHeader 0x9f {- Major type 5: a map of pairs of data items. Maps are also called tables, dictionaries, hashes, or objects (in JSON). A map is comprised of pairs of data items, each pair consisting of a key that is immediately followed by a value. The map's length follows the rules for byte strings (major type 2), except that the length denotes the number of pairs, not the length in bytes that the map takes up. For example, a map that contains 9 pairs would have an initial byte of 0b101_01001 (major type of 5, additional information of 9 for the number of pairs) followed by the 18 remaining items. The first item is the first key, the second item is the first value, the third item is the second key, and so on. A map that has duplicate keys may be well-formed, but it is not valid, and thus it causes indeterminate decoding; see also Section 3.7. -} mapLenMP :: P.BoundedPrim Word mapLenMP = condB (<= 0x17) (fromIntegral . (0xa0 +) >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 0xb8 P.word8) $ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0xb9 P.word16BE) $ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0xba P.word32BE) $ (fromIntegral >$< withConstHeader 0xbb P.word64BE) mapBeginMP :: P.BoundedPrim () mapBeginMP = constHeader 0xbf {- Major type 6: optional semantic tagging of other major types. In CBOR, a data item can optionally be preceded by a tag to give it additional semantics while retaining its structure. The tag is major type 6, and represents an integer number as indicated by the tag's integer value; the (sole) data item is carried as content data. The initial bytes of the tag follow the rules for positive integers (major type 0). -} tagMP :: P.BoundedPrim Word tagMP = condB (<= 0x17) (fromIntegral . (0xc0 +) >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 0xd8 P.word8) $ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0xd9 P.word16BE) $ #if defined(ARCH_64bit) condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0xda P.word32BE) $ (fromIntegral >$< withConstHeader 0xdb P.word64BE) #else (fromIntegral >$< withConstHeader 0xda P.word32BE) #endif tag64MP :: P.BoundedPrim Word64 tag64MP = condB (<= 0x17) (fromIntegral . (0xc0 +) >$< header) $ condB (<= 0xff) (fromIntegral >$< withConstHeader 0xd8 P.word8) $ condB (<= 0xffff) (fromIntegral >$< withConstHeader 0xd9 P.word16BE) $ condB (<= 0xffffffff) (fromIntegral >$< withConstHeader 0xda P.word32BE) $ (fromIntegral >$< withConstHeader 0xdb P.word64BE) {- Major type 7: floating-point numbers and simple data types that need no content, as well as the "break" stop code. Major type 7 is for two types of data: floating-point numbers and "simple values" that do not need any content. Each value of the 5-bit additional information in the initial byte has its own separate meaning, as defined in Table 1. Like the major types for integers, items of this major type do not carry content data; all the information is in the initial bytes. +-------------+--------------------------------------------------+ | 5-Bit Value | Semantics | +-------------+--------------------------------------------------+ | 0..23 | Simple value (value 0..23) | | | | | 24 | Simple value (value 32..255 in following byte) | | | | | 25 | IEEE 754 Half-Precision Float (16 bits follow) | | | | | 26 | IEEE 754 Single-Precision Float (32 bits follow) | | | | | 27 | IEEE 754 Double-Precision Float (64 bits follow) | | | | | 28-30 | (Unassigned) | | | | | 31 | "break" stop code for indefinite-length items | +-------------+--------------------------------------------------+ -} simpleMP :: P.BoundedPrim Word8 simpleMP = condB (<= 0x17) ((0xe0 +) >$< header) $ (withConstHeader 0xf8 P.word8) falseMP :: P.BoundedPrim () falseMP = constHeader 0xf4 trueMP :: P.BoundedPrim () trueMP = constHeader 0xf5 nullMP :: P.BoundedPrim () nullMP = constHeader 0xf6 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 = condB isNaN canonicalNaN (floatToWord16 >$< withConstHeader 0xf9 P.word16BE) floatMP :: P.BoundedPrim Float floatMP = condB isNaN canonicalNaN (withConstHeader 0xfa P.floatBE) doubleMP :: P.BoundedPrim Double doubleMP = condB isNaN canonicalNaN (withConstHeader 0xfb P.doubleBE) breakMP :: P.BoundedPrim () breakMP = constHeader 0xff #if defined(OPTIMIZE_GMP) -- ---------------------------------------- -- -- Implementation optimized for integer-gmp -- -- ---------------------------------------- -- bigNatMP :: Gmp.BigNat -> B.Builder bigNatMP n = P.primBounded header 0xc2 <> bigNatToBuilder n negBigNatMP :: Gmp.BigNat -> B.Builder negBigNatMP n = -- If value `n` is stored in CBOR, it is interpreted as -1 - n. Since BigNat -- already represents n (note: it's unsigned), we simply decrement it to get -- the correct encoding. P.primBounded header 0xc3 <> bigNatToBuilder (Gmp.minusBigNatWord n (int2Word# 1#)) bigNatToBuilder :: Gmp.BigNat -> B.Builder bigNatToBuilder = bigNatBuilder where bigNatBuilder :: Gmp.BigNat -> B.Builder bigNatBuilder bigNat = let sizeW# = Gmp.sizeInBaseBigNat bigNat 256# bounded = PI.boudedPrim (I# (word2Int# sizeW#)) (dumpBigNat sizeW#) in P.primBounded bytesLenMP (W# sizeW#) <> P.primBounded bounded bigNat dumpBigNat :: Word# -> Gmp.BigNat -> Ptr a -> IO (Ptr a) dumpBigNat sizeW# bigNat ptr@(Ptr addr#) = do -- The last parameter (`1#`) makes the export function use big endian -- encoding. (W# written#) <- Gmp.exportBigNatToAddr bigNat addr# 1# let !newPtr = ptr `plusPtr` (I# (word2Int# written#)) sanity = isTrue# (sizeW# `eqWord#` written#) return $ assert sanity newPtr #else -- ---------------------- -- -- Generic implementation -- -- ---------------------- -- integerMP :: Integer -> B.Builder integerMP n | n >= 0 = P.primBounded header 0xc2 <> integerToBuilder n | otherwise = P.primBounded header 0xc3 <> integerToBuilder (-1 - n) integerToBuilder :: Integer -> B.Builder integerToBuilder n = bytesMP (integerToBytes n) integerToBytes :: Integer -> S.ByteString integerToBytes n0 | n0 == 0 = S.pack [0] | otherwise = S.pack (reverse (go n0)) where go n | n == 0 = [] | otherwise = narrow n : go (n `shiftR` 8) narrow :: Integer -> Word8 narrow = fromIntegral #endif cborg-0.2.1.0/src/Codec/CBOR/Read.hs0000644000000000000000000031437713357736054014726 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -- 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 #-} -- | -- Module : Codec.CBOR.Read -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- Tools for reading values in a CBOR-encoded format -- back into ordinary values. -- module Codec.CBOR.Read ( 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 ) where #include "cbor.h" #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import GHC.Int import Control.DeepSeq import Control.Monad (ap) import Control.Monad.ST import Data.Array.IArray import Data.Array.Unboxed import qualified Data.Array.Base as A import Data.Monoid import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Internal as LBS import qualified Data.Text as T 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 -- We do all numeric conversions explicitly to be careful about overflows. import Prelude hiding (fromIntegral) 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 import Codec.CBOR.Magic -------------------------------------------------------------------------------- -- | An exception type that may be returned (by pure functions) or -- thrown (by IO actions) that fail to deserialise a given input. -- -- @since 0.2.0.0 data DeserialiseFailure = DeserialiseFailure ByteOffset String deriving (Eq, Show, Typeable) instance NFData DeserialiseFailure where rnf (DeserialiseFailure offset msg) = rnf offset `seq` rnf msg `seq` () instance Exception DeserialiseFailure where #if MIN_VERSION_base(4,8,0) displayException (DeserialiseFailure off msg) = "Codec.CBOR: deserialising failed at offset " ++ show off ++ " : " ++ msg #endif -- | An Incremental decoder, used to represent the result of -- attempting to run a decoder over a given input, and return a value -- of type @a@. data IDecode s a = -- | The decoder has consumed the available input and needs more -- to continue. Provide @'Just'@ if more input is available and -- @'Nothing'@ otherwise, and you will get a new @'IDecode'@. Partial (Maybe BS.ByteString -> ST s (IDecode s a)) -- | The decoder has successfully finished. Except for the output -- value you also get any unused input as well as the number of -- bytes consumed. | Done !BS.ByteString {-# UNPACK #-} !ByteOffset a -- | The decoder ran into an error. The decoder either used -- @'fail'@ or was not provided enough input. Contains any -- unconsumed input, the number of bytes consumed, and a -- @'DeserialiseFailure'@ exception describing the reason why the -- failure occurred. | Fail !BS.ByteString {-# UNPACK #-} !ByteOffset DeserialiseFailure -- | 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. -- -- @since 0.2.0.0 deserialiseFromBytes :: (forall s. Decoder s a) -> LBS.ByteString -> Either DeserialiseFailure (LBS.ByteString, a) deserialiseFromBytes 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, ByteOffset, a) runIDecode d lbs = runST (go lbs =<< d) where go :: LBS.ByteString -> IDecode s a -> 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. -- -- @since 0.2.0.0 deserialiseIncremental :: Decoder s a -> ST s (IDecode s a) deserialiseIncremental decoder = do da <- getDecodeAction decoder runIncrementalDecoder (runDecodeAction da) ---------------------------------------------- -- A monad for building incremental decoders -- -- | Simple alias for @'Int64'@, used to make types more descriptive. type ByteOffset = Int64 newtype IncrementalDecoder s a = IncrementalDecoder { unIncrementalDecoder :: forall r. (a -> ST s (IDecode s r)) -> ST s (IDecode s r) } instance Functor (IncrementalDecoder s) where fmap f a = a >>= return . f instance Applicative (IncrementalDecoder s) where pure x = IncrementalDecoder $ \k -> k x (<*>) = ap instance Monad (IncrementalDecoder s) where return = pure {-# INLINE (>>=) #-} m >>= f = IncrementalDecoder $ \k -> unIncrementalDecoder m $ \x -> unIncrementalDecoder (f x) k runIncrementalDecoder :: IncrementalDecoder s (ByteString, ByteOffset, a) -> ST s (IDecode s a) runIncrementalDecoder (IncrementalDecoder f) = f (\(trailing, off, x) -> return $ Done trailing off x) decodeFail :: ByteString -> ByteOffset -> String -> IncrementalDecoder s a decodeFail trailing off msg = IncrementalDecoder $ \_ -> return $ Fail trailing off exn where exn = DeserialiseFailure off msg needChunk :: IncrementalDecoder s (Maybe ByteString) needChunk = IncrementalDecoder $ \k -> return $ Partial $ \mbs -> k mbs lift :: ST s a -> IncrementalDecoder s a lift action = IncrementalDecoder (\k -> action >>= k) -------------------------------------------- -- The main decoder -- -- The top level entry point runDecodeAction :: DecodeAction s a -> IncrementalDecoder s (ByteString, ByteOffset, a) runDecodeAction (D.Fail msg) = decodeFail BS.empty 0 msg runDecodeAction (D.Done x) = return (BS.empty, 0, x) runDecodeAction (D.PeekAvailable k) = lift (k 0#) >>= runDecodeAction runDecodeAction da = do mbs <- needChunk case mbs of Nothing -> decodeFail BS.empty 0 "end of input" Just bs -> go_slow da bs 0 -- The decoder is split into a fast path and a slow path. The fast path is -- used for a single input chunk. It decodes as far as it can, reading only -- whole tokens that fit within the input chunk. When it cannot read any -- further it returns control to the slow path. The slow path fixes up all the -- complicated corner cases with tokens that span chunk boundaries, gets more -- input and then goes back into the fast path. -- -- The idea is that chunks are usually large, and we can use simpler and -- faster code if we don't make it deal with the general case of tokens that -- span chunk boundaries. -- These are all the ways in which the fast path can finish, and return -- control to the slow path. In particular there are three different cases -- of tokens spanning a chunk boundary. -- data SlowPath s a = 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 -- the main version 'go_fast' and a version used when we are near the end of -- the chunk, 'go_fast_end'. -- -- This version can then do fewer tests when we're not near the end of the -- chunk, in particular we just check if there's enough input buffer space -- left for the largest possible fixed-size token (8+1 bytes). -- go_fast :: ByteString -> DecodeAction s a -> ST s (SlowPath s a) go_fast !bs da | BS.length bs < 9 = go_fast_end bs da go_fast !bs da@(ConsumeWord k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeWord8 k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) -> case gtWord# w# 0xff## of 0# -> k w# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da go_fast !bs da@(ConsumeWord16 k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) -> case gtWord# w# 0xffff## of 0# -> k w# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da go_fast !bs da@(ConsumeWord32 k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) -> #if defined(ARCH_32bit) k w# >>= go_fast (BS.unsafeDrop sz bs) #else case gtWord# w# 0xffffffff## of 0# -> k w# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da #endif go_fast !bs da@(ConsumeNegWord k) = case tryConsumeNegWord (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (W# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeInt k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeInt8 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# -> k n# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da go_fast !bs da@(ConsumeInt16 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# -> k n# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da go_fast !bs da@(ConsumeInt32 k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I# n#) -> #if defined(ARCH_32bit) k n# >>= go_fast (BS.unsafeDrop sz bs) #else case (n# ># 0x7fffffff#) `orI#` (n# <# -0x80000000#) of 0# -> k n# >>= go_fast (BS.unsafeDrop sz bs) _ -> go_fast_end bs da #endif go_fast !bs da@(ConsumeListLen k) = case tryConsumeListLen (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeMapLen k) = case tryConsumeMapLen (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeTag k) = case tryConsumeTag (BS.unsafeHead bs) bs of 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 :: Word# -> Int# 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 :: Int# -> Int# 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 DecodedToken sz (W64# w#) -> k w# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeNegWord64 k) = case tryConsumeNegWord64 (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@(ConsumeInt64 k) = case tryConsumeInt64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeListLen64 k) = case tryConsumeListLen64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeMapLen64 k) = case tryConsumeMapLen64 (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I64# i#) -> k i# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeTag64 k) = 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 sz w# -> 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 go_fast !bs da@(ConsumeFloat k) = case tryConsumeFloat (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (F# f#) -> k f# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeDouble k) = case tryConsumeDouble (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (D# f#) -> k f# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeBytes k) = case tryConsumeBytes (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da 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) -> case T.decodeUtf8' str of Right t -> k t >>= go_fast (BS.unsafeDrop sz bs) Left _e -> return $! SlowFail bs "invalid UTF8" 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 DecodedToken sz b -> k b >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeSimple k) = case tryConsumeSimple (BS.unsafeHead bs) bs of 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@(ConsumeBytesCanonical k) = case tryConsumeBytes (BS.unsafeHead bs) bs of DecodedToken sz (Fits True bstr) -> k bstr >>= go_fast (BS.unsafeDrop sz bs) DecodedToken sz (TooLong True len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len _ -> go_fast_end bs da go_fast !bs da@(ConsumeByteArrayCanonical k) = case tryConsumeBytes (BS.unsafeHead bs) bs of DecodedToken sz (Fits True str) -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs) DecodedToken sz (TooLong True len) -> return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len _ -> go_fast_end bs da go_fast !bs da@(ConsumeStringCanonical k) = case tryConsumeString (BS.unsafeHead bs) bs of DecodedToken sz (Fits True str) -> case T.decodeUtf8' str of Right t -> k t >>= go_fast (BS.unsafeDrop sz bs) Left _e -> return $! SlowFail bs "invalid UTF8" DecodedToken sz (TooLong True len) -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len _ -> go_fast_end bs da go_fast !bs da@(ConsumeUtf8ByteArrayCanonical k) = case tryConsumeString (BS.unsafeHead bs) bs of DecodedToken sz (Fits True str) -> k (BA.fromByteString str) >>= go_fast (BS.unsafeDrop sz bs) DecodedToken sz (TooLong True len) -> return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len _ -> 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 DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeStringIndef k) = case tryConsumeStringIndef (BS.unsafeHead bs) of DecodeFailure -> go_fast_end bs da DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeListLenIndef k) = case tryConsumeListLenIndef (BS.unsafeHead bs) of DecodeFailure -> go_fast_end bs da DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeMapLenIndef k) = case tryConsumeMapLenIndef (BS.unsafeHead bs) of DecodeFailure -> go_fast_end bs da DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeNull k) = case tryConsumeNull (BS.unsafeHead bs) of DecodeFailure -> go_fast_end bs da DecodedToken sz _ -> k >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeListLenOrIndef k) = case tryConsumeListLenOrIndef (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs da@(ConsumeMapLenOrIndef k) = case tryConsumeMapLenOrIndef (BS.unsafeHead bs) bs of DecodeFailure -> go_fast_end bs da DecodedToken sz (I# n#) -> k n# >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs (ConsumeBreakOr k) = case tryConsumeBreakOr (BS.unsafeHead bs) of DecodeFailure -> k False >>= go_fast bs DecodedToken sz _ -> k True >>= go_fast (BS.unsafeDrop sz bs) go_fast !bs (PeekTokenType k) = let !hdr = BS.unsafeHead bs !tkty = decodeTokenTypeTable `A.unsafeAt` word8ToInt hdr in k tkty >>= go_fast bs go_fast !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast bs go_fast !bs da@D.Fail{} = go_fast_end bs da go_fast !bs da@D.Done{} = go_fast_end bs da -- This variant of the fast path has to do a few more checks because we're -- near the end of the chunk. The guarantee we provide here is that we will -- decode any tokens where the whole token fits within the input buffer. So -- if we return with input buffer space still unconsumed (and we're not done -- or failed) then there's one remaining token that spans the end of the -- input chunk (the slow path fixup code relies on this guarantee). -- go_fast_end :: ByteString -> DecodeAction s a -> ST s (SlowPath s a) -- these three cases don't need any input go_fast_end !bs (D.Fail msg) = return $! SlowFail bs msg go_fast_end !bs (D.Done x) = return $! FastDone bs x go_fast_end !bs (PeekAvailable k) = k (case BS.length bs of I# len# -> len#) >>= go_fast_end bs -- the next two cases only need the 1 byte token header go_fast_end !bs da | BS.null bs = return $! SlowDecodeAction bs da go_fast_end !bs (ConsumeBreakOr k) = case tryConsumeBreakOr (BS.unsafeHead bs) of DecodeFailure -> k False >>= go_fast_end bs DecodedToken sz _ -> k True >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (PeekTokenType k) = let !hdr = BS.unsafeHead bs !tkty = decodeTokenTypeTable `A.unsafeAt` word8ToInt hdr in k tkty >>= go_fast_end bs -- all the remaining cases have to decode the current token go_fast_end !bs da | let !hdr = BS.unsafeHead bs , BS.length bs < tokenSize hdr = return $! SlowDecodeAction bs da go_fast_end !bs (ConsumeWord k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word" DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeWord8 k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word8" DecodedToken sz (W# w#) -> case gtWord# w# 0xff## of 0# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) _ -> return $! SlowFail bs "expected word8" go_fast_end !bs (ConsumeWord16 k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word16" DecodedToken sz (W# w#) -> case gtWord# w# 0xffff## of 0# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) _ -> return $! SlowFail bs "expected word16" go_fast_end !bs (ConsumeWord32 k) = case tryConsumeWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word32" DecodedToken sz (W# w#) -> #if defined(ARCH_32bit) k w# >>= go_fast_end (BS.unsafeDrop sz bs) #else case gtWord# w# 0xffffffff## of 0# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) _ -> return $! SlowFail bs "expected word32" #endif go_fast_end !bs (ConsumeNegWord k) = case tryConsumeNegWord (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected negative int" DecodedToken sz (W# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeInt k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int" DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeInt8 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# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) _ -> return $! SlowFail bs "expected int8" go_fast_end !bs (ConsumeInt16 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# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) _ -> return $! SlowFail bs "expected int16" go_fast_end !bs (ConsumeInt32 k) = case tryConsumeInt (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int32" DecodedToken sz (I# n#) -> #if defined(ARCH_32bit) k n# >>= go_fast_end (BS.unsafeDrop sz bs) #else case (n# ># 0x7fffffff#) `orI#` (n# <# -0x80000000#) of 0# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) _ -> return $! SlowFail bs "expected int32" #endif go_fast_end !bs (ConsumeListLen k) = case tryConsumeListLen (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected list len" DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeMapLen k) = case tryConsumeMapLen (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected map len" DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeTag k) = case tryConsumeTag (BS.unsafeHead bs) bs of 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 :: Word# -> Int# 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 :: Int# -> Int# 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" DecodedToken sz (W64# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeNegWord64 k) = case tryConsumeNegWord64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected negative int" DecodedToken sz (W64# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeInt64 k) = case tryConsumeInt64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int64" DecodedToken sz (I64# i#) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeListLen64 k) = case tryConsumeListLen64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected list len 64" DecodedToken sz (I64# i#) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeMapLen64 k) = case tryConsumeMapLen64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected map len 64" DecodedToken sz (I64# i#) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeTag64 k) = case tryConsumeTag64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected tag64" DecodedToken sz (W64# w#) -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeWord64Canonical k) = case tryConsumeWord64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected word64" DecodedToken sz (W64# w#) | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical word64" go_fast_end !bs (ConsumeNegWord64Canonical k) = case tryConsumeNegWord64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected negative int" DecodedToken sz (W64# w#) | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical negative int" go_fast_end !bs (ConsumeInt64Canonical k) = case tryConsumeInt64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected int64" DecodedToken sz (I64# i#) | isInt64Canonical sz i# -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical int64" go_fast_end !bs (ConsumeListLen64Canonical k) = case tryConsumeListLen64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected list len 64" DecodedToken sz (I64# i#) -- List length can't be negative, cast it to Word64#. | isWord64Canonical sz (int64ToWord64# i#) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical list len 64" go_fast_end !bs (ConsumeMapLen64Canonical k) = case tryConsumeMapLen64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected map len 64" DecodedToken sz (I64# i#) -- Map length can't be negative, cast it to Word64#. | isWord64Canonical sz (int64ToWord64# i#) -> k i# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical map len 64" go_fast_end !bs (ConsumeTag64Canonical k) = case tryConsumeTag64 (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected tag64" DecodedToken sz (W64# w#) | isWord64Canonical sz w# -> k w# >>= go_fast_end (BS.unsafeDrop sz bs) | otherwise -> return $! SlowFail bs "non-canonical tag64" #endif 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 (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 (ConsumeFloat k) = case tryConsumeFloat (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected float" DecodedToken sz (F# f#) -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeDouble k) = case tryConsumeDouble (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected double" DecodedToken sz (D# f#) -> k f# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeBytes k) = case tryConsumeBytes (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected bytes" 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) -> case T.decodeUtf8' str of Right t -> k t >>= go_fast_end (BS.unsafeDrop sz bs) Left _e -> return $! SlowFail bs "invalid UTF8" 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" DecodedToken sz b -> k b >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeSimple k) = case tryConsumeSimple (BS.unsafeHead bs) bs of 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 True n) -> k n >>= go_fast_end (BS.unsafeDrop sz bs) DecodedToken sz (BigUIntNeedBody True len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContCanonicalBigUIntNeedBody k) len DecodedToken sz (BigNIntNeedBody True len) -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) (adjustContCanonicalBigNIntNeedBody k) len DecodedToken sz BigUIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContCanonicalBigUIntNeedHeader k) DecodedToken sz BigNIntNeedHeader -> return $! SlowDecodeAction (BS.unsafeDrop sz bs) (adjustContCanonicalBigNIntNeedHeader k) _ -> return $! SlowFail bs "non-canonical integer" 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 (ConsumeBytesCanonical k) = case tryConsumeBytes (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected bytes" DecodedToken sz token -> case token of Fits True bstr -> k bstr >>= go_fast_end (BS.unsafeDrop sz bs) TooLong True len -> return $! SlowConsumeTokenBytes (BS.unsafeDrop sz bs) k len _ -> return $! SlowFail bs "non-canonical length prefix" go_fast_end !bs (ConsumeByteArrayCanonical k) = case tryConsumeBytes (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected string" DecodedToken sz token -> case token of Fits True str -> (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs) TooLong True len -> return $! SlowConsumeTokenByteArray (BS.unsafeDrop sz bs) k len _ -> return $! SlowFail bs "non-canonical length prefix" go_fast_end !bs (ConsumeStringCanonical k) = case tryConsumeString (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected string" DecodedToken sz token -> case token of Fits True str -> case T.decodeUtf8' str of Right t -> k t >>= go_fast_end (BS.unsafeDrop sz bs) Left _e -> return $! SlowFail bs "invalid UTF8" TooLong True len -> return $! SlowConsumeTokenString (BS.unsafeDrop sz bs) k len _ -> return $! SlowFail bs "non-canonical length prefix" go_fast_end !bs (ConsumeUtf8ByteArrayCanonical k) = case tryConsumeString (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected string" DecodedToken sz token -> case token of Fits True str -> (k $! BA.fromByteString str) >>= go_fast_end (BS.unsafeDrop sz bs) TooLong True len -> return $! SlowConsumeTokenUtf8ByteArray (BS.unsafeDrop sz bs) k len _ -> return $! SlowFail bs "non-canonical length prefix" 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" DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeStringIndef k) = case tryConsumeStringIndef (BS.unsafeHead bs) of DecodeFailure -> return $! SlowFail bs "expected string start" DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeListLenIndef k) = case tryConsumeListLenIndef (BS.unsafeHead bs) of DecodeFailure -> return $! SlowFail bs "expected list start" DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeMapLenIndef k) = case tryConsumeMapLenIndef (BS.unsafeHead bs) of DecodeFailure -> return $! SlowFail bs "expected map start" DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeNull k) = case tryConsumeNull (BS.unsafeHead bs) of DecodeFailure -> return $! SlowFail bs "expected null" DecodedToken sz _ -> k >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeListLenOrIndef k) = case tryConsumeListLenOrIndef (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected list len or indef" DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) go_fast_end !bs (ConsumeMapLenOrIndef k) = case tryConsumeMapLenOrIndef (BS.unsafeHead bs) bs of DecodeFailure -> return $! SlowFail bs "expected map len or indef" DecodedToken sz (I# n#) -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) -- The slow path starts off by running the fast path on the current chunk -- then looking at where it finished, fixing up the chunk boundary issues, -- getting more input and going around again. -- -- The offset here is the offset after of all data consumed so far, -- so not including the current chunk. -- go_slow :: DecodeAction s a -> ByteString -> ByteOffset -> IncrementalDecoder s (ByteString, ByteOffset, a) go_slow da bs !offset = do slowpath <- lift $ go_fast bs da case slowpath of FastDone bs' x -> return (bs', offset', x) where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowConsumeTokenBytes bs' k len -> do (bstr, bs'') <- getTokenVarLen len bs' offset' lift (k bstr) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) where !offset' = offset + intToInt64 (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' + intToInt64 len) where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowConsumeTokenString bs' k len -> do (bstr, bs'') <- getTokenVarLen len bs' offset' case T.decodeUtf8' bstr of Right str -> lift (k str) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) Left _e -> decodeFail bs' offset' "invalid UTF8" where !offset' = offset + intToInt64 (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' + intToInt64 len) where !offset' = offset + intToInt64 (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 -- so we can get more input and carry on mbs <- needChunk case mbs of Nothing -> decodeFail bs' offset' "end of input" Just bs'' -> go_slow da' bs'' offset' where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowDecodeAction bs' da' -> -- of course we should only end up here when we really are out of -- input, otherwise go_fast_end could have continued assert (BS.length bs' < tokenSize (BS.head bs')) $ go_slow_fixup da' bs' offset' where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') SlowFail bs' msg -> decodeFail bs' offset' msg where !offset' = offset + intToInt64 (BS.length bs - BS.length bs') -- The complicated case is when a token spans a chunk boundary. -- -- Our goal is to get enough input so that go_fast_end can consume exactly one -- token without need for further fixups. -- go_slow_fixup :: DecodeAction s a -> ByteString -> ByteOffset -> IncrementalDecoder s (ByteString, ByteOffset, a) go_slow_fixup da !bs !offset = do let !hdr = BS.head bs !sz = tokenSize hdr mbs <- needChunk case mbs of Nothing -> decodeFail bs offset "end of input" Just bs' -- We have enough input now, try reading one final token | BS.length bs + BS.length bs' >= sz -> go_slow_overlapped da sz bs bs' offset -- We still don't have enough input, get more | otherwise -> go_slow_fixup da (bs <> bs') offset -- We've now got more input, but we have one token that spanned the old and -- new input buffers, so we have to decode that one before carrying on go_slow_overlapped :: DecodeAction s a -> Int -> ByteString -> ByteString -> ByteOffset -> IncrementalDecoder s (ByteString, ByteOffset, a) go_slow_overlapped da sz bs_cur bs_next !offset = -- we have: -- sz the size of the pending input token -- bs_cur the tail end of the previous input buffer -- bs_next the next input chunk -- we know the old buffer is too small, but the combo is enough assert (BS.length bs_cur < sz) $ assert (BS.length bs_cur + BS.length bs_next >= sz) $ -- we make: -- bs_tok a buffer containing only the pending input token -- bs' the tail of the next input chunk, -- which will become the next input buffer let bs_tok = bs_cur <> BS.unsafeTake (sz - BS.length bs_cur) bs_next bs' = BS.unsafeDrop (sz - BS.length bs_cur) bs_next offset' = offset + intToInt64 sz in -- so the token chunk should be exactly the right size assert (BS.length bs_tok == sz) $ -- and overall we shouldn't loose any input assert (BS.length bs_cur + BS.length bs_next == sz + BS.length bs') $ do -- so now we can run the fast path to consume just this one token slowpath <- lift $ go_fast_end bs_tok da case slowpath of -- typically we'll fall out of the fast path having -- consumed exactly one token, now with no trailing data SlowDecodeAction bs_empty da' -> assert (BS.null bs_empty) $ go_slow da' bs' offset' -- but the other possibilities can happen too FastDone bs_empty x -> assert (BS.null bs_empty) $ return (bs', offset', x) SlowConsumeTokenBytes bs_empty k len -> assert (BS.null bs_empty) $ do (bstr, bs'') <- getTokenShortOrVarLen bs' offset' len lift (k bstr) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) SlowConsumeTokenByteArray bs_empty k len -> assert (BS.null bs_empty) $ do (bstr, bs'') <- getTokenShortOrVarLen bs' offset' len let !ba = BA.fromByteString bstr lift (k ba) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) SlowConsumeTokenString bs_empty k len -> assert (BS.null bs_empty) $ do (bstr, bs'') <- getTokenShortOrVarLen bs' offset' len case T.decodeUtf8' bstr of Right str -> lift (k str) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) Left _e -> decodeFail bs' offset' "invalid UTF8" SlowConsumeTokenUtf8ByteArray bs_empty k len -> assert (BS.null bs_empty) $ do (bstr, bs'') <- getTokenShortOrVarLen bs' offset' len let !ba = BA.fromByteString bstr lift (k ba) >>= \daz -> go_slow daz bs'' (offset' + intToInt64 len) SlowFail bs_unconsumed msg -> decodeFail (bs_unconsumed <> bs') offset'' msg where !offset'' = offset + intToInt64 (sz - BS.length bs_unconsumed) where {-# INLINE getTokenShortOrVarLen #-} getTokenShortOrVarLen :: BS.ByteString -> ByteOffset -> Int -> IncrementalDecoder s (ByteString, ByteString) getTokenShortOrVarLen bs' offset' len | BS.length bs' < len = getTokenVarLen len bs' offset' | otherwise = let !bstr = BS.take len bs' !bs'' = BS.drop len bs' in return (bstr, bs'') -- 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 -- can still stream the utf8 validation/converstion -- TODO FIXME: also consider sharing or not sharing here, and possibly -- rechunking. getTokenVarLen :: Int -> ByteString -> ByteOffset -> IncrementalDecoder s (ByteString, ByteString) getTokenVarLen len bs offset = assert (len > BS.length bs) $ do mbs <- needChunk case mbs of Nothing -> decodeFail BS.empty offset "end of input" Just bs' | let n = len - BS.length bs , BS.length bs' >= n -> let !tok = bs <> BS.unsafeTake n bs' in return (tok, BS.drop n bs') | otherwise -> getTokenVarLenSlow [bs',bs] (len - (BS.length bs + BS.length bs')) offset getTokenVarLenSlow :: [ByteString] -> Int -> ByteOffset -> IncrementalDecoder s (ByteString, ByteString) getTokenVarLenSlow bss n offset = do mbs <- needChunk case mbs of Nothing -> decodeFail BS.empty offset "end of input" Just bs | BS.length bs >= n -> let !tok = BS.concat (reverse (BS.unsafeTake n bs : bss)) in return (tok, BS.drop n bs) | otherwise -> getTokenVarLenSlow (bs:bss) (n - BS.length bs) offset tokenSize :: Word8 -> Int tokenSize hdr = word8ToInt $ decodeTableSz `A.unsafeAt` (word8ToInt hdr .&. 0x1f) decodeTableSz :: UArray Word8 Word8 decodeTableSz = array (0, 0x1f) $ [ (encodeHeader 0 n, 1) | n <- [0..0x1f] ] ++ [ (encodeHeader 0 n, s) | (n, s) <- zip [24..27] [2,3,5,9] ] decodeTokenTypeTable :: Array Word8 TokenType decodeTokenTypeTable = array (minBound, maxBound) $ [ (encodeHeader 0 n, TypeUInt) | n <- [0..26] ] ++ [ (encodeHeader 0 27, TypeUInt64) , (encodeHeader 0 31, TypeInvalid) ] ++ [ (encodeHeader 1 n, TypeNInt) | n <- [0..26] ] ++ [ (encodeHeader 1 27, TypeNInt64) , (encodeHeader 1 31, TypeInvalid) ] ++ [ (encodeHeader 2 n, TypeBytes) | n <- [0..27] ] ++ [ (encodeHeader 2 31, TypeBytesIndef) ] ++ [ (encodeHeader 3 n, TypeString) | n <- [0..27] ] ++ [ (encodeHeader 3 31, TypeStringIndef) ] ++ [ (encodeHeader 4 n, TypeListLen) | n <- [0..26] ] ++ [ (encodeHeader 4 27, TypeListLen64) , (encodeHeader 4 31, TypeListLenIndef) ] ++ [ (encodeHeader 5 n, TypeMapLen) | n <- [0..26] ] ++ [ (encodeHeader 5 27, TypeMapLen64) , (encodeHeader 5 31, TypeMapLenIndef) ] ++ [ (encodeHeader 6 n, TypeTag) | n <- 0:1:[4..26] ] ++ [ (encodeHeader 6 2, TypeInteger) , (encodeHeader 6 3, TypeInteger) , (encodeHeader 6 27, TypeTag64) , (encodeHeader 6 31, TypeInvalid) ] ++ [ (encodeHeader 7 n, TypeSimple) | n <- [0..19] ] ++ [ (encodeHeader 7 20, TypeBool) , (encodeHeader 7 21, TypeBool) , (encodeHeader 7 22, TypeNull) , (encodeHeader 7 23, TypeSimple) , (encodeHeader 7 24, TypeSimple) , (encodeHeader 7 25, TypeFloat16) , (encodeHeader 7 26, TypeFloat32) , (encodeHeader 7 27, TypeFloat64) , (encodeHeader 7 31, TypeBreak) ] ++ [ (encodeHeader mt n, TypeInvalid) | mt <- [0..7], n <- [28..30] ] encodeHeader :: Word8 -> Word8 -> Word8 encodeHeader mt ai = mt `shiftL` 5 .|. ai data DecodedToken a = DecodedToken !Int !a | DecodeFailure deriving Show -- TODO add classification for DecodeFailure -- | Note that canonicity information is calculated lazily. This way we don't -- need to concern ourselves with two distinct paths, while according to -- benchmarks it doesn't affect performance in the non-canonical case. data LongToken a = Fits Bool {- canonical? -} !a | TooLong Bool {- canonical? -} !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# `gtWord#` 0x17##) | sz == 3 = isTrue# (w# `gtWord#` 0xff##) | sz == 5 = isTrue# (w# `gtWord#` 0xffff##) | sz == 9 = isTrue# (w# `gtWord#` 0xffffffff##) | 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# `gtWord64#` wordToWord64# 0x17##) | sz == 3 = isTrue# (w# `gtWord64#` wordToWord64# 0xff##) | sz == 5 = isTrue# (w# `gtWord64#` wordToWord64# 0xffff##) | sz == 9 = isTrue# (w# `gtWord64#` wordToWord64# 0xffffffff##) | otherwise = True {-# INLINE isInt64Canonical #-} isInt64Canonical :: Int -> Int64# -> Bool isInt64Canonical sz i# | isTrue# (i# `ltInt64#` intToInt64# 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 -- division. Whereas for Int or Word it does the right thing. {-# INLINE tryConsumeWord #-} tryConsumeWord :: Word8 -> ByteString -> DecodedToken Word tryConsumeWord hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 0 0x01 -> DecodedToken 1 1 0x02 -> DecodedToken 1 2 0x03 -> DecodedToken 1 3 0x04 -> DecodedToken 1 4 0x05 -> DecodedToken 1 5 0x06 -> DecodedToken 1 6 0x07 -> DecodedToken 1 7 0x08 -> DecodedToken 1 8 0x09 -> DecodedToken 1 9 0x0a -> DecodedToken 1 10 0x0b -> DecodedToken 1 11 0x0c -> DecodedToken 1 12 0x0d -> DecodedToken 1 13 0x0e -> DecodedToken 1 14 0x0f -> DecodedToken 1 15 0x10 -> DecodedToken 1 16 0x11 -> DecodedToken 1 17 0x12 -> DecodedToken 1 18 0x13 -> DecodedToken 1 19 0x14 -> DecodedToken 1 20 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23 0x18 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) 0x19 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs)) 0x1a -> DecodedToken 5 (word32ToWord (eatTailWord32 bs)) #if defined(ARCH_64bit) 0x1b -> DecodedToken 9 (word64ToWord (eatTailWord64 bs)) #else 0x1b -> case word64ToWord (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure #endif _ -> DecodeFailure {-# INLINE tryConsumeNegWord #-} tryConsumeNegWord :: Word8 -> ByteString -> DecodedToken Word tryConsumeNegWord hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x20 -> DecodedToken 1 0 0x21 -> DecodedToken 1 1 0x22 -> DecodedToken 1 2 0x23 -> DecodedToken 1 3 0x24 -> DecodedToken 1 4 0x25 -> DecodedToken 1 5 0x26 -> DecodedToken 1 6 0x27 -> DecodedToken 1 7 0x28 -> DecodedToken 1 8 0x29 -> DecodedToken 1 9 0x2a -> DecodedToken 1 10 0x2b -> DecodedToken 1 11 0x2c -> DecodedToken 1 12 0x2d -> DecodedToken 1 13 0x2e -> DecodedToken 1 14 0x2f -> DecodedToken 1 15 0x30 -> DecodedToken 1 16 0x31 -> DecodedToken 1 17 0x32 -> DecodedToken 1 18 0x33 -> DecodedToken 1 19 0x34 -> DecodedToken 1 20 0x35 -> DecodedToken 1 21 0x36 -> DecodedToken 1 22 0x37 -> DecodedToken 1 23 0x38 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) 0x39 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs)) 0x3a -> DecodedToken 5 (word32ToWord (eatTailWord32 bs)) #if defined(ARCH_64bit) 0x3b -> DecodedToken 9 (word64ToWord (eatTailWord64 bs)) #else 0x3b -> case word64ToWord (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure #endif _ -> DecodeFailure {-# INLINE tryConsumeInt #-} tryConsumeInt :: Word8 -> ByteString -> DecodedToken Int tryConsumeInt hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 0 0x01 -> DecodedToken 1 1 0x02 -> DecodedToken 1 2 0x03 -> DecodedToken 1 3 0x04 -> DecodedToken 1 4 0x05 -> DecodedToken 1 5 0x06 -> DecodedToken 1 6 0x07 -> DecodedToken 1 7 0x08 -> DecodedToken 1 8 0x09 -> DecodedToken 1 9 0x0a -> DecodedToken 1 10 0x0b -> DecodedToken 1 11 0x0c -> DecodedToken 1 12 0x0d -> DecodedToken 1 13 0x0e -> DecodedToken 1 14 0x0f -> DecodedToken 1 15 0x10 -> DecodedToken 1 16 0x11 -> DecodedToken 1 17 0x12 -> DecodedToken 1 18 0x13 -> DecodedToken 1 19 0x14 -> DecodedToken 1 20 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23 0x18 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) 0x19 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) 0x1a -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) #else 0x1a -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n Nothing -> DecodeFailure #endif 0x1b -> case word64ToInt (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure -- Negative integers (type 1) 0x20 -> DecodedToken 1 (-1) 0x21 -> DecodedToken 1 (-2) 0x22 -> DecodedToken 1 (-3) 0x23 -> DecodedToken 1 (-4) 0x24 -> DecodedToken 1 (-5) 0x25 -> DecodedToken 1 (-6) 0x26 -> DecodedToken 1 (-7) 0x27 -> DecodedToken 1 (-8) 0x28 -> DecodedToken 1 (-9) 0x29 -> DecodedToken 1 (-10) 0x2a -> DecodedToken 1 (-11) 0x2b -> DecodedToken 1 (-12) 0x2c -> DecodedToken 1 (-13) 0x2d -> DecodedToken 1 (-14) 0x2e -> DecodedToken 1 (-15) 0x2f -> DecodedToken 1 (-16) 0x30 -> DecodedToken 1 (-17) 0x31 -> DecodedToken 1 (-18) 0x32 -> DecodedToken 1 (-19) 0x33 -> DecodedToken 1 (-20) 0x34 -> DecodedToken 1 (-21) 0x35 -> DecodedToken 1 (-22) 0x36 -> DecodedToken 1 (-23) 0x37 -> DecodedToken 1 (-24) 0x38 -> DecodedToken 2 (-1 - word8ToInt (eatTailWord8 bs)) 0x39 -> DecodedToken 3 (-1 - word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) 0x3a -> DecodedToken 5 (-1 - word32ToInt (eatTailWord32 bs)) #else 0x3a -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 (-1 - n) Nothing -> DecodeFailure #endif 0x3b -> case word64ToInt (eatTailWord64 bs) of Just n -> DecodedToken 9 (-1 - n) Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeInteger #-} tryConsumeInteger :: Word8 -> ByteString -> DecodedToken (BigIntToken Integer) tryConsumeInteger hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 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@(W8# w#) = eatTailWord8 bs sz = 2 in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) 0x19 -> let !w@(W16# w#) = eatTailWord16 bs sz = 3 in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) 0x1a -> let !w@(W32# w#) = eatTailWord32 bs sz = 5 in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) 0x1b -> let !w@(W64# w#) = eatTailWord64 bs sz = 9 #if defined(ARCH_32bit) in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (toInteger w)) #else in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (toInteger w)) #endif -- Negative integers (type 1) 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@(W8# w#) = eatTailWord8 bs sz = 2 in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) 0x39 -> let !w@(W16# w#) = eatTailWord16 bs sz = 3 in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) 0x3a -> let !w@(W32# w#) = eatTailWord32 bs sz = 5 in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) 0x3b -> let !w@(W64# w#) = eatTailWord64 bs sz = 9 #if defined(ARCH_32bit) in DecodedToken sz (BigIntToken (isWord64Canonical sz w#) (-1 - toInteger w)) #else in DecodedToken sz (BigIntToken (isWordCanonical sz w#) (-1 - toInteger w)) #endif 0xc2 -> readBigUInt bs 0xc3 -> readBigNInt bs _ -> DecodeFailure {-# INLINE tryConsumeBytes #-} tryConsumeBytes :: Word8 -> ByteString -> DecodedToken (LongToken ByteString) tryConsumeBytes hdr !bs = case word8ToWord hdr of -- Bytes (type 2) 0x40 -> readBytesSmall 0 bs 0x41 -> readBytesSmall 1 bs 0x42 -> readBytesSmall 2 bs 0x43 -> readBytesSmall 3 bs 0x44 -> readBytesSmall 4 bs 0x45 -> readBytesSmall 5 bs 0x46 -> readBytesSmall 6 bs 0x47 -> readBytesSmall 7 bs 0x48 -> readBytesSmall 8 bs 0x49 -> readBytesSmall 9 bs 0x4a -> readBytesSmall 10 bs 0x4b -> readBytesSmall 11 bs 0x4c -> readBytesSmall 12 bs 0x4d -> readBytesSmall 13 bs 0x4e -> readBytesSmall 14 bs 0x4f -> readBytesSmall 15 bs 0x50 -> readBytesSmall 16 bs 0x51 -> readBytesSmall 17 bs 0x52 -> readBytesSmall 18 bs 0x53 -> readBytesSmall 19 bs 0x54 -> readBytesSmall 20 bs 0x55 -> readBytesSmall 21 bs 0x56 -> readBytesSmall 22 bs 0x57 -> readBytesSmall 23 bs 0x58 -> readBytes8 bs 0x59 -> readBytes16 bs 0x5a -> readBytes32 bs 0x5b -> readBytes64 bs _ -> DecodeFailure {-# INLINE tryConsumeString #-} tryConsumeString :: Word8 -> ByteString -> DecodedToken (LongToken ByteString) tryConsumeString hdr !bs = case word8ToWord hdr of -- Strings (type 3) 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 {-# INLINE tryConsumeListLen #-} tryConsumeListLen :: Word8 -> ByteString -> DecodedToken Int tryConsumeListLen hdr !bs = case word8ToWord hdr of -- List structures (type 4) 0x80 -> DecodedToken 1 0 0x81 -> DecodedToken 1 1 0x82 -> DecodedToken 1 2 0x83 -> DecodedToken 1 3 0x84 -> DecodedToken 1 4 0x85 -> DecodedToken 1 5 0x86 -> DecodedToken 1 6 0x87 -> DecodedToken 1 7 0x88 -> DecodedToken 1 8 0x89 -> DecodedToken 1 9 0x8a -> DecodedToken 1 10 0x8b -> DecodedToken 1 11 0x8c -> DecodedToken 1 12 0x8d -> DecodedToken 1 13 0x8e -> DecodedToken 1 14 0x8f -> DecodedToken 1 15 0x90 -> DecodedToken 1 16 0x91 -> DecodedToken 1 17 0x92 -> DecodedToken 1 18 0x93 -> DecodedToken 1 19 0x94 -> DecodedToken 1 20 0x95 -> DecodedToken 1 21 0x96 -> DecodedToken 1 22 0x97 -> DecodedToken 1 23 0x98 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) 0x99 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) 0x9a -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) #else 0x9a -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n Nothing -> DecodeFailure #endif 0x9b -> case word64ToInt (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeMapLen #-} tryConsumeMapLen :: Word8 -> ByteString -> DecodedToken Int tryConsumeMapLen hdr !bs = case word8ToWord hdr of -- Map structures (type 5) 0xa0 -> DecodedToken 1 0 0xa1 -> DecodedToken 1 1 0xa2 -> DecodedToken 1 2 0xa3 -> DecodedToken 1 3 0xa4 -> DecodedToken 1 4 0xa5 -> DecodedToken 1 5 0xa6 -> DecodedToken 1 6 0xa7 -> DecodedToken 1 7 0xa8 -> DecodedToken 1 8 0xa9 -> DecodedToken 1 9 0xaa -> DecodedToken 1 10 0xab -> DecodedToken 1 11 0xac -> DecodedToken 1 12 0xad -> DecodedToken 1 13 0xae -> DecodedToken 1 14 0xaf -> DecodedToken 1 15 0xb0 -> DecodedToken 1 16 0xb1 -> DecodedToken 1 17 0xb2 -> DecodedToken 1 18 0xb3 -> DecodedToken 1 19 0xb4 -> DecodedToken 1 20 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23 0xb8 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) 0xb9 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) 0xba -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) #else 0xba -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n Nothing -> DecodeFailure #endif 0xbb -> case word64ToInt (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeListLenIndef #-} tryConsumeListLenIndef :: Word8 -> DecodedToken () tryConsumeListLenIndef hdr = case word8ToWord hdr of 0x9f -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeMapLenIndef #-} tryConsumeMapLenIndef :: Word8 -> DecodedToken () tryConsumeMapLenIndef hdr = case word8ToWord hdr of 0xbf -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeListLenOrIndef #-} tryConsumeListLenOrIndef :: Word8 -> ByteString -> DecodedToken Int tryConsumeListLenOrIndef hdr !bs = case word8ToWord hdr of -- List structures (type 4) 0x80 -> DecodedToken 1 0 0x81 -> DecodedToken 1 1 0x82 -> DecodedToken 1 2 0x83 -> DecodedToken 1 3 0x84 -> DecodedToken 1 4 0x85 -> DecodedToken 1 5 0x86 -> DecodedToken 1 6 0x87 -> DecodedToken 1 7 0x88 -> DecodedToken 1 8 0x89 -> DecodedToken 1 9 0x8a -> DecodedToken 1 10 0x8b -> DecodedToken 1 11 0x8c -> DecodedToken 1 12 0x8d -> DecodedToken 1 13 0x8e -> DecodedToken 1 14 0x8f -> DecodedToken 1 15 0x90 -> DecodedToken 1 16 0x91 -> DecodedToken 1 17 0x92 -> DecodedToken 1 18 0x93 -> DecodedToken 1 19 0x94 -> DecodedToken 1 20 0x95 -> DecodedToken 1 21 0x96 -> DecodedToken 1 22 0x97 -> DecodedToken 1 23 0x98 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) 0x99 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) 0x9a -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) #else 0x9a -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n Nothing -> DecodeFailure #endif 0x9b -> case word64ToInt (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure 0x9f -> DecodedToken 1 (-1) -- indefinite length _ -> DecodeFailure {-# INLINE tryConsumeMapLenOrIndef #-} tryConsumeMapLenOrIndef :: Word8 -> ByteString -> DecodedToken Int tryConsumeMapLenOrIndef hdr !bs = case word8ToWord hdr of -- Map structures (type 5) 0xa0 -> DecodedToken 1 0 0xa1 -> DecodedToken 1 1 0xa2 -> DecodedToken 1 2 0xa3 -> DecodedToken 1 3 0xa4 -> DecodedToken 1 4 0xa5 -> DecodedToken 1 5 0xa6 -> DecodedToken 1 6 0xa7 -> DecodedToken 1 7 0xa8 -> DecodedToken 1 8 0xa9 -> DecodedToken 1 9 0xaa -> DecodedToken 1 10 0xab -> DecodedToken 1 11 0xac -> DecodedToken 1 12 0xad -> DecodedToken 1 13 0xae -> DecodedToken 1 14 0xaf -> DecodedToken 1 15 0xb0 -> DecodedToken 1 16 0xb1 -> DecodedToken 1 17 0xb2 -> DecodedToken 1 18 0xb3 -> DecodedToken 1 19 0xb4 -> DecodedToken 1 20 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23 0xb8 -> DecodedToken 2 (word8ToInt (eatTailWord8 bs)) 0xb9 -> DecodedToken 3 (word16ToInt (eatTailWord16 bs)) #if defined(ARCH_64bit) 0xba -> DecodedToken 5 (word32ToInt (eatTailWord32 bs)) #else 0xba -> case word32ToInt (eatTailWord32 bs) of Just n -> DecodedToken 5 n Nothing -> DecodeFailure #endif 0xbb -> case word64ToInt (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure 0xbf -> DecodedToken 1 (-1) -- indefinite length _ -> DecodeFailure {-# INLINE tryConsumeTag #-} tryConsumeTag :: Word8 -> ByteString -> DecodedToken Word tryConsumeTag hdr !bs = case word8ToWord hdr of -- Tagged values (type 6) 0xc0 -> DecodedToken 1 0 0xc1 -> DecodedToken 1 1 0xc2 -> DecodedToken 1 2 0xc3 -> DecodedToken 1 3 0xc4 -> DecodedToken 1 4 0xc5 -> DecodedToken 1 5 0xc6 -> DecodedToken 1 6 0xc7 -> DecodedToken 1 7 0xc8 -> DecodedToken 1 8 0xc9 -> DecodedToken 1 9 0xca -> DecodedToken 1 10 0xcb -> DecodedToken 1 11 0xcc -> DecodedToken 1 12 0xcd -> DecodedToken 1 13 0xce -> DecodedToken 1 14 0xcf -> DecodedToken 1 15 0xd0 -> DecodedToken 1 16 0xd1 -> DecodedToken 1 17 0xd2 -> DecodedToken 1 18 0xd3 -> DecodedToken 1 19 0xd4 -> DecodedToken 1 20 0xd5 -> DecodedToken 1 21 0xd6 -> DecodedToken 1 22 0xd7 -> DecodedToken 1 23 0xd8 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) 0xd9 -> DecodedToken 3 (word16ToWord (eatTailWord16 bs)) 0xda -> DecodedToken 5 (word32ToWord (eatTailWord32 bs)) #if defined(ARCH_64bit) 0xdb -> DecodedToken 9 (word64ToWord (eatTailWord64 bs)) #else 0xdb -> case word64ToWord (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure #endif _ -> DecodeFailure -- -- 64-on-32 bit code paths -- #if defined(ARCH_32bit) tryConsumeWord64 :: Word8 -> ByteString -> DecodedToken Word64 tryConsumeWord64 hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 0 0x01 -> DecodedToken 1 1 0x02 -> DecodedToken 1 2 0x03 -> DecodedToken 1 3 0x04 -> DecodedToken 1 4 0x05 -> DecodedToken 1 5 0x06 -> DecodedToken 1 6 0x07 -> DecodedToken 1 7 0x08 -> DecodedToken 1 8 0x09 -> DecodedToken 1 9 0x0a -> DecodedToken 1 10 0x0b -> DecodedToken 1 11 0x0c -> DecodedToken 1 12 0x0d -> DecodedToken 1 13 0x0e -> DecodedToken 1 14 0x0f -> DecodedToken 1 15 0x10 -> DecodedToken 1 16 0x11 -> DecodedToken 1 17 0x12 -> DecodedToken 1 18 0x13 -> DecodedToken 1 19 0x14 -> DecodedToken 1 20 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23 0x18 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs)) 0x19 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs)) 0x1a -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs)) 0x1b -> DecodedToken 9 (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeWord64 #-} tryConsumeNegWord64 :: Word8 -> ByteString -> DecodedToken Word64 tryConsumeNegWord64 hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x20 -> DecodedToken 1 0 0x21 -> DecodedToken 1 1 0x22 -> DecodedToken 1 2 0x23 -> DecodedToken 1 3 0x24 -> DecodedToken 1 4 0x25 -> DecodedToken 1 5 0x26 -> DecodedToken 1 6 0x27 -> DecodedToken 1 7 0x28 -> DecodedToken 1 8 0x29 -> DecodedToken 1 9 0x2a -> DecodedToken 1 10 0x2b -> DecodedToken 1 11 0x2c -> DecodedToken 1 12 0x2d -> DecodedToken 1 13 0x2e -> DecodedToken 1 14 0x2f -> DecodedToken 1 15 0x30 -> DecodedToken 1 16 0x31 -> DecodedToken 1 17 0x32 -> DecodedToken 1 18 0x33 -> DecodedToken 1 19 0x34 -> DecodedToken 1 20 0x35 -> DecodedToken 1 21 0x36 -> DecodedToken 1 22 0x37 -> DecodedToken 1 23 0x38 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs)) 0x39 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs)) 0x3a -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs)) 0x3b -> DecodedToken 9 (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeNegWord64 #-} tryConsumeInt64 :: Word8 -> ByteString -> DecodedToken Int64 tryConsumeInt64 hdr !bs = case word8ToWord hdr of -- Positive integers (type 0) 0x00 -> DecodedToken 1 0 0x01 -> DecodedToken 1 1 0x02 -> DecodedToken 1 2 0x03 -> DecodedToken 1 3 0x04 -> DecodedToken 1 4 0x05 -> DecodedToken 1 5 0x06 -> DecodedToken 1 6 0x07 -> DecodedToken 1 7 0x08 -> DecodedToken 1 8 0x09 -> DecodedToken 1 9 0x0a -> DecodedToken 1 10 0x0b -> DecodedToken 1 11 0x0c -> DecodedToken 1 12 0x0d -> DecodedToken 1 13 0x0e -> DecodedToken 1 14 0x0f -> DecodedToken 1 15 0x10 -> DecodedToken 1 16 0x11 -> DecodedToken 1 17 0x12 -> DecodedToken 1 18 0x13 -> DecodedToken 1 19 0x14 -> DecodedToken 1 20 0x15 -> DecodedToken 1 21 0x16 -> DecodedToken 1 22 0x17 -> DecodedToken 1 23 0x18 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs)) 0x19 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs)) 0x1a -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs)) 0x1b -> case word64ToInt64 (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure -- Negative integers (type 1) 0x20 -> DecodedToken 1 (-1) 0x21 -> DecodedToken 1 (-2) 0x22 -> DecodedToken 1 (-3) 0x23 -> DecodedToken 1 (-4) 0x24 -> DecodedToken 1 (-5) 0x25 -> DecodedToken 1 (-6) 0x26 -> DecodedToken 1 (-7) 0x27 -> DecodedToken 1 (-8) 0x28 -> DecodedToken 1 (-9) 0x29 -> DecodedToken 1 (-10) 0x2a -> DecodedToken 1 (-11) 0x2b -> DecodedToken 1 (-12) 0x2c -> DecodedToken 1 (-13) 0x2d -> DecodedToken 1 (-14) 0x2e -> DecodedToken 1 (-15) 0x2f -> DecodedToken 1 (-16) 0x30 -> DecodedToken 1 (-17) 0x31 -> DecodedToken 1 (-18) 0x32 -> DecodedToken 1 (-19) 0x33 -> DecodedToken 1 (-20) 0x34 -> DecodedToken 1 (-21) 0x35 -> DecodedToken 1 (-22) 0x36 -> DecodedToken 1 (-23) 0x37 -> DecodedToken 1 (-24) 0x38 -> DecodedToken 2 (-1 - word8ToInt64 (eatTailWord8 bs)) 0x39 -> DecodedToken 3 (-1 - word16ToInt64 (eatTailWord16 bs)) 0x3a -> DecodedToken 5 (-1 - word32ToInt64 (eatTailWord32 bs)) 0x3b -> case word64ToInt64 (eatTailWord64 bs) of Just n -> DecodedToken 9 (-1 - n) Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeInt64 #-} tryConsumeListLen64 :: Word8 -> ByteString -> DecodedToken Int64 tryConsumeListLen64 hdr !bs = case word8ToWord hdr of -- List structures (type 4) 0x80 -> DecodedToken 1 0 0x81 -> DecodedToken 1 1 0x82 -> DecodedToken 1 2 0x83 -> DecodedToken 1 3 0x84 -> DecodedToken 1 4 0x85 -> DecodedToken 1 5 0x86 -> DecodedToken 1 6 0x87 -> DecodedToken 1 7 0x88 -> DecodedToken 1 8 0x89 -> DecodedToken 1 9 0x8a -> DecodedToken 1 10 0x8b -> DecodedToken 1 11 0x8c -> DecodedToken 1 12 0x8d -> DecodedToken 1 13 0x8e -> DecodedToken 1 14 0x8f -> DecodedToken 1 15 0x90 -> DecodedToken 1 16 0x91 -> DecodedToken 1 17 0x92 -> DecodedToken 1 18 0x93 -> DecodedToken 1 19 0x94 -> DecodedToken 1 20 0x95 -> DecodedToken 1 21 0x96 -> DecodedToken 1 22 0x97 -> DecodedToken 1 23 0x98 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs)) 0x99 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs)) 0x9a -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs)) 0x9b -> case word64ToInt64 (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeListLen64 #-} tryConsumeMapLen64 :: Word8 -> ByteString -> DecodedToken Int64 tryConsumeMapLen64 hdr !bs = case word8ToWord hdr of -- Map structures (type 5) 0xa0 -> DecodedToken 1 0 0xa1 -> DecodedToken 1 1 0xa2 -> DecodedToken 1 2 0xa3 -> DecodedToken 1 3 0xa4 -> DecodedToken 1 4 0xa5 -> DecodedToken 1 5 0xa6 -> DecodedToken 1 6 0xa7 -> DecodedToken 1 7 0xa8 -> DecodedToken 1 8 0xa9 -> DecodedToken 1 9 0xaa -> DecodedToken 1 10 0xab -> DecodedToken 1 11 0xac -> DecodedToken 1 12 0xad -> DecodedToken 1 13 0xae -> DecodedToken 1 14 0xaf -> DecodedToken 1 15 0xb0 -> DecodedToken 1 16 0xb1 -> DecodedToken 1 17 0xb2 -> DecodedToken 1 18 0xb3 -> DecodedToken 1 19 0xb4 -> DecodedToken 1 20 0xb5 -> DecodedToken 1 21 0xb6 -> DecodedToken 1 22 0xb7 -> DecodedToken 1 23 0xb8 -> DecodedToken 2 (word8ToInt64 (eatTailWord8 bs)) 0xb9 -> DecodedToken 3 (word16ToInt64 (eatTailWord16 bs)) 0xba -> DecodedToken 5 (word32ToInt64 (eatTailWord32 bs)) 0xbb -> case word64ToInt64 (eatTailWord64 bs) of Just n -> DecodedToken 9 n Nothing -> DecodeFailure _ -> DecodeFailure {-# INLINE tryConsumeMapLen64 #-} tryConsumeTag64 :: Word8 -> ByteString -> DecodedToken Word64 tryConsumeTag64 hdr !bs = case word8ToWord hdr of -- Tagged values (type 6) 0xc0 -> DecodedToken 1 0 0xc1 -> DecodedToken 1 1 0xc2 -> DecodedToken 1 2 0xc3 -> DecodedToken 1 3 0xc4 -> DecodedToken 1 4 0xc5 -> DecodedToken 1 5 0xc6 -> DecodedToken 1 6 0xc7 -> DecodedToken 1 7 0xc8 -> DecodedToken 1 8 0xc9 -> DecodedToken 1 9 0xca -> DecodedToken 1 10 0xcb -> DecodedToken 1 11 0xcc -> DecodedToken 1 12 0xcd -> DecodedToken 1 13 0xce -> DecodedToken 1 14 0xcf -> DecodedToken 1 15 0xd0 -> DecodedToken 1 16 0xd1 -> DecodedToken 1 17 0xd2 -> DecodedToken 1 18 0xd3 -> DecodedToken 1 19 0xd4 -> DecodedToken 1 20 0xd5 -> DecodedToken 1 21 0xd6 -> DecodedToken 1 22 0xd7 -> DecodedToken 1 23 0xd8 -> DecodedToken 2 (word8ToWord64 (eatTailWord8 bs)) 0xd9 -> DecodedToken 3 (word16ToWord64 (eatTailWord16 bs)) 0xda -> DecodedToken 5 (word32ToWord64 (eatTailWord32 bs)) 0xdb -> DecodedToken 9 (eatTailWord64 bs) _ -> DecodeFailure {-# INLINE tryConsumeTag64 #-} #endif {-# INLINE tryConsumeFloat #-} tryConsumeFloat :: Word8 -> ByteString -> DecodedToken Float tryConsumeFloat hdr !bs = case word8ToWord hdr of 0xf9 -> DecodedToken 3 (wordToFloat16 (eatTailWord16 bs)) 0xfa -> DecodedToken 5 (wordToFloat32 (eatTailWord32 bs)) _ -> DecodeFailure {-# INLINE tryConsumeDouble #-} tryConsumeDouble :: Word8 -> ByteString -> DecodedToken Double tryConsumeDouble hdr !bs = case word8ToWord hdr of 0xf9 -> DecodedToken 3 (float2Double $ wordToFloat16 (eatTailWord16 bs)) 0xfa -> DecodedToken 5 (float2Double $ wordToFloat32 (eatTailWord32 bs)) 0xfb -> DecodedToken 9 (wordToFloat64 (eatTailWord64 bs)) _ -> DecodeFailure {-# INLINE tryConsumeBool #-} tryConsumeBool :: Word8 -> DecodedToken Bool tryConsumeBool hdr = case word8ToWord hdr of 0xf4 -> DecodedToken 1 False 0xf5 -> DecodedToken 1 True _ -> DecodeFailure {-# INLINE tryConsumeSimple #-} tryConsumeSimple :: Word8 -> ByteString -> DecodedToken Word tryConsumeSimple hdr !bs = case word8ToWord hdr of -- Simple and floats (type 7) 0xe0 -> DecodedToken 1 0 0xe1 -> DecodedToken 1 1 0xe2 -> DecodedToken 1 2 0xe3 -> DecodedToken 1 3 0xe4 -> DecodedToken 1 4 0xe5 -> DecodedToken 1 5 0xe6 -> DecodedToken 1 6 0xe7 -> DecodedToken 1 7 0xe8 -> DecodedToken 1 8 0xe9 -> DecodedToken 1 9 0xea -> DecodedToken 1 10 0xeb -> DecodedToken 1 11 0xec -> DecodedToken 1 12 0xed -> DecodedToken 1 13 0xee -> DecodedToken 1 14 0xef -> DecodedToken 1 15 0xf0 -> DecodedToken 1 16 0xf1 -> DecodedToken 1 17 0xf2 -> DecodedToken 1 18 0xf3 -> DecodedToken 1 19 0xf4 -> DecodedToken 1 20 0xf5 -> DecodedToken 1 21 0xf6 -> DecodedToken 1 22 0xf7 -> DecodedToken 1 23 0xf8 -> DecodedToken 2 (word8ToWord (eatTailWord8 bs)) _ -> DecodeFailure {-# INLINE tryConsumeBytesIndef #-} tryConsumeBytesIndef :: Word8 -> DecodedToken () tryConsumeBytesIndef hdr = case word8ToWord hdr of 0x5f -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeStringIndef #-} tryConsumeStringIndef :: Word8 -> DecodedToken () tryConsumeStringIndef hdr = case word8ToWord hdr of 0x7f -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeNull #-} tryConsumeNull :: Word8 -> DecodedToken () tryConsumeNull hdr = case word8ToWord hdr of 0xf6 -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE tryConsumeBreakOr #-} tryConsumeBreakOr :: Word8 -> DecodedToken () tryConsumeBreakOr hdr = case word8ToWord hdr of 0xff -> DecodedToken 1 () _ -> DecodeFailure {-# INLINE readBytesSmall #-} readBytesSmall :: Int -> ByteString -> DecodedToken (LongToken ByteString) readBytesSmall n bs -- if n <= bound then ok return it all | n + hdrsz <= BS.length bs = DecodedToken (n+hdrsz) $ Fits True $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk | otherwise = DecodedToken hdrsz $ TooLong True n where hdrsz = 1 {-# INLINE readBytes8 #-} {-# INLINE readBytes16 #-} {-# INLINE readBytes32 #-} {-# INLINE readBytes64 #-} readBytes8, readBytes16, readBytes32, readBytes64 :: ByteString -> DecodedToken (LongToken ByteString) readBytes8 bs | n <= BS.length bs - hdrsz = DecodedToken (n+hdrsz) $ Fits lengthCanonical $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk | otherwise = DecodedToken hdrsz $ TooLong lengthCanonical n where hdrsz = 2 !n@(I# n#) = word8ToInt (eatTailWord8 bs) lengthCanonical = isIntCanonical hdrsz n# readBytes16 bs | n <= BS.length bs - hdrsz = DecodedToken (n+hdrsz) $ Fits lengthCanonical $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk | otherwise = DecodedToken hdrsz $ TooLong lengthCanonical n where hdrsz = 3 !n@(I# n#) = word16ToInt (eatTailWord16 bs) lengthCanonical = isIntCanonical hdrsz n# readBytes32 bs = case word32ToInt (eatTailWord32 bs) of #if defined(ARCH_32bit) Just n@(I# n#) #else n@(I# n#) #endif | n <= BS.length bs - hdrsz -> DecodedToken (n+hdrsz) $ Fits (isIntCanonical hdrsz n#) $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk | otherwise -> DecodedToken hdrsz $ TooLong (isIntCanonical hdrsz n#) n #if defined(ARCH_32bit) Nothing -> DecodeFailure #endif where hdrsz = 5 readBytes64 bs = case word64ToInt (eatTailWord64 bs) of Just n@(I# n#) | n <= BS.length bs - hdrsz -> DecodedToken (n+hdrsz) $ Fits (isIntCanonical hdrsz n#) $ BS.unsafeTake n (BS.unsafeDrop hdrsz bs) -- if n > bound then slow path, multi-chunk | otherwise -> DecodedToken hdrsz $ TooLong (isIntCanonical hdrsz n#) n Nothing -> DecodeFailure where hdrsz = 9 ------------------------------------------------------------------------------ -- Reading big integers -- -- Big ints consist of two CBOR tokens: a tag token (2 for positive, 3 for -- negative) followed by a bytes token. Our usual invariant (for go_fast and -- go_fast_end) only guarantees that we've got enough space to decode the -- first token. So given that there's two tokens and the second is variable -- length then there are several points where we can discover we're out of -- input buffer space. -- -- In those cases we need to break out of the fast path but we must arrange -- things so that we can continue later once we've got more input buffer. -- -- In particular, we might run out of space when: -- 1. trying to decode the header of the second token (bytes); or -- 2. trying to read the bytes body -- --- The existing mechanisms we've got to drop out of the fast path are: -- * SlowDecodeAction to re-read a whole token -- * SlowConsumeTokenBytes to read the body of a bytes token -- -- Of course when we resume we need to convert the bytes into an integer. -- Rather than making new fast path return mechanisms we can reuse the -- existing ones, so long as we're prepared to allocate new continuation -- closures. This seems a reasonable price to pay to reduce complexity since -- decoding a big int across an input buffer boundary ought to be rare, and -- allocating a new continuation closure isn't that expensive. -- -- Note that canonicity information is calculated lazily. This way we don't need -- to concern ourselves with two distinct paths, while according to benchmarks -- it doesn't affect performance in the non-canonical case. data BigIntToken a = BigIntToken Bool {- canonical? -} Integer | BigUIntNeedBody Bool {- canonical? -} Int | BigNIntNeedBody Bool {- canonical? -} Int | BigUIntNeedHeader | BigNIntNeedHeader -- So when we have to break out because we can't read the whole bytes body -- in one go then we need to use SlowConsumeTokenBytes but we can adjust the -- continuation so that when we get the ByteString back we convert it to an -- Integer before calling the original continuation. adjustContBigUIntNeedBody, adjustContBigNIntNeedBody :: (Integer -> ST s (DecodeAction s a)) -> (ByteString -> ST s (DecodeAction s a)) adjustContBigUIntNeedBody k = \bs -> k $! uintegerFromBytes bs adjustContBigNIntNeedBody k = \bs -> k $! nintegerFromBytes bs adjustContCanonicalBigUIntNeedBody, adjustContCanonicalBigNIntNeedBody :: (Integer -> ST s (DecodeAction s a)) -> (ByteString -> ST s (DecodeAction s a)) adjustContCanonicalBigUIntNeedBody k = \bs -> if isBigIntRepCanonical bs then k $! uintegerFromBytes bs else pure $! D.Fail ("non-canonical integer") adjustContCanonicalBigNIntNeedBody k = \bs -> if isBigIntRepCanonical bs then k $! nintegerFromBytes bs else pure $! D.Fail ("non-canonical integer") -- And when we have to break out because we can't read the bytes token header -- in one go then we need to use SlowDecodeAction but we have to make two -- adjustments. When we resume we need to read a bytes token, not a big int. -- That is we don't want to re-read the tag token. Indeed we cannot even if we -- wanted to because the slow path code only guarantees to arrange for one -- complete token header in the input buffer. So we must pretend that we did -- in fact want to read a bytes token using ConsumeBytes, and then we can -- adjust the continuation for that in the same way as above. adjustContBigUIntNeedHeader, adjustContBigNIntNeedHeader :: (Integer -> ST s (DecodeAction s a)) -> DecodeAction s a adjustContBigUIntNeedHeader k = ConsumeBytes (\bs -> k $! uintegerFromBytes bs) adjustContBigNIntNeedHeader k = ConsumeBytes (\bs -> k $! nintegerFromBytes bs) adjustContCanonicalBigUIntNeedHeader, adjustContCanonicalBigNIntNeedHeader :: (Integer -> ST s (DecodeAction s a)) -> DecodeAction s a adjustContCanonicalBigUIntNeedHeader k = ConsumeBytesCanonical $ \bs -> if isBigIntRepCanonical bs then k $! uintegerFromBytes bs else pure $! D.Fail ("non-canonical integer") adjustContCanonicalBigNIntNeedHeader k = ConsumeBytesCanonical $ \bs -> if isBigIntRepCanonical bs then k $! nintegerFromBytes bs else pure $! D.Fail ("non-canonical integer") -- So finally when reading the input buffer we check if we have enough space -- to read the header of the bytes token and then try to read the bytes body, -- using the appropriate break-out codes as above. {-# INLINE readBigUInt #-} readBigUInt :: ByteString -> DecodedToken (BigIntToken a) readBigUInt bs | let bs' = BS.unsafeTail bs , not (BS.null bs') , let !hdr = BS.unsafeHead bs' , BS.length bs' >= tokenSize hdr = case tryConsumeBytes hdr bs' of DecodeFailure -> DecodeFailure DecodedToken sz (Fits canonical bstr) -> DecodedToken (1+sz) (BigIntToken (canonical && isBigIntRepCanonical bstr) (uintegerFromBytes bstr)) DecodedToken sz (TooLong canonical len) -> DecodedToken (1+sz) (BigUIntNeedBody canonical len) | otherwise = DecodedToken 1 BigUIntNeedHeader {-# INLINE readBigNInt #-} readBigNInt :: ByteString -> DecodedToken (BigIntToken a) readBigNInt bs | let bs' = BS.unsafeTail bs , not (BS.null bs') , let !hdr = BS.unsafeHead bs' , BS.length bs' >= tokenSize hdr = case tryConsumeBytes hdr bs' of DecodeFailure -> DecodeFailure DecodedToken sz (Fits canonical bstr) -> DecodedToken (1+sz) (BigIntToken (canonical && isBigIntRepCanonical bstr) (nintegerFromBytes bstr)) DecodedToken sz (TooLong canonical len) -> DecodedToken (1+sz) (BigNIntNeedBody canonical 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 cborg-0.2.1.0/src/Codec/CBOR/Encoding.hs0000644000000000000000000002502313357736054015564 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Module : Codec.CBOR.Encoding -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- High level API for encoding values, for later serialization into -- CBOR binary format, using a @'Monoid'@ based interface. -- module Codec.CBOR.Encoding ( -- * Encoding implementation Encoding(..) -- :: * , Tokens(..) -- :: * -- * @'Encoding'@ API for serialisation , encodeWord -- :: Word -> Encoding , encodeWord8 -- :: Word8 -> Encoding , encodeWord16 -- :: Word16 -> Encoding , encodeWord32 -- :: Word32 -> Encoding , encodeWord64 -- :: Word64 -> Encoding , encodeInt -- :: Int -> Encoding , encodeInt8 -- :: Int8 -> Encoding , encodeInt16 -- :: Int16 -> Encoding , encodeInt32 -- :: Int32 -> Encoding , encodeInt64 -- :: Int64 -> Encoding , 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 , encodeMapLenIndef -- :: Encoding , encodeBreak -- :: Encoding , encodeTag -- :: Word -> Encoding , encodeTag64 -- :: Word64 -> Encoding , encodeBool -- :: Bool -> Encoding , encodeUndef -- :: Encoding , encodeNull -- :: Encoding , encodeSimple -- :: Word8 -> Encoding , encodeFloat16 -- :: Float -> Encoding , encodeFloat -- :: Float -> Encoding , encodeDouble -- :: Double -> Encoding ) where #include "cbor.h" import Data.Int import Data.Word import Data.Semigroup 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 -- | An intermediate form used during serialisation, specified as a -- @'Monoid'@. It supports efficient concatenation, and is equivalent -- to a specialised @'Data.Monoid.Endo' 'Tokens'@ type. -- -- It is used for the stage in serialisation where we flatten out the -- Haskell data structure but it is independent of any specific -- external binary or text format. -- -- Traditionally, to build any arbitrary @'Encoding'@ value, you specify -- larger structures from smaller ones and append the small ones together -- using @'Data.Monoid.mconcat'@. -- -- @since 0.2.0.0 newtype Encoding = Encoding (Tokens -> Tokens) instance Show Encoding where show = show . FlatTerm.toFlatTerm -- | A flattened representation of a term, which is independent -- of any underlying binary representation, but which we later -- serialise into CBOR format. -- -- @since 0.2.0.0 data Tokens = -- Positive and negative integers (type 0,1) TkWord {-# UNPACK #-} !Word Tokens | TkWord64 {-# UNPACK #-} !Word64 Tokens -- convenience for either positive or negative | TkInt {-# UNPACK #-} !Int Tokens | TkInt64 {-# UNPACK #-} !Int64 Tokens -- Bytes and string (type 2,3) | 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 | TkListBegin Tokens | TkMapLen {-# UNPACK #-} !Word Tokens | TkMapBegin Tokens -- Tagged values (type 6) | TkTag {-# UNPACK #-} !Word Tokens | TkTag64 {-# UNPACK #-} !Word64 Tokens | TkInteger !Integer Tokens -- Simple and floats (type 7) | TkNull Tokens | TkUndef Tokens | TkBool !Bool Tokens | TkSimple {-# UNPACK #-} !Word8 Tokens | TkFloat16 {-# UNPACK #-} !Float Tokens | TkFloat32 {-# UNPACK #-} !Float Tokens | TkFloat64 {-# UNPACK #-} !Double Tokens | TkBreak Tokens | TkEnd deriving (Show,Eq) -- | @since 0.2.0.0 instance Semigroup Encoding where Encoding b1 <> Encoding b2 = Encoding (\ts -> b1 (b2 ts)) {-# INLINE (<>) #-} -- | @since 0.2.0.0 instance Monoid Encoding where mempty = Encoding (\ts -> ts) {-# INLINE mempty #-} mappend = (<>) {-# INLINE mappend #-} mconcat = foldr (<>) mempty {-# INLINE mconcat #-} -- | Encode a @'Word'@ in a flattened format. -- -- @since 0.2.0.0 encodeWord :: Word -> Encoding encodeWord = Encoding . TkWord -- | Encode a @'Word8'@ in a flattened format. -- -- @since 0.2.0.0 encodeWord8 :: Word8 -> Encoding encodeWord8 = Encoding . TkWord . fromIntegral -- | Encode a @'Word16'@ in a flattened format. -- -- @since 0.2.0.0 encodeWord16 :: Word16 -> Encoding encodeWord16 = Encoding . TkWord . fromIntegral -- | Encode a @'Word32'@ in a flattened format. -- -- @since 0.2.0.0 encodeWord32 :: Word32 -> Encoding encodeWord32 = Encoding . TkWord . fromIntegral -- | Encode a @'Word64'@ in a flattened format. -- -- @since 0.2.0.0 encodeWord64 :: Word64 -> Encoding encodeWord64 = Encoding . TkWord64 -- | Encode an @'Int'@ in a flattened format. -- -- @since 0.2.0.0 encodeInt :: Int -> Encoding encodeInt = Encoding . TkInt -- | Encode an @'Int8'@ in a flattened format. -- -- @since 0.2.0.0 encodeInt8 :: Int8 -> Encoding encodeInt8 = Encoding . TkInt . fromIntegral -- | Encode an @'Int16'@ in a flattened format. -- -- @since 0.2.0.0 encodeInt16 :: Int16 -> Encoding encodeInt16 = Encoding . TkInt . fromIntegral -- | Encode an @'Int32'@ in a flattened format. -- -- @since 0.2.0.0 encodeInt32 :: Int32 -> Encoding encodeInt32 = Encoding . TkInt . fromIntegral -- | Encode an @'Int64' in a flattened format. -- -- @since 0.2.0.0 encodeInt64 :: Int64 -> Encoding encodeInt64 = Encoding . TkInt64 -- | Encode an arbitrarily large @'Integer' in a -- flattened format. -- -- @since 0.2.0.0 encodeInteger :: Integer -> Encoding encodeInteger n = Encoding (TkInteger n) -- | Encode an arbitrary strict @'B.ByteString'@ in -- a flattened format. -- -- @since 0.2.0.0 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 -- overall string. After all the bytes desired have been encoded, you -- should follow it with a break token (see @'encodeBreak'@). -- -- @since 0.2.0.0 encodeBytesIndef :: Encoding encodeBytesIndef = Encoding TkBytesBegin -- | Encode a @'T.Text'@ in a flattened format. -- -- @since 0.2.0.0 encodeString :: T.Text -> Encoding encodeString = Encoding . TkString -- | Encode the beginning of an indefinite string. -- -- @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. -- -- @since 0.2.0.0 encodeListLen :: Word -> Encoding encodeListLen = Encoding . TkListLen -- | Encode a token specifying that this is the beginning of an -- indefinite list of unknown size. Tokens representing the list are -- expected afterwords, followed by a break token (see -- @'encodeBreak'@) when the list has ended. -- -- @since 0.2.0.0 encodeListLenIndef :: Encoding encodeListLenIndef = Encoding TkListBegin -- | Encode the length of a Map, used to indicate that -- the following tokens represent the map values. -- -- @since 0.2.0.0 encodeMapLen :: Word -> Encoding encodeMapLen = Encoding . TkMapLen -- | Encode a token specifying that this is the beginning of an -- indefinite map of unknown size. Tokens representing the map are -- expected afterwords, followed by a break token (see -- @'encodeBreak'@) when the map has ended. -- -- @since 0.2.0.0 encodeMapLenIndef :: Encoding encodeMapLenIndef = Encoding TkMapBegin -- | Encode a \'break\', used to specify the end of indefinite -- length objects like maps or lists. -- -- @since 0.2.0.0 encodeBreak :: Encoding encodeBreak = Encoding TkBreak -- | Encode an arbitrary @'Word'@ tag. -- -- @since 0.2.0.0 encodeTag :: Word -> Encoding encodeTag = Encoding . TkTag -- | Encode an arbitrary 64-bit @'Word64'@ tag. -- -- @since 0.2.0.0 encodeTag64 :: Word64 -> Encoding encodeTag64 = Encoding . TkTag64 -- | Encode a @'Bool'@. -- -- @since 0.2.0.0 encodeBool :: Bool -> Encoding encodeBool b = Encoding (TkBool b) -- | Encode an @Undef@ value. -- -- @since 0.2.0.0 encodeUndef :: Encoding encodeUndef = Encoding TkUndef -- | Encode a @Null@ value. -- -- @since 0.2.0.0 encodeNull :: Encoding encodeNull = Encoding TkNull -- | Encode a \'simple\' CBOR token that can be represented with an -- 8-bit word. You probably don't ever need this. -- -- @since 0.2.0.0 encodeSimple :: Word8 -> Encoding encodeSimple = Encoding . TkSimple -- | Encode a small 16-bit @'Float'@ in a flattened format. -- -- @since 0.2.0.0 encodeFloat16 :: Float -> Encoding encodeFloat16 = Encoding . TkFloat16 -- | Encode a full precision @'Float'@ in a flattened format. -- -- @since 0.2.0.0 encodeFloat :: Float -> Encoding encodeFloat = Encoding . TkFloat32 -- | Encode a @'Double'@ in a flattened format. -- -- @since 0.2.0.0 encodeDouble :: Double -> Encoding encodeDouble = Encoding . TkFloat64 cborg-0.2.1.0/src/Codec/CBOR/Decoding.hs0000644000000000000000000007661313357736054015565 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} -- | -- Module : Codec.CBOR.Decoding -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- High level API for decoding values that were encoded with the -- "Codec.CBOR.Encoding" module, using a @'Monad'@ -- based interface. -- module Codec.CBOR.Decoding ( -- * Decode primitive operations Decoder , DecodeAction(..) , liftST , getDecodeAction -- ** Read input tokens , decodeWord -- :: Decoder s Word , decodeWord8 -- :: Decoder s Word8 , decodeWord16 -- :: Decoder s Word16 , decodeWord32 -- :: Decoder s Word32 , decodeWord64 -- :: Decoder s Word64 , decodeNegWord -- :: Decoder s Word , decodeNegWord64 -- :: Decoder s Word64 , decodeInt -- :: Decoder s Int , decodeInt8 -- :: Decoder s Int8 , decodeInt16 -- :: Decoder s Int16 , decodeInt32 -- :: Decoder s Int32 , decodeInt64 -- :: 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 , decodeListLenIndef -- :: Decoder s () , decodeMapLen -- :: Decoder s Int , decodeMapLenIndef -- :: Decoder s () , decodeTag -- :: Decoder s Word , decodeTag64 -- :: Decoder s Word64 , decodeBool -- :: Decoder s Bool , decodeNull -- :: Decoder s () , decodeSimple -- :: Decoder s Word8 -- ** Specialised Read input token operations , decodeWordOf -- :: Word -> Decoder s () , decodeListLenOf -- :: Int -> Decoder s () -- ** Branching operations --, decodeBytesOrIndef --, decodeStringOrIndef , decodeListLenOrIndef -- :: Decoder s (Maybe Int) , decodeMapLenOrIndef -- :: Decoder s (Maybe Int) , decodeBreakOr -- :: Decoder s Bool -- ** Inspecting the token type , peekTokenType -- :: Decoder s TokenType , peekAvailable -- :: Decoder s Int , TokenType(..) -- ** Canonical CBOR -- $canonical , 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 , decodeBytesCanonical -- :: Decoder s ByteString , decodeByteArrayCanonical -- :: Decoder s ByteArray , decodeStringCanonical -- :: Decoder s Text , decodeUtf8ByteArrayCanonical -- :: Decoder s ByteArray , decodeListLenCanonical -- :: Decoder s Int , decodeMapLenCanonical -- :: Decoder s Int , decodeTagCanonical -- :: Decoder s Word , decodeTag64Canonical -- :: Decoder s Word64 , decodeIntegerCanonical -- :: Decoder s Integer , decodeFloat16Canonical -- :: Decoder s Float , decodeFloatCanonical -- :: Decoder s Float , decodeDoubleCanonical -- :: Decoder s Double , decodeSimpleCanonical -- :: Decoder s Word8 , decodeWordCanonicalOf -- :: Word -> Decoder s () , decodeListLenCanonicalOf -- :: Int -> Decoder s () {- -- ** Special operations , ignoreTerms , decodeTrace -} -- * Sequence operations , decodeSequenceLenIndef -- :: ... , decodeSequenceLenN -- :: ... ) where #include "cbor.h" import GHC.Exts import GHC.Word import GHC.Int import Data.Text (Text) import Data.ByteString (ByteString) import Control.Applicative import Control.Monad.ST import qualified Control.Monad.Fail as Fail import Codec.CBOR.ByteArray (ByteArray) import Prelude hiding (decodeFloat) -- | A continuation-based decoder, used for decoding values that were -- previously encoded using the "Codec.CBOR.Encoding" -- module. As @'Decoder'@ has a @'Monad'@ instance, you can easily -- write @'Decoder'@s monadically for building your deserialisation -- logic. -- -- @since 0.2.0.0 data Decoder s a = Decoder { runDecoder :: forall r. (a -> ST s (DecodeAction s r)) -> ST s (DecodeAction s r) } -- | An action, representing a step for a decoder to taken and a -- continuation to invoke with the expected value. -- -- @since 0.2.0.0 data DecodeAction s a = ConsumeWord (Word# -> ST s (DecodeAction s a)) | ConsumeWord8 (Word# -> ST s (DecodeAction s a)) | ConsumeWord16 (Word# -> ST s (DecodeAction s a)) | ConsumeWord32 (Word# -> ST s (DecodeAction s a)) | ConsumeNegWord (Word# -> ST s (DecodeAction s a)) | ConsumeInt (Int# -> ST s (DecodeAction s a)) | ConsumeInt8 (Int# -> ST s (DecodeAction s a)) | ConsumeInt16 (Int# -> ST s (DecodeAction s a)) | ConsumeInt32 (Int# -> ST s (DecodeAction s a)) | ConsumeListLen (Int# -> ST s (DecodeAction s a)) | 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)) | ConsumeNegWord64 (Word64# -> ST s (DecodeAction s a)) | ConsumeInt64 (Int64# -> ST s (DecodeAction s a)) | 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)) | 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)) | ConsumeBytesCanonical (ByteString-> ST s (DecodeAction s a)) | ConsumeByteArrayCanonical (ByteArray -> ST s (DecodeAction s a)) | ConsumeStringCanonical (Text -> ST s (DecodeAction s a)) | ConsumeUtf8ByteArrayCanonical (ByteArray -> 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)) | ConsumeMapLenIndef (ST s (DecodeAction s a)) | ConsumeNull (ST s (DecodeAction s a)) | ConsumeListLenOrIndef (Int# -> ST s (DecodeAction s a)) | ConsumeMapLenOrIndef (Int# -> ST s (DecodeAction s a)) | ConsumeBreakOr (Bool -> ST s (DecodeAction s a)) | PeekTokenType (TokenType -> ST s (DecodeAction s a)) | PeekAvailable (Int# -> ST s (DecodeAction s a)) | Fail String | Done a -- | The type of a token, which a decoder can ask for at -- an arbitrary time. -- -- @since 0.2.0.0 data TokenType = TypeUInt | TypeUInt64 | TypeNInt | TypeNInt64 | TypeInteger | TypeFloat16 | TypeFloat32 | TypeFloat64 | TypeBytes | TypeBytesIndef | TypeString | TypeStringIndef | TypeListLen | TypeListLen64 | TypeListLenIndef | TypeMapLen | TypeMapLen64 | TypeMapLenIndef | TypeTag | TypeTag64 | TypeBool | TypeNull | TypeSimple | TypeBreak | TypeInvalid deriving (Eq, Ord, Enum, Bounded, Show) -- | @since 0.2.0.0 instance Functor (Decoder s) where {-# INLINE fmap #-} fmap f = \d -> Decoder $ \k -> runDecoder d (k . f) -- | @since 0.2.0.0 instance Applicative (Decoder s) where {-# INLINE pure #-} pure = \x -> Decoder $ \k -> k x {-# INLINE (<*>) #-} (<*>) = \df dx -> Decoder $ \k -> runDecoder df (\f -> runDecoder dx (\x -> k (f x))) {-# INLINE (*>) #-} (*>) = \dm dn -> Decoder $ \k -> runDecoder dm (\_ -> runDecoder dn k) -- | @since 0.2.0.0 instance Monad (Decoder s) where return = pure {-# INLINE (>>=) #-} (>>=) = \dm f -> Decoder $ \k -> runDecoder dm (\m -> runDecoder (f m) k) {-# INLINE (>>) #-} (>>) = (*>) fail = Fail.fail -- | @since 0.2.0.0 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 -- | Given a @'Decoder'@, give us the @'DecodeAction'@ -- -- @since 0.2.0.0 getDecodeAction :: Decoder s a -> ST s (DecodeAction s a) getDecodeAction (Decoder k) = k (\x -> return (Done x)) -- $canonical -- -- -- -- In general in CBOR there can be multiple representations for the same value, -- for example the integer @0@ represented in 8, 16, 32 or 64 bits. This -- library always encodeds values in the shortest representation but on -- decoding allows any valid encoding. For some applications it is useful or -- important to only decode the canonical encoding. The decoder primitves here -- are to allow applications to implement canonical decoding. -- -- It is important to note that achieving a canonical representation is /not/ -- simply about using these primitives. For example consider a typical CBOR -- encoding of a Haskell @Set@ data type. This will be encoded as a CBOR list -- of the set elements. A typical implementation might be: -- -- > encodeSet = encodeList . Set.toList -- > decodeSet = fmap Set.fromList . decodeList -- -- This /does not/ enforce a canonical encoding. The decoder above will allow -- set elements in any order. The use of @Set.fromList@ forgets the order. -- To enforce that the decoder only accepts the canonical encoding it will -- have to check that the elemets in the list are /strictly/ increasing. -- Similar issues arise in many other data types, wherever there is redundancy -- in the external representation. -- -- The decoder primitives in this section are not much more expensive than -- their normal counterparts. If checking the canonical encoding property is -- critical then a technique that is more expensive but easier to implement and -- test is to decode normally, re-encode and check the serialised bytes are the -- same. --------------------------------------- -- Read input tokens of various types -- -- | Decode a @'Word'@. -- -- @since 0.2.0.0 decodeWord :: Decoder s Word decodeWord = Decoder (\k -> return (ConsumeWord (\w# -> k (W# w#)))) {-# INLINE decodeWord #-} -- | Decode a @'Word8'@. -- -- @since 0.2.0.0 decodeWord8 :: Decoder s Word8 decodeWord8 = Decoder (\k -> return (ConsumeWord8 (\w# -> k (W8# w#)))) {-# INLINE decodeWord8 #-} -- | Decode a @'Word16'@. -- -- @since 0.2.0.0 decodeWord16 :: Decoder s Word16 decodeWord16 = Decoder (\k -> return (ConsumeWord16 (\w# -> k (W16# w#)))) {-# INLINE decodeWord16 #-} -- | Decode a @'Word32'@. -- -- @since 0.2.0.0 decodeWord32 :: Decoder s Word32 decodeWord32 = Decoder (\k -> return (ConsumeWord32 (\w# -> k (W32# w#)))) {-# INLINE decodeWord32 #-} -- | Decode a @'Word64'@. -- -- @since 0.2.0.0 decodeWord64 :: Decoder s Word64 {-# INLINE decodeWord64 #-} decodeWord64 = #if defined(ARCH_64bit) Decoder (\k -> return (ConsumeWord (\w# -> k (W64# w#)))) #else Decoder (\k -> return (ConsumeWord64 (\w64# -> k (W64# w64#)))) #endif -- | Decode a negative @'Word'@. -- -- @since 0.2.0.0 decodeNegWord :: Decoder s Word decodeNegWord = Decoder (\k -> return (ConsumeNegWord (\w# -> k (W# w#)))) {-# INLINE decodeNegWord #-} -- | Decode a negative @'Word64'@. -- -- @since 0.2.0.0 decodeNegWord64 :: Decoder s Word64 {-# INLINE decodeNegWord64 #-} decodeNegWord64 = #if defined(ARCH_64bit) Decoder (\k -> return (ConsumeNegWord (\w# -> k (W64# w#)))) #else Decoder (\k -> return (ConsumeNegWord64 (\w64# -> k (W64# w64#)))) #endif -- | Decode an @'Int'@. -- -- @since 0.2.0.0 decodeInt :: Decoder s Int decodeInt = Decoder (\k -> return (ConsumeInt (\n# -> k (I# n#)))) {-# INLINE decodeInt #-} -- | Decode an @'Int8'@. -- -- @since 0.2.0.0 decodeInt8 :: Decoder s Int8 decodeInt8 = Decoder (\k -> return (ConsumeInt8 (\w# -> k (I8# w#)))) {-# INLINE decodeInt8 #-} -- | Decode an @'Int16'@. -- -- @since 0.2.0.0 decodeInt16 :: Decoder s Int16 decodeInt16 = Decoder (\k -> return (ConsumeInt16 (\w# -> k (I16# w#)))) {-# INLINE decodeInt16 #-} -- | Decode an @'Int32'@. -- -- @since 0.2.0.0 decodeInt32 :: Decoder s Int32 decodeInt32 = Decoder (\k -> return (ConsumeInt32 (\w# -> k (I32# w#)))) {-# INLINE decodeInt32 #-} -- | Decode an @'Int64'@. -- -- @since 0.2.0.0 decodeInt64 :: Decoder s Int64 {-# INLINE decodeInt64 #-} decodeInt64 = #if defined(ARCH_64bit) Decoder (\k -> return (ConsumeInt (\n# -> k (I64# n#)))) #else 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 decodeInteger :: Decoder s Integer decodeInteger = Decoder (\k -> return (ConsumeInteger (\n -> k n))) {-# INLINE decodeInteger #-} -- | Decode a @'Float'@. -- -- @since 0.2.0.0 decodeFloat :: Decoder s Float decodeFloat = Decoder (\k -> return (ConsumeFloat (\f# -> k (F# f#)))) {-# INLINE decodeFloat #-} -- | Decode a @'Double'@. -- -- @since 0.2.0.0 decodeDouble :: Decoder s Double decodeDouble = Decoder (\k -> return (ConsumeDouble (\f# -> k (D# f#)))) {-# INLINE decodeDouble #-} -- | Decode a string of bytes as a @'ByteString'@. -- -- @since 0.2.0.0 decodeBytes :: Decoder s ByteString decodeBytes = Decoder (\k -> return (ConsumeBytes (\bs -> k bs))) {-# INLINE decodeBytes #-} -- | Decode canonical representation of a string of bytes as a @'ByteString'@. -- -- @since 0.2.1.0 decodeBytesCanonical :: Decoder s ByteString decodeBytesCanonical = Decoder (\k -> return (ConsumeBytesCanonical (\bs -> k bs))) {-# INLINE decodeBytesCanonical #-} -- | Decode a token marking the beginning of an indefinite length -- set of bytes. -- -- @since 0.2.0.0 decodeBytesIndef :: Decoder s () 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 canonical representation of 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.1.0 decodeByteArrayCanonical :: Decoder s ByteArray decodeByteArrayCanonical = Decoder (\k -> return (ConsumeByteArrayCanonical k)) {-# INLINE decodeByteArrayCanonical #-} -- | Decode a textual string as a piece of @'Text'@. -- -- @since 0.2.0.0 decodeString :: Decoder s Text decodeString = Decoder (\k -> return (ConsumeString (\str -> k str))) {-# INLINE decodeString #-} -- | Decode canonical representation of a textual string as a piece of @'Text'@. -- -- @since 0.2.1.0 decodeStringCanonical :: Decoder s Text decodeStringCanonical = Decoder (\k -> return (ConsumeStringCanonical (\str -> k str))) {-# INLINE decodeStringCanonical #-} -- | Decode a token marking the beginning of an indefinite length -- string. -- -- @since 0.2.0.0 decodeStringIndef :: Decoder s () 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 canonical representation of 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.1.0 decodeUtf8ByteArrayCanonical :: Decoder s ByteArray decodeUtf8ByteArrayCanonical = Decoder (\k -> return (ConsumeUtf8ByteArrayCanonical k)) {-# INLINE decodeUtf8ByteArrayCanonical #-} -- | Decode the length of a list. -- -- @since 0.2.0.0 decodeListLen :: Decoder s Int 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. -- -- @since 0.2.0.0 decodeListLenIndef :: Decoder s () decodeListLenIndef = Decoder (\k -> return (ConsumeListLenIndef (k ()))) {-# INLINE decodeListLenIndef #-} -- | Decode the length of a map. -- -- @since 0.2.0.0 decodeMapLen :: Decoder s Int 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. -- -- @since 0.2.0.0 decodeMapLenIndef :: Decoder s () decodeMapLenIndef = Decoder (\k -> return (ConsumeMapLenIndef (k ()))) {-# INLINE decodeMapLenIndef #-} -- | Decode an arbitrary tag and return it as a @'Word'@. -- -- @since 0.2.0.0 decodeTag :: Decoder s Word decodeTag = Decoder (\k -> return (ConsumeTag (\w# -> k (W# w#)))) {-# INLINE decodeTag #-} -- | Decode an arbitrary 64-bit tag and return it as a @'Word64'@. -- -- @since 0.2.0.0 decodeTag64 :: Decoder s Word64 {-# INLINE decodeTag64 #-} decodeTag64 = #if defined(ARCH_64bit) Decoder (\k -> return (ConsumeTag (\w# -> k (W64# w#)))) #else 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 decodeBool :: Decoder s Bool decodeBool = Decoder (\k -> return (ConsumeBool (\b -> k b))) {-# INLINE decodeBool #-} -- | Decode a nullary value, and return a unit value. -- -- @since 0.2.0.0 decodeNull :: Decoder s () decodeNull = Decoder (\k -> return (ConsumeNull (k ()))) {-# INLINE decodeNull #-} -- | Decode a 'simple' CBOR value and give back a @'Word8'@. You -- probably don't ever need to use this. -- -- @since 0.2.0.0 decodeSimple :: Decoder s Word8 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 -- -- | Attempt to decode a word with @'decodeWord'@, and ensure the word -- is exactly as expected, or fail. -- -- @since 0.2.0.0 decodeWordOf :: Word -- ^ Expected value of the decoded word -> Decoder s () decodeWordOf = decodeWordOfHelper decodeWord {-# INLINE decodeWordOf #-} -- | Attempt to decode a list length using @'decodeListLen'@, and -- ensure it is exactly the specified length, or fail. -- -- @since 0.2.0.0 decodeListLenOf :: Int -> Decoder s () 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 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 -- | Attempt to decode a token for the length of a finite, known list, -- or an indefinite list. If @'Nothing'@ is returned, then an -- indefinite length list occurs afterwords. If @'Just' x@ is -- returned, then a list of length @x@ is encoded. -- -- @since 0.2.0.0 decodeListLenOrIndef :: Decoder s (Maybe Int) decodeListLenOrIndef = Decoder (\k -> return (ConsumeListLenOrIndef (\n# -> if I# n# >= 0 then k (Just (I# n#)) else k Nothing))) {-# INLINE decodeListLenOrIndef #-} -- | Attempt to decode a token for the length of a finite, known map, -- or an indefinite map. If @'Nothing'@ is returned, then an -- indefinite length map occurs afterwords. If @'Just' x@ is returned, -- then a map of length @x@ is encoded. -- -- @since 0.2.0.0 decodeMapLenOrIndef :: Decoder s (Maybe Int) decodeMapLenOrIndef = Decoder (\k -> return (ConsumeMapLenOrIndef (\n# -> if I# n# >= 0 then k (Just (I# n#)) else k Nothing))) {-# INLINE decodeMapLenOrIndef #-} -- | Attempt to decode a @Break@ token, and if that was -- successful, return @'True'@. If the token was of any -- other type, return @'False'@. -- -- @since 0.2.0.0 decodeBreakOr :: Decoder s Bool decodeBreakOr = Decoder (\k -> return (ConsumeBreakOr (\b -> k b))) {-# INLINE decodeBreakOr #-} -------------------------------------------------------------- -- Special operations -- | Peek at the current token we're about to decode, and return a -- @'TokenType'@ specifying what it is. -- -- @since 0.2.0.0 peekTokenType :: Decoder s TokenType peekTokenType = Decoder (\k -> return (PeekTokenType (\tk -> k tk))) {-# INLINE peekTokenType #-} -- | Peek and return the length of the current buffer that we're -- running our decoder on. -- -- @since 0.2.0.0 peekAvailable :: Decoder s Int peekAvailable = Decoder (\k -> return (PeekAvailable (\len# -> k (I# len#)))) {-# INLINE peekAvailable #-} {- expectExactly :: Word -> Decoder (Word :#: s) s expectExactly n = expectExactly_ n done expectAtLeast :: Word -> Decoder (Word :#: s) (Word :#: s) expectAtLeast n = expectAtLeast_ n done ignoreTrailingTerms :: Decoder (a :*: Word :#: s) (a :*: s) ignoreTrailingTerms = IgnoreTerms done -} ------------------------------------------------------------------------------ -- Special combinations for sequences -- -- | Decode an indefinite sequence length. -- -- @since 0.2.0.0 decodeSequenceLenIndef :: (r -> a -> r) -> r -> (r -> r') -> Decoder s a -> Decoder s r' decodeSequenceLenIndef f z g get = go z where go !acc = do stop <- decodeBreakOr if stop then return $! g acc else do !x <- get; go (f acc x) {-# INLINE decodeSequenceLenIndef #-} -- | Decode a sequence length. -- -- @since 0.2.0.0 decodeSequenceLenN :: (r -> a -> r) -> r -> (r -> r') -> Int -> Decoder s a -> Decoder s r' decodeSequenceLenN f z g c get = go z c where go !acc 0 = return $! g acc go !acc n = do !x <- get; go (f acc x) (n-1) {-# INLINE decodeSequenceLenN #-} cborg-0.2.1.0/src/Codec/CBOR/FlatTerm.hs0000644000000000000000000007240413357736054015561 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} -- | -- Module : Codec.CBOR.FlatTerm -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- A simpler form than CBOR for writing out @'Enc.Encoding'@ values that allows -- easier verification and testing. While this library primarily focuses -- on taking @'Enc.Encoding'@ values (independent of any underlying format) -- and serializing them into CBOR format, this module offers an alternative -- format called @'FlatTerm'@ for serializing @'Enc.Encoding'@ values. -- -- The @'FlatTerm'@ form is very simple and internally mirrors the original -- @'Encoding'@ type very carefully. The intention here is that once you -- have @'Enc.Encoding'@ and @'Dec.Decoding'@ values for your types, you can -- round-trip values through @'FlatTerm'@ to catch bugs more easily and with -- a smaller amount of code to look through. -- -- For that reason, this module is primarily useful for client libraries, -- and even then, only for their test suites to offer a simpler form for -- doing encoding tests and catching problems in an encoder and decoder. -- module Codec.CBOR.FlatTerm ( -- * Types FlatTerm -- :: * , TermToken(..) -- :: * -- * Functions , toFlatTerm -- :: Encoding -> FlatTerm , fromFlatTerm -- :: Decoder s a -> FlatTerm -> Either String a , validFlatTerm -- :: FlatTerm -> Bool ) where #include "cbor.h" 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) import GHC.Int (Int64(I64#)) import GHC.Word (Word64(W64#)) import GHC.Exts (Word64#, Int64#) #endif import GHC.Word (Word(W#), Word8(W8#)) import GHC.Exts (Int(I#), Int#, Word#, Float#, Double#) import GHC.Float (Float(F#), Double(D#), float2Double) import Data.Word import Data.Text (Text) import qualified Data.Text.Encoding as TE import Data.ByteString (ByteString) import Control.Monad.ST -------------------------------------------------------------------------------- -- | A "flat" representation of an @'Enc.Encoding'@ value, -- useful for round-tripping and writing tests. -- -- @since 0.2.0.0 type FlatTerm = [TermToken] -- | A concrete encoding of @'Enc.Encoding'@ values, one -- which mirrors the original @'Enc.Encoding'@ type closely. -- -- @since 0.2.0.0 data TermToken = TkInt {-# UNPACK #-} !Int | TkInteger !Integer | TkBytes {-# UNPACK #-} !ByteString | TkBytesBegin | TkString {-# UNPACK #-} !Text | TkStringBegin | TkListLen {-# UNPACK #-} !Word | TkListBegin | TkMapLen {-# UNPACK #-} !Word | TkMapBegin | TkBreak | TkTag {-# UNPACK #-} !Word64 | TkBool !Bool | TkNull | TkSimple {-# UNPACK #-} !Word8 | TkFloat16 {-# UNPACK #-} !Float | TkFloat32 {-# UNPACK #-} !Float | TkFloat64 {-# UNPACK #-} !Double deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- -- | Convert an arbitrary @'Enc.Encoding'@ into a @'FlatTerm'@. -- -- @since 0.2.0.0 toFlatTerm :: Encoding -- ^ The input @'Enc.Encoding'@. -> FlatTerm -- ^ The resulting @'FlatTerm'@. toFlatTerm (Encoding tb) = convFlatTerm (tb Enc.TkEnd) convFlatTerm :: Enc.Tokens -> FlatTerm convFlatTerm (Enc.TkWord w ts) | w <= maxInt = TkInt (fromIntegral w) : convFlatTerm ts | otherwise = TkInteger (fromIntegral w) : convFlatTerm ts convFlatTerm (Enc.TkWord64 w ts) | w <= maxInt = TkInt (fromIntegral w) : convFlatTerm ts | otherwise = TkInteger (fromIntegral w) : convFlatTerm ts convFlatTerm (Enc.TkInt n ts) = TkInt n : convFlatTerm ts convFlatTerm (Enc.TkInt64 n ts) | n <= maxInt && n >= minInt = TkInt (fromIntegral n) : convFlatTerm ts | otherwise = TkInteger (fromIntegral n) : convFlatTerm ts convFlatTerm (Enc.TkInteger n ts) | n <= maxInt && n >= minInt = TkInt (fromIntegral n) : convFlatTerm ts | 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 convFlatTerm (Enc.TkMapBegin ts) = TkMapBegin : convFlatTerm ts convFlatTerm (Enc.TkTag n ts) = TkTag (fromIntegral n) : convFlatTerm ts convFlatTerm (Enc.TkTag64 n ts) = TkTag n : convFlatTerm ts convFlatTerm (Enc.TkBool b ts) = TkBool b : convFlatTerm ts convFlatTerm (Enc.TkNull ts) = TkNull : convFlatTerm ts convFlatTerm (Enc.TkUndef ts) = TkSimple 23 : convFlatTerm ts convFlatTerm (Enc.TkSimple n ts) = TkSimple n : convFlatTerm ts convFlatTerm (Enc.TkFloat16 f ts) = TkFloat16 f : convFlatTerm ts convFlatTerm (Enc.TkFloat32 f ts) = TkFloat32 f : convFlatTerm ts convFlatTerm (Enc.TkFloat64 f ts) = TkFloat64 f : convFlatTerm ts convFlatTerm (Enc.TkBreak ts) = TkBreak : convFlatTerm ts convFlatTerm Enc.TkEnd = [] -------------------------------------------------------------------------------- -- | Given a @'Dec.Decoder'@, decode a @'FlatTerm'@ back into -- an ordinary value, or return an error. -- -- @since 0.2.0.0 fromFlatTerm :: (forall s. Decoder s a) -- ^ A @'Dec.Decoder'@ for a serialised value. -> FlatTerm -- ^ The serialised @'FlatTerm'@. -> Either String a -- ^ The deserialised value, or an error. fromFlatTerm decoder ft = runST (getDecodeAction decoder >>= go ft) where go :: FlatTerm -> DecodeAction s a -> ST s (Either String a) go (TkInt n : ts) (ConsumeWord k) | n >= 0 = k (unW# (fromIntegral n)) >>= go ts go (TkInteger n : ts) (ConsumeWord k) | n >= 0 = k (unW# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeWord8 k) | n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts go (TkInteger n : ts) (ConsumeWord8 k) | n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeWord16 k) | n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts go (TkInteger n : ts) (ConsumeWord16 k) | n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeWord32 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) (ConsumeWord32 k) | n >= 0 && n <= maxWord32 = k (unW# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeNegWord k) | n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts go (TkInteger n : ts) (ConsumeNegWord k) | n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts go (TkInt n : ts) (ConsumeInt k) = k (unI# n) >>= go ts go (TkInteger n : ts) (ConsumeInt k) | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeInt8 k) | n >= minInt8 && n <= maxInt8 = k (unI# n) >>= go ts go (TkInteger n : ts) (ConsumeInt8 k) | n >= minInt8 && n <= maxInt8 = k (unI# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeInt16 k) | n >= minInt16 && n <= maxInt16 = k (unI# n) >>= go ts go (TkInteger n : ts) (ConsumeInt16 k) | n >= minInt16 && n <= maxInt16 = k (unI# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeInt32 k) | n >= minInt32 && n <= maxInt32 = k (unI# n) >>= go ts go (TkInteger n : ts) (ConsumeInt32 k) | n >= minInt32 && n <= maxInt32 = k (unI# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeInteger k) = k (fromIntegral n) >>= go ts go (TkInteger n : ts) (ConsumeInteger k) = k n >>= go ts go (TkListLen n : ts) (ConsumeListLen k) | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts go (TkMapLen n : ts) (ConsumeMapLen k) | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts 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) | n >= 0 = k (unW64# (fromIntegral n)) >>= go ts go (TkInteger n : ts) (ConsumeWord64 k) | n >= 0 = k (unW64# (fromIntegral n)) >>= go ts go (TkInt n : ts) (ConsumeNegWord64 k) | n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts go (TkInteger n : ts) (ConsumeNegWord64 k) | n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts go (TkInt n : ts) (ConsumeInt64 k) = k (unI64# (fromIntegral n)) >>= go ts go (TkInteger n : ts) (ConsumeInt64 k) = k (unI64# (fromIntegral n)) >>= go ts 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 (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 (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 (TkBytes bs : ts) (ConsumeBytesCanonical k) = k bs >>= go ts go (TkBytes bs : ts) (ConsumeByteArrayCanonical k) = k (BA.fromByteString bs) >>= go ts go (TkString st : ts) (ConsumeStringCanonical k) = k st >>= go ts go (TkString st : ts) (ConsumeUtf8ByteArrayCanonical k) = k (BA.fromByteString $ TE.encodeUtf8 st) >>= 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 go (TkMapBegin : ts) (ConsumeMapLenIndef da) = da >>= go ts go (TkNull : ts) (ConsumeNull da) = da >>= go ts go (TkListLen n : ts) (ConsumeListLenOrIndef k) | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts go (TkListBegin : ts) (ConsumeListLenOrIndef k) = k (-1#) >>= go ts go (TkMapLen n : ts) (ConsumeMapLenOrIndef k) | n <= maxInt = k (unI# (fromIntegral n)) >>= go ts go (TkMapBegin : ts) (ConsumeMapLenOrIndef k) = k (-1#) >>= go ts go (TkBreak : ts) (ConsumeBreakOr k) = k True >>= go ts go ts@(_ : _ ) (ConsumeBreakOr k) = k False >>= go ts go ts@(tk:_) (PeekTokenType k) = k (tokenTypeOf tk) >>= go ts go ts (PeekTokenType _) = unexpected "peekTokenType" ts go ts (PeekAvailable k) = k (unI# (length ts)) >>= go ts go _ (Fail msg) = return $ Left msg go [] (Done x) = return $ Right x go ts (Done _) = return $ Left ("trailing tokens: " ++ show (take 5 ts)) ---------------------------------------------------------------------------- -- Fallthrough cases: unhandled token/DecodeAction combinations go ts (ConsumeWord _) = unexpected "decodeWord" ts go ts (ConsumeWord8 _) = unexpected "decodeWord8" ts go ts (ConsumeWord16 _) = unexpected "decodeWord16" ts go ts (ConsumeWord32 _) = unexpected "decodeWord32" ts go ts (ConsumeNegWord _) = unexpected "decodeNegWord" ts go ts (ConsumeInt _) = unexpected "decodeInt" ts go ts (ConsumeInt8 _) = unexpected "decodeInt8" ts go ts (ConsumeInt16 _) = unexpected "decodeInt16" ts go ts (ConsumeInt32 _) = unexpected "decodeInt32" ts go ts (ConsumeInteger _) = unexpected "decodeInteger" ts go ts (ConsumeListLen _) = unexpected "decodeListLen" ts 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 (ConsumeBytesCanonical _) = unexpected "decodeBytesCanonical" ts go ts (ConsumeByteArrayCanonical _) = unexpected "decodeByteArrayCanonical" ts go ts (ConsumeStringCanonical _) = unexpected "decodeStringCanonical" ts go ts (ConsumeUtf8ByteArrayCanonical _) = unexpected "decodeUtf8ByteArrayCanonical" ts go ts (ConsumeSimpleCanonical _) = unexpected "decodeSimpleCanonical" ts #if defined(ARCH_32bit) -- 64bit variants for 32bit machines go ts (ConsumeWord64 _) = unexpected "decodeWord64" ts go ts (ConsumeNegWord64 _) = unexpected "decodeNegWord64" ts go ts (ConsumeInt64 _) = unexpected "decodeInt64" ts 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 go ts (ConsumeStringIndef _) = unexpected "decodeStringIndef" ts go ts (ConsumeListLenIndef _) = unexpected "decodeListLenIndef" ts go ts (ConsumeMapLenIndef _) = unexpected "decodeMapLenIndef" ts go ts (ConsumeNull _) = unexpected "decodeNull" ts go ts (ConsumeListLenOrIndef _) = unexpected "decodeListLenOrIndef" ts go ts (ConsumeMapLenOrIndef _) = unexpected "decodeMapLenOrIndef" ts go ts (ConsumeBreakOr _) = unexpected "decodeBreakOr" ts unexpected name [] = return $ Left $ name ++ ": unexpected end of input" unexpected name (tok:_) = return $ Left $ name ++ ": unexpected token " ++ show tok -- | Map a @'TermToken'@ to the underlying CBOR @'TokenType'@ tokenTypeOf :: TermToken -> TokenType tokenTypeOf (TkInt n) | n >= 0 = TypeUInt | otherwise = TypeNInt tokenTypeOf TkInteger{} = TypeInteger tokenTypeOf TkBytes{} = TypeBytes tokenTypeOf TkBytesBegin{} = TypeBytesIndef tokenTypeOf TkString{} = TypeString tokenTypeOf TkStringBegin{} = TypeStringIndef tokenTypeOf TkListLen{} = TypeListLen tokenTypeOf TkListBegin{} = TypeListLenIndef tokenTypeOf TkMapLen{} = TypeMapLen tokenTypeOf TkMapBegin{} = TypeMapLenIndef tokenTypeOf TkTag{} = TypeTag tokenTypeOf TkBool{} = TypeBool tokenTypeOf TkNull = TypeNull tokenTypeOf TkBreak = TypeBreak tokenTypeOf TkSimple{} = TypeSimple tokenTypeOf TkFloat16{} = TypeFloat16 tokenTypeOf TkFloat32{} = TypeFloat32 tokenTypeOf TkFloat64{} = TypeFloat64 -------------------------------------------------------------------------------- -- | Ensure a @'FlatTerm'@ is internally consistent and was created in a valid -- manner. -- -- @since 0.2.0.0 validFlatTerm :: FlatTerm -- ^ The input @'FlatTerm'@ -> Bool -- ^ @'True'@ if valid, @'False'@ otherwise. validFlatTerm ts = either (const False) (const True) $ do ts' <- validateTerm TopLevelSingle ts case ts' of [] -> return () _ -> Left "trailing data" -- | A data type used for tracking the position we're at -- as we traverse a @'FlatTerm'@ and make sure it's valid. data Loc = TopLevelSingle | TopLevelSequence | InString Int Loc | InBytes Int Loc | InListN Int Int Loc | InList Int Loc | InMapNKey Int Int Loc | InMapNVal Int Int Loc | InMapKey Int Loc | InMapVal Int Loc | InTagged Word64 Loc deriving Show -- | Validate an arbitrary @'FlatTerm'@ at an arbitrary location. validateTerm :: Loc -> FlatTerm -> Either String FlatTerm validateTerm _loc (TkInt _ : ts) = return ts validateTerm _loc (TkInteger _ : ts) = return ts validateTerm _loc (TkBytes _ : ts) = return ts validateTerm loc (TkBytesBegin : ts) = validateBytes loc 0 ts validateTerm _loc (TkString _ : ts) = return ts validateTerm loc (TkStringBegin : ts) = validateString loc 0 ts validateTerm loc (TkListLen len : ts) | len <= maxInt = validateListN loc 0 (fromIntegral len) ts | otherwise = Left "list len too long (> max int)" validateTerm loc (TkListBegin : ts) = validateList loc 0 ts validateTerm loc (TkMapLen len : ts) | len <= maxInt = validateMapN loc 0 (fromIntegral len) ts | otherwise = Left "map len too long (> max int)" validateTerm loc (TkMapBegin : ts) = validateMap loc 0 ts validateTerm loc (TkTag w : ts) = validateTerm (InTagged w loc) ts validateTerm _loc (TkBool _ : ts) = return ts validateTerm _loc (TkNull : ts) = return ts validateTerm loc (TkBreak : _) = unexpectedToken TkBreak loc validateTerm _loc (TkSimple _ : ts) = return ts validateTerm _loc (TkFloat16 _ : ts) = return ts validateTerm _loc (TkFloat32 _ : ts) = return ts validateTerm _loc (TkFloat64 _ : ts) = return ts validateTerm loc [] = unexpectedEof loc unexpectedToken :: TermToken -> Loc -> Either String a unexpectedToken tok loc = Left $ "unexpected token " ++ show tok ++ ", in context " ++ show loc unexpectedEof :: Loc -> Either String a unexpectedEof loc = Left $ "unexpected end of input in context " ++ show loc validateBytes :: Loc -> Int -> [TermToken] -> Either String [TermToken] validateBytes _ _ (TkBreak : ts) = return ts validateBytes ploc i (TkBytes _ : ts) = validateBytes ploc (i+1) ts validateBytes ploc i (tok : _) = unexpectedToken tok (InBytes i ploc) validateBytes ploc i [] = unexpectedEof (InBytes i ploc) validateString :: Loc -> Int -> [TermToken] -> Either String [TermToken] validateString _ _ (TkBreak : ts) = return ts validateString ploc i (TkString _ : ts) = validateString ploc (i+1) ts validateString ploc i (tok : _) = unexpectedToken tok (InString i ploc) validateString ploc i [] = unexpectedEof (InString i ploc) validateListN :: Loc -> Int -> Int -> [TermToken] -> Either String [TermToken] validateListN _ i len ts | i == len = return ts validateListN ploc i len ts = do ts' <- validateTerm (InListN i len ploc) ts validateListN ploc (i+1) len ts' validateList :: Loc -> Int -> [TermToken] -> Either String [TermToken] validateList _ _ (TkBreak : ts) = return ts validateList ploc i ts = do ts' <- validateTerm (InList i ploc) ts validateList ploc (i+1) ts' validateMapN :: Loc -> Int -> Int -> [TermToken] -> Either String [TermToken] validateMapN _ i len ts | i == len = return ts validateMapN ploc i len ts = do ts' <- validateTerm (InMapNKey i len ploc) ts ts'' <- validateTerm (InMapNVal i len ploc) ts' validateMapN ploc (i+1) len ts'' validateMap :: Loc -> Int -> [TermToken] -> Either String [TermToken] validateMap _ _ (TkBreak : ts) = return ts validateMap ploc i ts = do ts' <- validateTerm (InMapKey i ploc) ts ts'' <- validateTerm (InMapVal i ploc) ts' validateMap ploc (i+1) ts'' -------------------------------------------------------------------------------- -- Utilities maxInt, minInt, maxWord :: Num n => n maxInt = fromIntegral (maxBound :: Int) minInt = fromIntegral (minBound :: Int) maxWord = fromIntegral (maxBound :: Word) maxInt8, minInt8, maxWord8 :: Num n => n maxInt8 = fromIntegral (maxBound :: Int8) minInt8 = fromIntegral (minBound :: Int8) maxWord8 = fromIntegral (maxBound :: Word8) maxInt16, minInt16, maxWord16 :: Num n => n maxInt16 = fromIntegral (maxBound :: Int16) minInt16 = fromIntegral (minBound :: Int16) maxWord16 = fromIntegral (maxBound :: Word16) maxInt32, minInt32, maxWord32 :: Num n => n maxInt32 = fromIntegral (maxBound :: Int32) minInt32 = fromIntegral (minBound :: Int32) maxWord32 = fromIntegral (maxBound :: Word32) -- | Do a careful check to ensure an @'Int'@ is in the -- range of a @'Word32'@. intIsValidWord32 :: Int -> Bool intIsValidWord32 n = b1 && b2 where -- NOTE: this first comparison must use Int for -- the check, not Word32, in case a negative value -- is given. Otherwise this check would fail due to -- overflow. b1 = n >= 0 -- NOTE: we must convert n to Word32, otherwise, -- maxWord32 is inferred as Int, and because -- the maxBound of Word32 is greater than Int, -- it overflows and this check fails. b2 = (fromIntegral n :: Word32) <= maxWord32 unI# :: Int -> Int# unI# (I# i#) = i# unW# :: Word -> Word# unW# (W# w#) = w# unW8# :: Word8 -> Word# unW8# (W8# w#) = w# unF# :: Float -> Float# unF# (F# f#) = f# unD# :: Double -> Double# unD# (D# f#) = f# #if defined(ARCH_32bit) unW64# :: Word64 -> Word64# unW64# (W64# w#) = w# unI64# :: Int64 -> Int64# unI64# (I64# i#) = i# #endif cborg-0.2.1.0/src/Codec/CBOR/Term.hs0000644000000000000000000002270213357736054014746 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -- | -- Module : Codec.CBOR.Term -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- This module provides an interface for decoding and encoding arbitrary -- CBOR values (ones that, for example, may not have been generated by this -- library). -- -- Using @'decodeTerm'@, you can decode an arbitrary CBOR value given to you -- into a @'Term'@, which represents a CBOR value as an AST. -- -- Similarly, if you wanted to encode some value into a CBOR value directly, -- you can wrap it in a @'Term'@ constructor and use @'encodeTerm'@. This -- would be useful, as an example, if you needed to serialise some value into -- a CBOR term that is not compatible with that types @'Serialise'@ instance. -- -- Because this interface gives you the ability to decode or encode any -- arbitrary CBOR term, it can also be seen as an alternative interface to the -- @'Codec.CBOR.Encoding'@ and -- @'Codec.CBOR.Decoding'@ modules. -- module Codec.CBOR.Term ( Term(..) -- :: * , encodeTerm -- :: Term -> Encoding , decodeTerm -- :: Decoder Term ) where #include "cbor.h" import Codec.CBOR.Encoding hiding (Tokens(..)) import Codec.CBOR.Decoding import Data.Word import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Monoid import Control.Applicative import Prelude hiding (encodeFloat, decodeFloat) -------------------------------------------------------------------------------- -- Types -- | A general CBOR term, which can be used to serialise or deserialise -- arbitrary CBOR terms for interoperability or debugging. This type is -- essentially a direct reflection of the CBOR abstract syntax tree as a -- Haskell data type. -- -- The @'Term'@ type also comes with a @'Serialise'@ instance, so you can -- easily use @'decode' :: 'Decoder' 'Term'@ to directly decode any arbitrary -- CBOR value into Haskell with ease, and likewise with @'encode'@. -- -- @since 0.2.0.0 data Term = TInt {-# UNPACK #-} !Int | TInteger !Integer | TBytes !BS.ByteString | TBytesI !LBS.ByteString | TString !T.Text | TStringI !LT.Text | TList ![Term] | TListI ![Term] | TMap ![(Term, Term)] | TMapI ![(Term, Term)] | TTagged {-# UNPACK #-} !Word64 !Term | TBool !Bool | TNull | TSimple {-# UNPACK #-} !Word8 | THalf {-# UNPACK #-} !Float | TFloat {-# UNPACK #-} !Float | TDouble {-# UNPACK #-} !Double deriving (Eq, Ord, Show, Read) -------------------------------------------------------------------------------- -- Main API -- | Encode an arbitrary @'Term'@ into an @'Encoding'@ for later serialization. -- -- @since 0.2.0.0 encodeTerm :: Term -> Encoding encodeTerm (TInt n) = encodeInt n encodeTerm (TInteger n) = encodeInteger n encodeTerm (TBytes bs) = encodeBytes bs encodeTerm (TString st) = encodeString st encodeTerm (TBytesI bss) = encodeBytesIndef <> mconcat [ encodeBytes bs | bs <- LBS.toChunks bss ] <> encodeBreak encodeTerm (TStringI sts) = encodeStringIndef <> mconcat [ encodeString str | str <- LT.toChunks sts ] <> encodeBreak encodeTerm (TList ts) = encodeListLen (fromIntegral $ length ts) <> mconcat [ encodeTerm t | t <- ts ] encodeTerm (TListI ts) = encodeListLenIndef <> mconcat [ encodeTerm t | t <- ts ] <> encodeBreak encodeTerm (TMap ts) = encodeMapLen (fromIntegral $ length ts) <> mconcat [ encodeTerm t <> encodeTerm t' | (t, t') <- ts ] encodeTerm (TMapI ts) = encodeMapLenIndef <> mconcat [ encodeTerm t <> encodeTerm t' | (t, t') <- ts ] <> encodeBreak encodeTerm (TTagged w t) = encodeTag64 w <> encodeTerm t encodeTerm (TBool b) = encodeBool b encodeTerm TNull = encodeNull encodeTerm (TSimple w) = encodeSimple w encodeTerm (THalf f) = encodeFloat16 f encodeTerm (TFloat f) = encodeFloat f encodeTerm (TDouble f) = encodeDouble f -- | Decode some arbitrary CBOR value into a @'Term'@. -- -- @since 0.2.0.0 decodeTerm :: Decoder s Term decodeTerm = do tkty <- peekTokenType case tkty of TypeUInt -> do w <- decodeWord return $! fromWord w where fromWord :: Word -> Term fromWord w | w <= fromIntegral (maxBound :: Int) = TInt (fromIntegral w) | otherwise = TInteger (fromIntegral w) TypeUInt64 -> do w <- decodeWord64 return $! fromWord64 w where fromWord64 w | w <= fromIntegral (maxBound :: Int) = TInt (fromIntegral w) | otherwise = TInteger (fromIntegral w) TypeNInt -> do w <- decodeNegWord return $! fromNegWord w where fromNegWord w | w <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral w) | otherwise = TInteger (-1 - fromIntegral w) TypeNInt64 -> do w <- decodeNegWord64 return $! fromNegWord64 w where fromNegWord64 w | w <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral w) | otherwise = TInteger (-1 - fromIntegral w) TypeInteger -> do !x <- decodeInteger return (TInteger x) TypeFloat16 -> do !x <- decodeFloat return (THalf x) TypeFloat32 -> do !x <- decodeFloat return (TFloat x) TypeFloat64 -> do !x <- decodeDouble return (TDouble x) TypeBytes -> do !x <- decodeBytes return (TBytes x) TypeBytesIndef -> decodeBytesIndef >> decodeBytesIndefLen [] TypeString -> do !x <- decodeString return (TString x) TypeStringIndef -> decodeStringIndef >> decodeStringIndefLen [] TypeListLen -> decodeListLen >>= flip decodeListN [] TypeListLen64 -> decodeListLen >>= flip decodeListN [] TypeListLenIndef -> decodeListLenIndef >> decodeListIndefLen [] TypeMapLen -> decodeMapLen >>= flip decodeMapN [] TypeMapLen64 -> decodeMapLen >>= flip decodeMapN [] TypeMapLenIndef -> decodeMapLenIndef >> decodeMapIndefLen [] TypeTag -> do !x <- decodeTag64 !y <- decodeTerm return (TTagged x y) TypeTag64 -> do !x <- decodeTag64 !y <- decodeTerm return (TTagged x y) TypeBool -> do !x <- decodeBool return (TBool x) TypeNull -> TNull <$ decodeNull TypeSimple -> do !x <- decodeSimple return (TSimple x) TypeBreak -> fail "unexpected break" TypeInvalid -> fail "invalid token encoding" -------------------------------------------------------------------------------- -- Internal utilities decodeBytesIndefLen :: [BS.ByteString] -> Decoder s Term decodeBytesIndefLen acc = do stop <- decodeBreakOr if stop then return $! TBytesI (LBS.fromChunks (reverse acc)) else do !bs <- decodeBytes decodeBytesIndefLen (bs : acc) decodeStringIndefLen :: [T.Text] -> Decoder s Term decodeStringIndefLen acc = do stop <- decodeBreakOr if stop then return $! TStringI (LT.fromChunks (reverse acc)) else do !str <- decodeString decodeStringIndefLen (str : acc) decodeListN :: Int -> [Term] -> Decoder s Term decodeListN !n acc = case n of 0 -> return $! TList (reverse acc) _ -> do !t <- decodeTerm decodeListN (n-1) (t : acc) decodeListIndefLen :: [Term] -> Decoder s Term decodeListIndefLen acc = do stop <- decodeBreakOr if stop then return $! TListI (reverse acc) else do !tm <- decodeTerm decodeListIndefLen (tm : acc) decodeMapN :: Int -> [(Term, Term)] -> Decoder s Term decodeMapN !n acc = case n of 0 -> return $! TMap (reverse acc) _ -> do !tm <- decodeTerm !tm' <- decodeTerm decodeMapN (n-1) ((tm, tm') : acc) decodeMapIndefLen :: [(Term, Term)] -> Decoder s Term decodeMapIndefLen acc = do stop <- decodeBreakOr if stop then return $! TMapI (reverse acc) else do !tm <- decodeTerm !tm' <- decodeTerm decodeMapIndefLen ((tm, tm') : acc) cborg-0.2.1.0/src/Codec/CBOR/FlatTerm.hs-boot0000644000000000000000000000026413357736054016515 0ustar0000000000000000module Codec.CBOR.FlatTerm where import {-# SOURCE #-} Codec.CBOR.Encoding type FlatTerm = [TermToken] data TermToken instance Show TermToken toFlatTerm :: Encoding -> FlatTermcborg-0.2.1.0/src/Codec/CBOR/Magic.hs0000644000000000000000000004703013357736054015060 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} #include "cbor.h" -- | -- Module : Codec.CBOR.Magic -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- An internal module for doing magical, low-level, and unholy things -- in the name of efficiency. -- module Codec.CBOR.Magic ( -- * Word utilities grabWord8 -- :: Ptr () -> Word , grabWord16 -- :: Ptr () -> Word , grabWord32 -- :: Ptr () -> Word , grabWord64 -- :: Ptr () -> Word64 -- * @'ByteString'@ utilities , eatTailWord8 -- :: ByteString -> Word , eatTailWord16 -- :: ByteString -> Word , eatTailWord32 -- :: ByteString -> Word , eatTailWord64 -- :: ByteString -> Word64 -- * Half-floats , wordToFloat16 -- :: Word -> Float , floatToWord16 -- :: Float -> Word16 -- * Float\/Word conversion , wordToFloat32 -- :: Word -> Float , wordToFloat64 -- :: Word64 -> Double -- * Int and Word explicit conversions , word8ToWord -- :: Word8 -> Word , word16ToWord -- :: Word16 -> Word , word32ToWord -- :: Word32 -> Word , word64ToWord -- :: Word64 -> Word -- int*ToInt conversions are missing because they are not needed. , word8ToInt -- :: Int8 -> Int , word16ToInt -- :: Int16 -> Int , word32ToInt -- :: Int32 -> Int , word64ToInt -- :: Int64 -> Int , intToInt64 -- :: Int -> Int64 #if defined(ARCH_32bit) , word8ToInt64 -- :: Word8 -> Int64 , word16ToInt64 -- :: Word16 -> Int64 , word32ToInt64 -- :: Word32 -> Int64 , word64ToInt64 -- :: Word64 -> Maybe Int64 , word8ToWord64 -- :: Word8 -> Word64 , word16ToWord64 -- :: Word16 -> Word64 , word32ToWord64 -- :: Word32 -> Word64 #endif -- * @'Integer'@ utilities , nintegerFromBytes -- :: ByteString -> Integer , uintegerFromBytes -- :: ByteString -> Integer -- * Simple mutable counters , Counter -- :: * -> * , newCounter -- :: Int -> ST s (Counter s) , readCounter -- :: Counter s -> ST s Int , writeCounter -- :: Counter s -> Int -> ST s () , incCounter -- :: Counter s -> ST s () , decCounter -- :: Counter s -> ST s () -- * Array support , copyByteStringToByteArray , copyByteArrayToByteString ) where import GHC.Exts import GHC.ST (ST(ST)) import GHC.IO (IO(IO), unsafeDupablePerformIO) import GHC.Word import GHC.Int import Foreign.Ptr #if defined(OPTIMIZE_GMP) import qualified GHC.Integer.GMP.Internals as Gmp #endif import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import Data.Primitive.ByteArray as Prim import Foreign.ForeignPtr (withForeignPtr) import Foreign.C (CUShort) import qualified Numeric.Half as Half #if !defined(HAVE_BYTESWAP_PRIMOPS) || !defined(MEM_UNALIGNED_OPS) import Data.Bits ((.|.), unsafeShiftL) #endif #if defined(ARCH_32bit) import GHC.IntWord64 (wordToWord64#, word64ToWord#, intToInt64#, int64ToInt#, leWord64#, ltWord64#, word64ToInt64#) #endif -------------------------------------------------------------------------------- -- | Grab a 8-bit @'Word'@ given a @'Ptr'@ to some address. grabWord8 :: Ptr () -> Word8 {-# INLINE grabWord8 #-} -- | Grab a 16-bit @'Word'@ given a @'Ptr'@ to some address. grabWord16 :: Ptr () -> Word16 {-# INLINE grabWord16 #-} -- | Grab a 32-bit @'Word'@ given a @'Ptr'@ to some address. grabWord32 :: Ptr () -> Word32 {-# INLINE grabWord32 #-} -- | Grab a 64-bit @'Word64'@ given a @'Ptr'@ to some address. grabWord64 :: Ptr () -> Word64 {-# INLINE grabWord64 #-} -- -- Machine-dependent implementation -- -- 8-bit word case is always the same... grabWord8 (Ptr ip#) = W8# (indexWord8OffAddr# ip# 0#) -- ... but the remaining cases arent #if defined(HAVE_BYTESWAP_PRIMOPS) && \ defined(MEM_UNALIGNED_OPS) && \ !defined(WORDS_BIGENDIAN) -- On x86 machines with GHC 7.10, we have byteswap primitives -- available to make this conversion very fast. grabWord16 (Ptr ip#) = W16# (narrow16Word# (byteSwap16# (indexWord16OffAddr# ip# 0#))) grabWord32 (Ptr ip#) = W32# (narrow32Word# (byteSwap32# (indexWord32OffAddr# ip# 0#))) #if defined(ARCH_64bit) grabWord64 (Ptr ip#) = W64# (byteSwap# (indexWord64OffAddr# ip# 0#)) #else grabWord64 (Ptr ip#) = W64# (byteSwap64# (indexWord64OffAddr# ip# 0#)) #endif #elif defined(MEM_UNALIGNED_OPS) && \ defined(WORDS_BIGENDIAN) -- In some theoretical future-verse where there are unaligned memory -- accesses on the machine, but it is also big-endian, we need to be -- able to decode these numbers efficiently, still. grabWord16 (Ptr ip#) = W16# (indexWord16OffAddr# ip# 0#) grabWord32 (Ptr ip#) = W32# (indexWord32OffAddr# ip# 0#) grabWord64 (Ptr ip#) = W64# (indexWord64OffAddr# ip# 0#) #else -- Otherwise, we fall back to the much slower, inefficient case -- of writing out each of the 8 bits of the output word at -- a time. grabWord16 (Ptr ip#) = case indexWord8OffAddr# ip# 0# of w0# -> case indexWord8OffAddr# ip# 1# of w1# -> W16# w0# `unsafeShiftL` 8 .|. W16# w1# grabWord32 (Ptr ip#) = case indexWord8OffAddr# ip# 0# of w0# -> case indexWord8OffAddr# ip# 1# of w1# -> case indexWord8OffAddr# ip# 2# of w2# -> case indexWord8OffAddr# ip# 3# of w3# -> W32# w0# `unsafeShiftL` 24 .|. W32# w1# `unsafeShiftL` 16 .|. W32# w2# `unsafeShiftL` 8 .|. W32# w3# grabWord64 (Ptr ip#) = case indexWord8OffAddr# ip# 0# of w0# -> case indexWord8OffAddr# ip# 1# of w1# -> case indexWord8OffAddr# ip# 2# of w2# -> case indexWord8OffAddr# ip# 3# of w3# -> case indexWord8OffAddr# ip# 4# of w4# -> case indexWord8OffAddr# ip# 5# of w5# -> case indexWord8OffAddr# ip# 6# of w6# -> case indexWord8OffAddr# ip# 7# of w7# -> w w0# `unsafeShiftL` 56 .|. w w1# `unsafeShiftL` 48 .|. w w2# `unsafeShiftL` 40 .|. w w3# `unsafeShiftL` 32 .|. w w4# `unsafeShiftL` 24 .|. w w5# `unsafeShiftL` 16 .|. w w6# `unsafeShiftL` 8 .|. w w7# where #if defined(ARCH_64bit) w w# = W64# w# #else w w# = W64# (wordToWord64# w#) #endif #endif -------------------------------------------------------------------------------- -- ByteString shennanigans -- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the -- resulting byte(s) as an 8-bit word value. The input @'ByteString'@ MUST be at -- least 2 bytes long: one byte to drop from the front, and one to read as a -- @'Word'@ value. This is not checked, and failure to ensure this will result -- in undefined behavior. eatTailWord8 :: ByteString -> Word8 eatTailWord8 xs = withBsPtr grabWord8 (BS.unsafeTail xs) {-# INLINE eatTailWord8 #-} -- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the -- resulting byte(s) as a 16-bit word value. The input @'ByteString'@ MUST be at -- least 3 bytes long: one byte to drop from the front, and two to read as a -- 16-bit @'Word'@ value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord16 :: ByteString -> Word16 eatTailWord16 xs = withBsPtr grabWord16 (BS.unsafeTail xs) {-# INLINE eatTailWord16 #-} -- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the -- resulting byte(s) as a 32-bit word value. The input @'ByteString'@ MUST be at -- least 5 bytes long: one byte to drop from the front, and four to read as a -- 32-bit @'Word'@ value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord32 :: ByteString -> Word32 eatTailWord32 xs = withBsPtr grabWord32 (BS.unsafeTail xs) {-# INLINE eatTailWord32 #-} -- | Take the tail of a @'ByteString'@ (i.e. drop the first byte) and read the -- resulting byte(s) as a 64-bit word value. The input @'ByteString'@ MUST be at -- least 9 bytes long: one byte to drop from the front, and eight to read as a -- 64-bit @'Word64'@ value. This is not checked, and failure to ensure this will -- result in undefined behavior. eatTailWord64 :: ByteString -> Word64 eatTailWord64 xs = withBsPtr grabWord64 (BS.unsafeTail xs) {-# INLINE eatTailWord64 #-} -- | Unsafely take a @'Ptr'@ to a @'ByteString'@ and do unholy things -- with it. withBsPtr :: (Ptr b -> a) -> ByteString -> a withBsPtr f (BS.PS x off _) = unsafeDupablePerformIO $ withForeignPtr x $ \(Ptr addr#) -> return $! (f (Ptr addr# `plusPtr` off)) {-# INLINE withBsPtr #-} -------------------------------------------------------------------------------- -- Half floats -- | Convert a @'Word16'@ to a half-sized @'Float'@. wordToFloat16 :: Word16 -> Float wordToFloat16 = \x -> Half.fromHalf (Half.Half (cast x)) where cast :: Word16 -> CUShort cast = fromIntegral {-# INLINE wordToFloat16 #-} -- | Convert a half-sized @'Float'@ to a @'Word'@. floatToWord16 :: Float -> Word16 floatToWord16 = \x -> cast (Half.getHalf (Half.toHalf x)) where cast :: CUShort -> Word16 cast = fromIntegral {-# INLINE floatToWord16 #-} -------------------------------------------------------------------------------- -- Casting words to floats -- We have to go via a word rather than reading directly from memory because of -- endian issues. A little endian machine cannot read a big-endian float direct -- from memory, so we read a word, bswap it and then convert to float. -- -- Currently there are no primops for casting word <-> float, see -- https://ghc.haskell.org/trac/ghc/ticket/4092 -- -- In this implementation, we're avoiding doing the extra indirection (and -- closure allocation) of the runSTRep stuff, but we have to be very careful -- here, we cannot allow the "constant" newByteArray# 8# realWorld# to be -- floated out and shared and aliased across multiple concurrent calls. So we -- do manual worker/wrapper with the worker not being inlined. -- | Cast a @'Word32'@ to a @'Float'@. wordToFloat32 :: Word32 -> Float wordToFloat32 (W32# w#) = F# (wordToFloat32# w#) {-# INLINE wordToFloat32 #-} -- | Cast a @'Word64'@ to a @'Float'@. wordToFloat64 :: Word64 -> Double wordToFloat64 (W64# w#) = D# (wordToFloat64# w#) {-# INLINE wordToFloat64 #-} -- | Cast an unboxed word to an unboxed float. wordToFloat32# :: Word# -> Float# wordToFloat32# w# = case newByteArray# 4# realWorld# of (# s', mba# #) -> case writeWord32Array# mba# 0# w# s' of s'' -> case readFloatArray# mba# 0# s'' of (# _, f# #) -> f# {-# NOINLINE wordToFloat32# #-} -- | Cast an unboxed word to an unboxed double. #if defined(ARCH_64bit) wordToFloat64# :: Word# -> Double# #else wordToFloat64# :: Word64# -> Double# #endif wordToFloat64# w# = case newByteArray# 8# realWorld# of (# s', mba# #) -> case writeWord64Array# mba# 0# w# s' of s'' -> case readDoubleArray# mba# 0# s'' of (# _, f# #) -> f# {-# NOINLINE wordToFloat64# #-} -------------------------------------------------------------------------------- -- Casting words and ints word8ToWord :: Word8 -> Word word16ToWord :: Word16 -> Word word32ToWord :: Word32 -> Word #if defined(ARCH_64bit) word64ToWord :: Word64 -> Word #else word64ToWord :: Word64 -> Maybe Word #endif word8ToInt :: Word8 -> Int word16ToInt :: Word16 -> Int #if defined(ARCH_64bit) word32ToInt :: Word32 -> Int #else word32ToInt :: Word32 -> Maybe Int #endif word64ToInt :: Word64 -> Maybe Int #if defined(ARCH_32bit) word8ToInt64 :: Word8 -> Int64 word16ToInt64 :: Word16 -> Int64 word32ToInt64 :: Word32 -> Int64 word64ToInt64 :: Word64 -> Maybe Int64 word8ToWord64 :: Word8 -> Word64 word16ToWord64 :: Word16 -> Word64 word32ToWord64 :: Word32 -> Word64 #endif intToInt64 :: Int -> Int64 intToInt64 = fromIntegral {-# INLINE intToInt64 #-} word8ToWord (W8# w#) = W# w# word16ToWord (W16# w#) = W# w# word32ToWord (W32# w#) = W# w# #if defined(ARCH_64bit) word64ToWord (W64# w#) = W# w# #else word64ToWord (W64# w64#) = case isTrue# (w64# `leWord64#` wordToWord64# 0xffffffff##) of True -> Just (W# (word64ToWord# w64#)) False -> Nothing #endif {-# INLINE word8ToWord #-} {-# INLINE word16ToWord #-} {-# INLINE word32ToWord #-} {-# INLINE word64ToWord #-} word8ToInt (W8# w#) = I# (word2Int# w#) word16ToInt (W16# w#) = I# (word2Int# w#) #if defined(ARCH_64bit) word32ToInt (W32# w#) = I# (word2Int# w#) #else word32ToInt (W32# w#) = case isTrue# (w# `ltWord#` 0x80000000##) of True -> Just (I# (word2Int# w#)) False -> Nothing #endif #if defined(ARCH_64bit) word64ToInt (W64# w#) = case isTrue# (w# `ltWord#` 0x8000000000000000##) of True -> Just (I# (word2Int# w#)) False -> Nothing #else word64ToInt (W64# w#) = case isTrue# (w# `ltWord64#` wordToWord64# 0x80000000##) of True -> Just (I# (int64ToInt# (word64ToInt64# w#))) False -> Nothing #endif {-# INLINE word8ToInt #-} {-# INLINE word16ToInt #-} {-# INLINE word32ToInt #-} {-# INLINE word64ToInt #-} #if defined(ARCH_32bit) word8ToInt64 (W8# w#) = I64# (intToInt64# (word2Int# w#)) word16ToInt64 (W16# w#) = I64# (intToInt64# (word2Int# w#)) word32ToInt64 (W32# w#) = I64# (word64ToInt64# (wordToWord64# w#)) word64ToInt64 (W64# w#) = case isTrue# (w# `ltWord64#` uncheckedShiftL64# (wordToWord64# 1##) 63#) of True -> Just (I64# (word64ToInt64# w#)) False -> Nothing word8ToWord64 (W8# w#) = W64# (wordToWord64# w#) word16ToWord64 (W16# w#) = W64# (wordToWord64# w#) word32ToWord64 (W32# w#) = W64# (wordToWord64# w#) {-# INLINE word8ToInt64 #-} {-# INLINE word16ToInt64 #-} {-# INLINE word32ToInt64 #-} {-# INLINE word64ToInt64 #-} {-# INLINE word8ToWord64 #-} {-# INLINE word16ToWord64 #-} {-# INLINE word32ToWord64 #-} #endif -------------------------------------------------------------------------------- -- Integer utilities -- | Create a negative @'Integer'@ out of a raw @'BS.ByteString'@. nintegerFromBytes :: BS.ByteString -> Integer nintegerFromBytes bs = -1 - uintegerFromBytes bs -- | Create an @'Integer'@ out of a raw @'BS.ByteString'@. uintegerFromBytes :: BS.ByteString -> Integer #if defined(OPTIMIZE_GMP) uintegerFromBytes (BS.PS fp (I# off#) (I# len#)) = -- This should be safe since we're simply reading from ByteString (which is -- immutable) and GMP allocates a new memory for the Integer, i.e., there is -- no mutation involved. unsafeDupablePerformIO $ withForeignPtr fp $ \(Ptr addr#) -> let addrOff# = addr# `plusAddr#` off# -- The last parmaeter (`1#`) tells the import function to use big -- endian encoding. in Gmp.importIntegerFromAddr addrOff# (int2Word# len#) 1# #else uintegerFromBytes bs = case BS.uncons bs of Nothing -> 0 Just (w0, ws0) -> go (fromIntegral w0) ws0 where go !acc ws = case BS.uncons ws of Nothing -> acc Just (w, ws') -> go (acc `unsafeShiftL` 8 + fromIntegral w) ws' #endif -------------------------------------------------------------------------------- -- Mutable counters -- | An efficient, mutable counter. Designed to be used inside -- @'ST'@ or other primitive monads, hence it carries an abstract -- rank-2 @s@ type parameter. data Counter s = Counter (MutableByteArray# s) -- | Create a new counter with a starting @'Int'@ value. newCounter :: Int -> ST s (Counter s) newCounter (I# n#) = ST (\s -> case newByteArray# 8# s of (# s', mba# #) -> case writeIntArray# mba# 0# n# s' of s'' -> (# s'', Counter mba# #)) {-# INLINE newCounter #-} -- | Read the current value of a @'Counter'@. readCounter :: Counter s -> ST s Int readCounter (Counter mba#) = ST (\s -> case readIntArray# mba# 0# s of (# s', n# #) -> (# s', I# n# #)) {-# INLINE readCounter #-} -- | Write a new value into the @'Counter'@. writeCounter :: Counter s -> Int -> ST s () writeCounter (Counter mba#) (I# n#) = ST (\s -> case writeIntArray# mba# 0# n# s of s' -> (# s', () #)) {-# INLINE writeCounter #-} -- | Increment a @'Counter'@ by one. incCounter :: Counter s -> ST s () incCounter c = do x <- readCounter c writeCounter c (x+1) {-# INLINE incCounter #-} -- | Decrement a @'Counter'@ by one. decCounter :: Counter s -> ST s () decCounter c = do x <- readCounter c writeCounter c (x-1) {-# INLINE decCounter #-} -------------------------------------------------------------------------------- -- Array support -- | Copy a @'BS.ByteString'@ and create a primitive @'Prim.ByteArray'@ from it. copyByteStringToByteArray :: BS.ByteString -> Prim.ByteArray copyByteStringToByteArray (BS.PS fp off len) = unsafeDupablePerformIO $ withForeignPtr fp $ \ptr -> do mba <- Prim.newByteArray len copyPtrToMutableByteArray (ptr `plusPtr` off) mba 0 len Prim.unsafeFreezeByteArray mba -- TODO FIXME: can do better here: can do non-copying for larger pinned arrays -- or copy directly into the builder buffer -- | Copy a @'Prim.ByteArray'@ at a certain offset and length into a -- @'BS.ByteString'@. copyByteArrayToByteString :: Prim.ByteArray -- ^ @'Prim.ByteArray'@ to copy from. -> Int -- ^ Offset into the @'Prim.ByteArray'@ to start with. -> Int -- ^ Length of the data to copy. -> BS.ByteString copyByteArrayToByteString ba off len = unsafeDupablePerformIO $ do fp <- BS.mallocByteString len withForeignPtr fp $ \ptr -> do copyByteArrayToPtr ba off ptr len return (BS.PS fp 0 len) -- | Copy the data pointed to by a @'Ptr'@ into a @'MutableByteArray'. copyPtrToMutableByteArray :: Ptr a -- ^ @'Ptr'@ to buffer to copy from. -> MutableByteArray RealWorld -- ^ @'MutableByteArray'@ to copy into. -> Int -- ^ Offset to start copying from. -> Int -- ^ Length of the data to copy. -> IO () copyPtrToMutableByteArray (Ptr addr#) (MutableByteArray mba#) (I# off#) (I# len#) = IO (\s -> case copyAddrToByteArray# addr# mba# off# len# s of s' -> (# s', () #)) -- | Copy a @'ByteArray'@ into a @'Ptr'@ with a given offset and length. copyByteArrayToPtr :: ByteArray -- ^ @'ByteArray'@ to copy. -> Int -- ^ Offset into the @'ByteArray'@ of where to start copying. -> Ptr a -- ^ Pointer to destination buffer. -> Int -- ^ Length of the data to copy into the destination buffer. -> IO () copyByteArrayToPtr (ByteArray ba#) (I# off#) (Ptr addr#) (I# len#) = IO (\s -> case copyByteArrayToAddr# ba# off# addr# len# s of s' -> (# s', () #)) cborg-0.2.1.0/src/Codec/CBOR/ByteArray.hs0000644000000000000000000000522613357736054015743 0ustar0000000000000000{-# 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 cborg-0.2.1.0/src/Codec/CBOR/Pretty.hs0000644000000000000000000002260113357736054015324 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UnboxedTuples #-} -- | -- Module : Codec.CBOR.Pretty -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- Pretty printing tools for debugging and analysis. -- module Codec.CBOR.Pretty ( prettyHexEnc -- :: Encoding -> String ) where #include "cbor.h" import Data.Word import qualified Data.ByteString as S import qualified Data.Text as T import Codec.CBOR.Encoding import Codec.CBOR.Write import qualified Control.Monad.Fail as Fail import Control.Monad (replicateM_) import Numeric #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif -------------------------------------------------------------------------------- newtype PP a = PP (Tokens -> Int -> ShowS -> Either String (Tokens,Int,ShowS,a)) -- | Pretty prints an @'Encoding'@ in an annotated, hexadecimal format -- that maps CBOR values to their types. The output format is similar -- to the format used on http://cbor.me/. -- -- For example, with the term: -- -- @ -- 'Prelude.putStrLn' . 'prettyHexEnc' . 'Codec.CBOR.encode' $ -- ( True -- , [1,2,3::Int] -- , ('Data.Map.fromList' [(\"Hello\",True),(\"World\",False)], "This is a long string which wraps") -- ) -- @ -- -- You get: -- -- @ -- 83 # list(3) -- f5 # bool(true) -- 9f # list(*) -- 01 # int(1) -- 02 # int(2) -- 03 # int(3) -- ff # break -- 82 # list(2) -- a2 # map(2) -- 65 48 65 6c 6c 6f # text(\"Hello\") -- f5 # bool(true) -- 65 57 6f 72 6c 64 # text(\"World\") -- f4 # bool(false) -- 78 21 54 68 69 73 20 69 73 20 61 20 6c 6f 6e 67 -- 20 73 74 72 69 6e 67 20 77 68 69 63 68 20 77 72 -- 61 70 73 # text("This is a long string which wraps") -- @ -- -- @since 0.2.0.0 prettyHexEnc :: Encoding -> String prettyHexEnc e = case runPP pprint e of Left s -> s Right (TkEnd,_,ss,_) -> ss "" Right (toks,_,ss,_) -> ss $ "\nprettyEnc: Not all input was consumed (this is probably a problem with the pretty printing code). Tokens left: " ++ show toks runPP :: PP a -> Encoding -> Either String (Tokens, Int, ShowS, a) runPP (PP f) (Encoding enc) = f (enc TkEnd) 0 id deriving instance Functor PP instance Applicative PP where pure a = PP (\toks ind ss -> Right (toks, ind, ss, a)) (PP f) <*> (PP x) = PP $ \toks ind ss -> case f toks ind ss of Left s -> Left s Right (toks', ind',ss',f') -> case x toks' ind' ss' of Left s -> Left s Right (toks'', ind'', ss'', x') -> Right (toks'', ind'', ss'', f' x') instance Monad PP where (PP f) >>= g = PP $ \toks ind ss -> case f toks ind ss of Left s -> Left s Right (toks', ind', ss', x) -> let PP g' = g x in g' toks' ind' ss' return = pure fail = Fail.fail instance Fail.MonadFail PP where fail s = PP $ \_ _ _ -> Left s indent :: PP () indent = PP (\toks ind ss -> Right (toks,ind,ss . (replicate ind ' ' ++),())) nl :: PP () nl = PP (\toks ind ss -> Right (toks,ind,ss . ('\n':), ())) inc :: Int -> PP () inc i = PP (\toks ind ss -> Right (toks,ind+i,ss,())) dec :: Int -> PP () dec i = inc (-i) getTerm :: PP Tokens getTerm = PP $ \toks ind ss -> case unconsToken toks of Just (tk,rest) -> Right (rest,ind,ss,tk) Nothing -> Left "getTok: Unexpected end of input" peekTerm :: PP Tokens peekTerm = PP $ \toks ind ss -> case unconsToken toks of Just (tk,_) -> Right (toks,ind,ss,tk) Nothing -> Left "peekTerm: Unexpected end of input" appShowS :: ShowS -> PP () appShowS s = PP $ \toks ind ss -> Right (toks,ind,ss . s,()) str :: String -> PP () str = appShowS . showString shown :: Show a => a -> PP () shown = appShowS . shows parens :: PP a -> PP a parens pp = str "(" *> pp <* str ")" indef :: PP () -> PP () indef pp = do tk <- peekTerm case tk of TkBreak TkEnd -> dec 3 >> pprint _ -> pp >> indef pp pprint :: PP () pprint = do nl term <- getTerm hexRep term str " " case term of TkInt i TkEnd -> ppTkInt i TkInteger i TkEnd -> ppTkInteger i TkWord w TkEnd -> ppTkWord w TkBytes bs TkEnd -> ppTkBytes bs TkBytesBegin TkEnd -> ppTkBytesBegin TkString t TkEnd -> ppTkString t TkStringBegin TkEnd -> ppTkStringBegin TkListLen w TkEnd -> ppTkListLen w TkListBegin TkEnd -> ppTkListBegin TkMapLen w TkEnd -> ppTkMapLen w TkMapBegin TkEnd -> ppTkMapBegin TkBreak TkEnd -> ppTkBreak TkTag w TkEnd -> ppTkTag w TkBool b TkEnd -> ppTkBool b TkNull TkEnd -> ppTkNull TkSimple w TkEnd -> ppTkSimple w TkFloat16 f TkEnd -> ppTkFloat16 f TkFloat32 f TkEnd -> ppTkFloat32 f TkFloat64 f TkEnd -> ppTkFloat64 f TkEnd -> str "# End of input" _ -> fail $ unwords ["pprint: Unexpected token:", show term] ppTkInt :: Int -> PP () ppTkInt i = str "# int" >> parens (shown i) ppTkInteger :: Integer -> PP () ppTkInteger i = str "# integer" >> parens (shown i) ppTkWord :: Word -> PP () ppTkWord w = str "# word" >> parens (shown w) ppTkBytes :: S.ByteString -> PP () ppTkBytes bs = str "# bytes" >> parens (shown (S.length bs)) ppTkBytesBegin :: PP () ppTkBytesBegin = str "# bytes(*)" >> inc 3 >> indef pprint ppTkString :: T.Text -> PP () ppTkString t = str "# text" >> parens (shown t) ppTkStringBegin:: PP () ppTkStringBegin = str "# text(*)" >> inc 3 >> indef pprint ppTkListLen :: Word -> PP () ppTkListLen n = do str "# list" parens (shown n) inc 3 replicateM_ (fromIntegral n) pprint dec 3 ppTkListBegin :: PP () ppTkListBegin = str "# list(*)" >> inc 3 >> indef pprint ppMapPairs :: PP () ppMapPairs = do nl inc 3 indent str " # key" pprint dec 3 -- str " [end map key]" nl inc 3 indent str " # value" pprint dec 3 -- str " [end map value]" ppTkMapLen :: Word -> PP () ppTkMapLen w = do str "# map" parens (shown w) -- inc 3 replicateM_ (fromIntegral w) ppMapPairs -- dec 3 ppTkMapBegin :: PP () ppTkMapBegin = str "# map(*)" >> inc 3 >> indef ppMapPairs ppTkBreak :: PP () ppTkBreak = str "# break" ppTkTag :: Word -> PP () ppTkTag w = do str "# tag" parens (shown w) inc 3 pprint dec 3 ppTkBool :: Bool -> PP () ppTkBool True = str "# bool" >> parens (str "true") ppTkBool False = str "# bool" >> parens (str "false") ppTkNull :: PP () ppTkNull = str "# null" ppTkSimple :: Word8 -> PP () ppTkSimple w = str "# simple" >> parens (shown w) ppTkFloat16 :: Float -> PP () ppTkFloat16 f = str "# float16" >> parens (shown f) ppTkFloat32 :: Float -> PP () ppTkFloat32 f = str "# float32" >> parens (shown f) ppTkFloat64 :: Double -> PP () ppTkFloat64 f = str "# float64" >> parens (shown f) unconsToken :: Tokens -> Maybe (Tokens, Tokens) unconsToken TkEnd = Nothing unconsToken (TkWord w tks) = Just (TkWord w TkEnd,tks) unconsToken (TkWord64 w tks) = Just (TkWord64 w TkEnd,tks) unconsToken (TkInt i tks) = Just (TkInt i TkEnd,tks) 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) unconsToken (TkMapBegin tks) = Just (TkMapBegin TkEnd,tks) unconsToken (TkTag w tks) = Just (TkTag w TkEnd,tks) unconsToken (TkTag64 w64 tks) = Just (TkTag64 w64 TkEnd,tks) unconsToken (TkInteger i tks) = Just (TkInteger i TkEnd,tks) unconsToken (TkNull tks) = Just (TkNull TkEnd,tks) unconsToken (TkUndef tks) = Just (TkUndef TkEnd,tks) unconsToken (TkBool b tks) = Just (TkBool b TkEnd,tks) unconsToken (TkSimple w8 tks) = Just (TkSimple w8 TkEnd,tks) unconsToken (TkFloat16 f16 tks) = Just (TkFloat16 f16 TkEnd,tks) unconsToken (TkFloat32 f32 tks) = Just (TkFloat32 f32 TkEnd,tks) unconsToken (TkFloat64 f64 tks) = Just (TkFloat64 f64 TkEnd,tks) unconsToken (TkBreak tks) = Just (TkBreak TkEnd,tks) hexRep :: Tokens -> PP () hexRep tk = go . toStrictByteString . Encoding $ const tk where go bs | S.length bs > 16 = case S.splitAt 16 bs of (h,t) -> indent >> appShowS (hexBS h) >> nl >> go t | otherwise = indent >> appShowS (hexBS bs) hexBS :: S.ByteString -> ShowS hexBS = foldr (.) id . map (\n -> ((if n < 16 then ('0':) else id) . showHex n . (' ':))) . S.unpack cborg-0.2.1.0/src/Codec/CBOR/ByteArray/0000755000000000000000000000000013357736054015402 5ustar0000000000000000cborg-0.2.1.0/src/Codec/CBOR/ByteArray/Sliced.hs0000644000000000000000000001144613357736054017147 0ustar0000000000000000{-# 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 cborg-0.2.1.0/src/Codec/CBOR/ByteArray/Internal.hs0000644000000000000000000000444413357736054017520 0ustar0000000000000000{-# 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', () #)) 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', () #) cborg-0.2.1.0/src/cbits/0000755000000000000000000000000013357736054013042 5ustar0000000000000000cborg-0.2.1.0/src/cbits/cbor.h0000644000000000000000000000225513357736054014144 0ustar0000000000000000/* Needed GHC definitions */ #include "MachDeps.h" /* ** GHC 7.10 and above include efficient byte-swapping primitives, ** which are useful for efficient byte-mangling routines. */ #if __GLASGOW_HASKELL__ >= 710 #define HAVE_BYTESWAP_PRIMOPS #endif /* ** On Intel 32/64 bit machines, memory access to unaligned addresses ** is permitted (and generally efficient, too). With this in mind, ** some operations can be implemented more efficiently. */ #if i386_HOST_ARCH || x86_64_HOST_ARCH #define MEM_UNALIGNED_OPS #endif /* ** Determine whether or not we can use more efficient code paths for ** integer-gmp. */ #if !defined(MIN_VERSION_integer_gmp) /* ** In case this isn't defined, then just bail. If someone isn't using ** integer-gmp, then it won't be in the dependency list, so this macro ** might not(?) be generated by Cabal. */ #define MIN_VERSION_integer_gmp(x,y,z) 0 #endif #if defined(FLAG_OPTIMIZE_GMP) && MIN_VERSION_integer_gmp(1,0,0) #define OPTIMIZE_GMP #endif /* ** Establish the word-size of the machine, or fail. */ #if WORD_SIZE_IN_BITS == 64 #define ARCH_64bit #elif WORD_SIZE_IN_BITS == 32 #define ARCH_32bit #else #error expected WORD_SIZE_IN_BITS to be 32 or 64 #endif cborg-0.2.1.0/tests/0000755000000000000000000000000013357736054012311 5ustar0000000000000000cborg-0.2.1.0/tests/Main.hs0000644000000000000000000000103513357736054013530 0ustar0000000000000000module Main ( main -- :: IO () ) where import Test.Tasty (defaultMain, testGroup) import qualified Tests.CBOR as CBOR import qualified Tests.Boundary as Boundary import qualified Tests.Regress as Regress import qualified Tests.Reference as Reference import qualified Tests.UTF8 as UTF8 main :: IO () main = Reference.loadTestCases >>= \tcs -> defaultMain $ testGroup "CBOR tests" [ CBOR.testTree tcs , Reference.testTree tcs , Boundary.testTree , Regress.testTree , UTF8.testTree ] cborg-0.2.1.0/tests/Tests/0000755000000000000000000000000013357736054013413 5ustar0000000000000000cborg-0.2.1.0/tests/Tests/Util.hs0000644000000000000000000000524713357736054014674 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Tests.Util ( splits2 , splits3 , arbitraryWithBounds , Length(..) , mkLengthPrefix ) where import Data.Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Word import Test.Tasty.QuickCheck #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif -- | Generate all 2-splits of a serialised CBOR value. splits2 :: BSL.ByteString -> [BSL.ByteString] splits2 bs = zipWith (\a b -> BSL.fromChunks [a,b]) (BS.inits sbs) (BS.tails sbs) where sbs = BSL.toStrict bs -- | Generate all 3-splits of a serialised CBOR value. splits3 :: BSL.ByteString -> [BSL.ByteString] splits3 bs = [ BSL.fromChunks [a,b,c] | (a,x) <- zip (BS.inits sbs) (BS.tails sbs) , (b,c) <- zip (BS.inits x) (BS.tails x) ] where sbs = BSL.toStrict bs ---------------------------------------- -- | Generate values of type 'a' embedded within (usually larger) type 'r' with -- upped probabilities of getting neighbourhood of bounds of 'a'. arbitraryWithBounds :: forall a r. (Bounded a, Integral a, Num r, Arbitrary r) => a -> Gen r arbitraryWithBounds _ = frequency [ (70, arbitrary) -- Boundaries , (5, pure $ fromIntegral (minBound :: a)) , (5, pure $ fromIntegral (maxBound :: a)) -- Near boundaries, in range , (5, pure $ fromIntegral (minBound + 1 :: a)) , (5, pure $ fromIntegral (maxBound - 1 :: a)) -- Near boundaries, out of range (assuming there is no overflow). It overflows -- if a ~ r, but it's fine as then we just get a value within range. , (5, pure $ fromIntegral (minBound :: a) - 1) , (5, pure $ fromIntegral (maxBound :: a) + 1) ] ---------------------------------------- -- | Wrapper for list/map length. newtype Length = Length { unLength :: Word } instance Show Length where showsPrec p = showsPrec p . unLength instance Arbitrary Length where arbitrary = Length <$> arbitraryWithBounds (undefined::Int) -- | Generate CBOR prefix of non-empty string/bytes containing its length. mkLengthPrefix :: Bool -> Length -> BSL.ByteString mkLengthPrefix string (Length w) | w <= 23 = BSL.pack $ [64 + stringBit + fromIntegral w] | w <= 0xff = BSL.pack $ [88 + stringBit] ++ f 1 w [] | w <= 0xffff = BSL.pack $ [89 + stringBit] ++ f 2 w [] | w <= 0xffffffff = BSL.pack $ [90 + stringBit] ++ f 4 w [] | otherwise = BSL.pack $ [91 + stringBit] ++ f 8 w [] where stringBit :: Word8 stringBit = if string then 32 else 0 f :: Int -> Word -> [Word8] -> [Word8] f 0 _ acc = acc f k n acc = f (k - 1) (n `shiftR` 8) (fromIntegral n : acc) cborg-0.2.1.0/tests/Tests/UTF8.hs0000644000000000000000000000324313357736054014477 0ustar0000000000000000{-# LANGUAGE CPP #-} module Tests.UTF8 ( testTree -- :: TestTree ) where import Control.DeepSeq import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL #if ! MIN_VERSION_base(4,11,0) import Data.Monoid #endif import qualified Data.Text.Encoding as T import Codec.CBOR.Decoding import Codec.CBOR.Read import Tests.Util import Test.Tasty import Test.Tasty.QuickCheck #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif -- | Wrapper for ByteString with Arbitrary instance that might produce a valid -- UTF-8 encoding of a string. newtype MaybeText = MaybeText BS.ByteString deriving Show instance Arbitrary MaybeText where arbitrary = MaybeText . BS.pack <$> arbitrary -- | Test that decoding of both valid and invalid CBOR strings produces output -- without exceptions hidden within. utf8DecodingTest :: MaybeText -> Property utf8DecodingTest (MaybeText bs) = case T.decodeUtf8' bs of Right _ -> collect "valid utf8" $ (and splitsOk) Left _ -> collect "invalid utf8" $ not (or splitsOk) where -- We test 2-splits to check all decoder paths. splitsOk = [ok $ deserialiseFromBytes decodeString v | v <- splits2 s] where ok (Right v) = deepseq v True ok (Left v) = deepseq v False s = mkLengthPrefix True (Length . fromIntegral $ BS.length bs) <> BSL.fromStrict bs ---------------------------------------- testTree :: TestTree testTree = localOption (QuickCheckTests 1000) . testGroup "UTF8" $ [testProperty "Decoding of UTF8 encoded Text works and properly handles decoding failures" utf8DecodingTest ] cborg-0.2.1.0/tests/Tests/Regress.hs0000644000000000000000000000074313357736054015365 0ustar0000000000000000module Tests.Regress ( testTree -- :: TestTree ) where import Test.Tasty import qualified Tests.Regress.Issue160 as Issue160 import qualified Tests.Regress.Issue162 as Issue162 import qualified Tests.Regress.FlatTerm as FlatTerm -------------------------------------------------------------------------------- -- Tests and properties testTree :: TestTree testTree = testGroup "Regression tests" [ FlatTerm.testTree , Issue160.testTree , Issue162.testTree ] cborg-0.2.1.0/tests/Tests/CBOR.hs0000644000000000000000000002776413357736054014514 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Tests.CBOR ( testTree -- :: TestTree ) where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Word import qualified Numeric.Half as Half import Codec.CBOR.Term import Codec.CBOR.Read import Codec.CBOR.Write import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import qualified Tests.Reference.Implementation as RefImpl import qualified Tests.Reference as TestVector import Tests.Reference (TestCase(..)) import Tests.Util #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Exception (throw) externalTestCase :: TestCase -> Assertion externalTestCase TestCase { encoded, decoded = Left expectedJson } = do let term = deserialise encoded actualJson = TestVector.termToJson (toRefTerm term) reencoded = serialise term expectedJson `TestVector.equalJson` actualJson encoded @=? reencoded externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do let term = deserialise encoded actualDiagnostic = RefImpl.diagnosticNotation (toRefTerm term) reencoded = serialise term expectedDiagnostic @=? actualDiagnostic encoded @=? reencoded expectedDiagnosticNotation :: String -> [Word8] -> Assertion expectedDiagnosticNotation expectedDiagnostic encoded = do let term = deserialise (LBS.pack encoded) actualDiagnostic = RefImpl.diagnosticNotation (toRefTerm term) expectedDiagnostic @=? actualDiagnostic -- | The reference implementation satisfies the roundtrip property for most -- examples (all the ones from Appendix A). It does not satisfy the roundtrip -- property in general however, non-canonical over-long int encodings for -- example. -- -- encodedRoundtrip :: String -> [Word8] -> Assertion encodedRoundtrip expectedDiagnostic encoded = do let term = deserialise (LBS.pack encoded) reencoded = LBS.unpack (serialise term) assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded prop_encodeDecodeTermRoundtrip :: Term -> Bool prop_encodeDecodeTermRoundtrip term = (deserialise . serialise) term `eqTerm` term prop_encodeDecodeTermRoundtrip_splits2 :: Term -> Bool prop_encodeDecodeTermRoundtrip_splits2 term = and [ deserialise thedata' `eqTerm` term | let thedata = serialise term , thedata' <- splits2 thedata ] prop_encodeDecodeTermRoundtrip_splits3 :: Term -> Bool prop_encodeDecodeTermRoundtrip_splits3 term = and [ deserialise thedata' `eqTerm` term | let thedata = serialise term , thedata' <- splits3 thedata ] prop_encodeTermMatchesRefImpl :: RefImpl.Term -> Bool prop_encodeTermMatchesRefImpl term = let encoded = serialise (fromRefTerm term) encoded' = RefImpl.serialise (RefImpl.canonicaliseTerm term) in encoded == encoded' prop_encodeTermMatchesRefImpl2 :: Term -> Bool prop_encodeTermMatchesRefImpl2 term = let encoded = serialise term encoded' = RefImpl.serialise (toRefTerm term) in encoded == encoded' prop_decodeTermMatchesRefImpl :: RefImpl.Term -> Bool prop_decodeTermMatchesRefImpl term0 = let encoded = RefImpl.serialise (RefImpl.canonicaliseTerm term0) term = RefImpl.deserialise encoded term' = deserialise encoded in term' `eqTerm` fromRefTerm term ------------------------------------------------------------------------------ serialise :: Term -> LBS.ByteString serialise = toLazyByteString . encodeTerm deserialise :: LBS.ByteString -> Term deserialise = either throw snd . deserialiseFromBytes decodeTerm ------------------------------------------------------------------------------ toRefTerm :: Term -> RefImpl.Term toRefTerm (TInt n) | n >= 0 = RefImpl.TUInt (RefImpl.toUInt (fromIntegral n)) | otherwise = RefImpl.TNInt (RefImpl.toUInt (fromIntegral (-1 - n))) toRefTerm (TInteger n) -- = RefImpl.TBigInt n | n >= 0 && n <= fromIntegral (maxBound :: Word64) = RefImpl.TUInt (RefImpl.toUInt (fromIntegral n)) | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64) = RefImpl.TNInt (RefImpl.toUInt (fromIntegral (-1 - n))) | otherwise = RefImpl.TBigInt n toRefTerm (TBytes bs) = RefImpl.TBytes (BS.unpack bs) toRefTerm (TBytesI bs) = RefImpl.TBytess (map BS.unpack (LBS.toChunks bs)) toRefTerm (TString st) = RefImpl.TString (T.unpack st) toRefTerm (TStringI st) = RefImpl.TStrings (map T.unpack (LT.toChunks st)) toRefTerm (TList ts) = RefImpl.TArray (map toRefTerm ts) toRefTerm (TListI ts) = RefImpl.TArrayI (map toRefTerm ts) toRefTerm (TMap ts) = RefImpl.TMap [ (toRefTerm x, toRefTerm y) | (x,y) <- ts ] toRefTerm (TMapI ts) = RefImpl.TMapI [ (toRefTerm x, toRefTerm y) | (x,y) <- ts ] toRefTerm (TTagged w t) = RefImpl.TTagged (RefImpl.toUInt (fromIntegral w)) (toRefTerm t) toRefTerm (TBool False) = RefImpl.TFalse toRefTerm (TBool True) = RefImpl.TTrue toRefTerm TNull = RefImpl.TNull toRefTerm (TSimple 23) = RefImpl.TUndef toRefTerm (TSimple w) = RefImpl.TSimple (fromIntegral w) 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 fromRefTerm (RefImpl.TUInt u) | n <= fromIntegral (maxBound :: Int) = TInt (fromIntegral n) | otherwise = TInteger (fromIntegral n) where n = RefImpl.fromUInt u fromRefTerm (RefImpl.TNInt u) | n <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral n) | otherwise = TInteger (-1 - fromIntegral n) where n = RefImpl.fromUInt u fromRefTerm (RefImpl.TBigInt n) = TInteger n fromRefTerm (RefImpl.TBytes bs) = TBytes (BS.pack bs) fromRefTerm (RefImpl.TBytess bs) = TBytesI (LBS.fromChunks (map BS.pack bs)) fromRefTerm (RefImpl.TString st) = TString (T.pack st) fromRefTerm (RefImpl.TStrings st) = TStringI (LT.fromChunks (map T.pack st)) fromRefTerm (RefImpl.TArray ts) = TList (map fromRefTerm ts) fromRefTerm (RefImpl.TArrayI ts) = TListI (map fromRefTerm ts) fromRefTerm (RefImpl.TMap ts) = TMap [ (fromRefTerm x, fromRefTerm y) | (x,y) <- ts ] fromRefTerm (RefImpl.TMapI ts) = TMapI [ (fromRefTerm x, fromRefTerm y) | (x,y) <- ts ] fromRefTerm (RefImpl.TTagged w t) = TTagged (RefImpl.fromUInt w) (fromRefTerm t) fromRefTerm (RefImpl.TFalse) = TBool False fromRefTerm (RefImpl.TTrue) = TBool True fromRefTerm RefImpl.TNull = TNull fromRefTerm RefImpl.TUndef = TSimple 23 fromRefTerm (RefImpl.TSimple w) = TSimple w fromRefTerm (RefImpl.TFloat16 f) = THalf (Half.fromHalf 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 eqTerm (TInt n) (TInteger n') = fromIntegral n == n' eqTerm (TList ts) (TList ts') = and (zipWith eqTerm ts ts') eqTerm (TListI ts) (TListI ts') = and (zipWith eqTerm ts ts') eqTerm (TMap ts) (TMap ts') = and (zipWith eqTermPair ts ts') eqTerm (TMapI ts) (TMapI ts') = and (zipWith eqTermPair ts ts') eqTerm (TTagged w t) (TTagged w' t') = w == w' && eqTerm t t' eqTerm (THalf f) (THalf f') | isNaN f && isNaN f' = True eqTerm (TFloat f) (TFloat f') | isNaN f && isNaN f' = True eqTerm (TDouble f) (TDouble f') | isNaN f && isNaN f' = True eqTerm a b = a == b eqTermPair :: (Term, Term) -> (Term, Term) -> Bool eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b' prop_fromToRefTerm :: RefImpl.Term -> Bool prop_fromToRefTerm term = toRefTerm (fromRefTerm term) `RefImpl.eqTerm` RefImpl.canonicaliseTerm term prop_toFromRefTerm :: Term -> Bool prop_toFromRefTerm term = fromRefTerm (toRefTerm term) `eqTerm` term instance Arbitrary Term where arbitrary = fromRefTerm <$> arbitrary shrink (TInt n) = [ TInt n' | n' <- shrink n ] shrink (TInteger n) = [ TInteger n' | n' <- shrink n ] shrink (TBytes ws) = [ TBytes (BS.pack ws') | ws' <- shrink (BS.unpack ws) ] shrink (TBytesI wss) = [ TBytesI (LBS.fromChunks (map BS.pack wss')) | wss' <- shrink (map BS.unpack (LBS.toChunks wss)) ] shrink (TString cs) = [ TString (T.pack cs') | cs' <- shrink (T.unpack cs) ] shrink (TStringI css) = [ TStringI (LT.fromChunks (map T.pack css')) | css' <- shrink (map T.unpack (LT.toChunks css)) ] shrink (TList xs@[x]) = x : [ TList xs' | xs' <- shrink xs ] shrink (TList xs) = [ TList xs' | xs' <- shrink xs ] shrink (TListI xs@[x]) = x : [ TListI xs' | xs' <- shrink xs ] shrink (TListI xs) = [ TListI xs' | xs' <- shrink xs ] shrink (TMap xys@[(x,y)]) = x : y : [ TMap xys' | xys' <- shrink xys ] shrink (TMap xys) = [ TMap xys' | xys' <- shrink xys ] shrink (TMapI xys@[(x,y)]) = x : y : [ TMapI xys' | xys' <- shrink xys ] shrink (TMapI xys) = [ TMapI xys' | xys' <- shrink xys ] shrink (TTagged w t) = [ TTagged w' t' | (w', t') <- shrink (w, t) , not (RefImpl.reservedTag (fromIntegral w')) ] shrink (TBool _) = [] shrink TNull = [] shrink (TSimple w) = [ TSimple w' | w' <- shrink w , not (RefImpl.reservedSimple (fromIntegral w)) ] shrink (THalf _f) = [] shrink (TFloat f) = [ TFloat f' | f' <- shrink f ] shrink (TDouble f) = [ TDouble f' | f' <- shrink f ] -------------------------------------------------------------------------------- -- TestTree API testTree :: [TestCase] -> TestTree testTree testCases = testGroup "Main implementation" [ testCase "external test vector" $ mapM_ externalTestCase testCases , testCase "internal test vector" $ do sequence_ [ do expectedDiagnosticNotation d e encodedRoundtrip d e | (d,e) <- TestVector.specTestVector ] , --localOption (QuickCheckTests 5000) $ localOption (QuickCheckMaxSize 150) $ testGroup "properties" [ testProperty "from/to reference terms" prop_fromToRefTerm , testProperty "to/from reference terms" prop_toFromRefTerm , testProperty "rountrip de/encoding terms" prop_encodeDecodeTermRoundtrip -- TODO FIXME: need to fix the generation of terms to give -- better size distribution some get far too big for the -- splits properties. , localOption (QuickCheckMaxSize 30) $ testProperty "decoding with all 2-chunks" prop_encodeDecodeTermRoundtrip_splits2 , localOption (QuickCheckMaxSize 20) $ testProperty "decoding with all 3-chunks" prop_encodeDecodeTermRoundtrip_splits3 , testProperty "encode term matches ref impl 1" prop_encodeTermMatchesRefImpl , testProperty "encode term matches ref impl 2" prop_encodeTermMatchesRefImpl2 , testProperty "decoding term matches ref impl" prop_decodeTermMatchesRefImpl ] ] cborg-0.2.1.0/tests/Tests/Reference.hs0000644000000000000000000003061313357736054015650 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Reference ( TestCase(..) -- :: * , termToJson -- :: , equalJson -- :: , loadTestCases -- :: , specTestVector -- :: , testTree -- :: TestTree ) where import Test.Tasty import Test.Tasty.QuickCheck import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Base64.URL as Base64url import qualified Data.ByteString.Base16 as Base16 import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V import Data.Scientific (fromFloatDigits, toRealFloat) import Data.Aeson as Aeson import Control.Applicative import Control.Monad import Data.Word import qualified Numeric.Half as Half import Test.Tasty.HUnit import Tests.Reference.Implementation as CBOR data TestCase = TestCase { encoded :: !LBS.ByteString, decoded :: !(Either Aeson.Value String), roundTrip :: !Bool } deriving Show instance FromJSON TestCase where parseJSON = withObject "cbor test" $ \obj -> do encoded64 <- T.encodeUtf8 <$> obj .: "cbor" encoded <- either (fail "invalid base64") return $ Base64.decode encoded64 encoded16 <- T.encodeUtf8 <$> obj .: "hex" let encoded' = fst (Base16.decode encoded16) when (encoded /= encoded') $ fail "hex and cbor encoding mismatch in input" roundTrip <- obj .: "roundtrip" decoded <- Left <$> obj .: "decoded" <|> Right <$> obj .: "diagnostic" return $! TestCase { encoded = LBS.fromStrict encoded, roundTrip, decoded } loadTestCases :: IO [TestCase] loadTestCases = do content <- LBS.readFile "tests/test-vectors/appendix_a.json" either fail return (Aeson.eitherDecode' content) externalTestCase :: TestCase -> Assertion externalTestCase TestCase { encoded, decoded = Left expectedJson } = do let term = deserialise encoded actualJson = termToJson term reencoded = serialise term expectedJson `equalJson` actualJson encoded @=? reencoded externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do let term = deserialise encoded actualDiagnostic = diagnosticNotation term reencoded = serialise term expectedDiagnostic @=? actualDiagnostic encoded @=? reencoded equalJson :: Aeson.Value -> Aeson.Value -> Assertion equalJson (Aeson.Number expected) (Aeson.Number actual) | toRealFloat expected == promoteDouble (toRealFloat actual) = return () where -- This is because the expected JSON output is always using double precision -- where as Aeson's Scientific type preserves the precision of the input. -- So for tests using Float, we're more precise than the reference values. promoteDouble :: Float -> Double promoteDouble = realToFrac equalJson expected actual = expected @=? actual termToJson :: CBOR.Term -> Aeson.Value termToJson (TUInt n) = Aeson.Number (fromIntegral (fromUInt n)) termToJson (TNInt n) = Aeson.Number (-1 - fromIntegral (fromUInt n)) termToJson (TBigInt n) = Aeson.Number (fromIntegral n) termToJson (TBytes ws) = Aeson.String (bytesToBase64Text ws) termToJson (TBytess wss) = Aeson.String (bytesToBase64Text (concat wss)) termToJson (TString cs) = Aeson.String (T.pack cs) termToJson (TStrings css) = Aeson.String (T.pack (concat css)) termToJson (TArray ts) = Aeson.Array (V.fromList (map termToJson ts)) termToJson (TArrayI ts) = Aeson.Array (V.fromList (map termToJson ts)) termToJson (TMap kvs) = Aeson.object [ (T.pack k, termToJson v) | (TString k,v) <- kvs ] termToJson (TMapI kvs) = Aeson.object [ (T.pack k, termToJson v) | (TString k,v) <- kvs ] termToJson (TTagged _ t) = termToJson t termToJson TTrue = Aeson.Bool True termToJson TFalse = Aeson.Bool False termToJson TNull = Aeson.Null termToJson TUndef = Aeson.Null -- replacement value termToJson (TSimple _) = Aeson.Null -- replacement value termToJson (TFloat16 f) = Aeson.Number (fromFloatDigits (Half.fromHalf f)) termToJson (TFloat32 f) = Aeson.Number (fromFloatDigits f) termToJson (TFloat64 f) = Aeson.Number (fromFloatDigits f) bytesToBase64Text :: [Word8] -> T.Text bytesToBase64Text = T.decodeLatin1 . Base64url.encode . BS.pack expectedDiagnosticNotation :: String -> [Word8] -> Assertion expectedDiagnosticNotation expectedDiagnostic encoded = do let Just (term, []) = runDecoder decodeTerm encoded actualDiagnostic = diagnosticNotation term expectedDiagnostic @=? actualDiagnostic -- | The reference implementation satisfies the roundtrip property for most -- examples (all the ones from Appendix A). It does not satisfy the roundtrip -- property in general however, non-canonical over-long int encodings for -- example. -- -- encodedRoundtrip :: String -> [Word8] -> Assertion encodedRoundtrip expectedDiagnostic encoded = do let Just (term, []) = runDecoder decodeTerm encoded reencoded = encodeTerm term assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded -- | The examples from the CBOR spec RFC7049 Appendix A. -- The diagnostic notation and encoded bytes. -- specTestVector :: [(String, [Word8])] specTestVector = [ ("0", [0x00]) , ("1", [0x01]) , ("10", [0x0a]) , ("23", [0x17]) , ("24", [0x18, 0x18]) , ("25", [0x18, 0x19]) , ("100", [0x18, 0x64]) , ("1000", [0x19, 0x03, 0xe8]) , ("1000000", [0x1a, 0x00, 0x0f, 0x42, 0x40]) , ("1000000000000", [0x1b, 0x00, 0x00, 0x00, 0xe8, 0xd4, 0xa5, 0x10, 0x00]) , ("18446744073709551615", [0x1b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) , ("18446744073709551616", [0xc2, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) , ("-18446744073709551616", [0x3b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) , ("-18446744073709551617", [0xc3, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) , ("-1", [0x20]) , ("-10", [0x29]) , ("-100", [0x38, 0x63]) , ("-1000", [0x39, 0x03, 0xe7]) , ("0.0", [0xf9, 0x00, 0x00]) , ("-0.0", [0xf9, 0x80, 0x00]) , ("1.0", [0xf9, 0x3c, 0x00]) , ("1.1", [0xfb, 0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a]) , ("1.5", [0xf9, 0x3e, 0x00]) , ("65504.0", [0xf9, 0x7b, 0xff]) , ("100000.0", [0xfa, 0x47, 0xc3, 0x50, 0x00]) , ("3.4028234663852886e38", [0xfa, 0x7f, 0x7f, 0xff, 0xff]) , ("1.0e300", [0xfb, 0x7e, 0x37, 0xe4, 0x3c, 0x88, 0x00, 0x75, 0x9c]) , ("5.960464477539063e-8", [0xf9, 0x00, 0x01]) , ("0.00006103515625", [0xf9, 0x04, 0x00]) , ("-4.0", [0xf9, 0xc4, 0x00]) , ("-4.1", [0xfb, 0xc0, 0x10, 0x66, 0x66, 0x66, 0x66, 0x66, 0x66]) , ("Infinity", [0xf9, 0x7c, 0x00]) , ("NaN", [0xf9, 0x7e, 0x00]) , ("-Infinity", [0xf9, 0xfc, 0x00]) , ("Infinity", [0xfa, 0x7f, 0x80, 0x00, 0x00]) , ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00]) , ("Infinity", [0xfb, 0x7f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) , ("-Infinity", [0xfb, 0xff, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) , ("false", [0xf4]) , ("true", [0xf5]) , ("null", [0xf6]) , ("undefined", [0xf7]) , ("simple(16)", [0xf0]) , ("simple(24)", [0xf8, 0x18]) , ("simple(255)", [0xf8, 0xff]) , ("0(\"2013-03-21T20:04:00Z\")", [0xc0, 0x74, 0x32, 0x30, 0x31, 0x33, 0x2d, 0x30, 0x33, 0x2d, 0x32, 0x31, 0x54, 0x32, 0x30, 0x3a, 0x30, 0x34, 0x3a, 0x30, 0x30, 0x5a]) , ("1(1363896240)", [0xc1, 0x1a, 0x51, 0x4b, 0x67, 0xb0]) , ("1(1363896240.5)", [0xc1, 0xfb, 0x41, 0xd4, 0x52, 0xd9, 0xec, 0x20, 0x00, 0x00]) , ("23(h'01020304')", [0xd7, 0x44, 0x01, 0x02, 0x03, 0x04]) , ("24(h'6449455446')", [0xd8, 0x18, 0x45, 0x64, 0x49, 0x45, 0x54, 0x46]) , ("32(\"http://www.example.com\")", [0xd8, 0x20, 0x76, 0x68, 0x74, 0x74, 0x70, 0x3a, 0x2f, 0x2f, 0x77, 0x77, 0x77, 0x2e, 0x65, 0x78, 0x61, 0x6d, 0x70, 0x6c, 0x65, 0x2e, 0x63, 0x6f, 0x6d]) , ("h''", [0x40]) , ("h'01020304'", [0x44, 0x01, 0x02, 0x03, 0x04]) , ("\"\"", [0x60]) , ("\"a\"", [0x61, 0x61]) , ("\"IETF\"", [0x64, 0x49, 0x45, 0x54, 0x46]) , ("\"\\\"\\\\\"", [0x62, 0x22, 0x5c]) , ("\"\\252\"", [0x62, 0xc3, 0xbc]) , ("\"\\27700\"", [0x63, 0xe6, 0xb0, 0xb4]) , ("\"\\65873\"", [0x64, 0xf0, 0x90, 0x85, 0x91]) , ("[]", [0x80]) , ("[1, 2, 3]", [0x83, 0x01, 0x02, 0x03]) , ("[1, [2, 3], [4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05]) , ("[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]", [0x98, 0x19, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x18, 0x18, 0x19]) , ("{}", [0xa0]) , ("{1: 2, 3: 4}", [0xa2, 0x01, 0x02, 0x03, 0x04]) , ("{\"a\": 1, \"b\": [2, 3]}", [0xa2, 0x61, 0x61, 0x01, 0x61, 0x62, 0x82, 0x02, 0x03]) , ("[\"a\", {\"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xa1, 0x61, 0x62, 0x61, 0x63]) , ("{\"a\": \"A\", \"b\": \"B\", \"c\": \"C\", \"d\": \"D\", \"e\": \"E\"}", [0xa5, 0x61, 0x61, 0x61, 0x41, 0x61, 0x62, 0x61, 0x42, 0x61, 0x63, 0x61, 0x43, 0x61, 0x64, 0x61, 0x44, 0x61, 0x65, 0x61, 0x45]) , ("(_ h'0102', h'030405')", [0x5f, 0x42, 0x01, 0x02, 0x43, 0x03, 0x04, 0x05, 0xff]) , ("(_ \"strea\", \"ming\")", [0x7f, 0x65, 0x73, 0x74, 0x72, 0x65, 0x61, 0x64, 0x6d, 0x69, 0x6e, 0x67, 0xff]) , ("[_ ]", [0x9f, 0xff]) , ("[_ 1, [2, 3], [_ 4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff, 0xff]) , ("[_ 1, [2, 3], [4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05, 0xff]) , ("[1, [2, 3], [_ 4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff]) , ("[1, [_ 2, 3], [4, 5]]", [0x83, 0x01, 0x9f, 0x02, 0x03, 0xff, 0x82, 0x04, 0x05]) , ("[_ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]", [0x9f, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x18, 0x18, 0x19, 0xff]) , ("{_ \"a\": 1, \"b\": [_ 2, 3]}", [0xbf, 0x61, 0x61, 0x01, 0x61, 0x62, 0x9f, 0x02, 0x03, 0xff, 0xff]) , ("[\"a\", {_ \"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xbf, 0x61, 0x62, 0x61, 0x63, 0xff]) , ("{_ \"Fun\": true, \"Amt\": -2}", [0xbf, 0x63, 0x46, 0x75, 0x6e, 0xf5, 0x63, 0x41, 0x6d, 0x74, 0x21, 0xff]) ] -- TODO FIXME: test redundant encodings e.g. -- bigint with zero-length bytestring -- bigint with leading zeros -- bigint using indefinate bytestring encoding -- larger than necessary ints, lengths, tags, simple etc -------------------------------------------------------------------------------- -- TestTree API testTree :: [TestCase] -> TestTree testTree testCases = testGroup "Reference implementation" [ testCase "external test vector" $ mapM_ externalTestCase testCases , testCase "internal test vector" $ do sequence_ [ do expectedDiagnosticNotation d e encodedRoundtrip d e | (d,e) <- specTestVector ] , testGroup "properties" [ testProperty "encoding/decoding initial byte" prop_InitialByte , testProperty "encoding/decoding additional info" prop_AdditionalInfo , testProperty "encoding/decoding token header" prop_TokenHeader , testProperty "encoding/decoding token header 2" prop_TokenHeader2 , testProperty "encoding/decoding tokens" prop_Token , --localOption (QuickCheckTests 1000) $ localOption (QuickCheckMaxSize 150) $ testProperty "encoding/decoding terms" prop_Term ] , testGroup "internal properties" [ testProperty "Integer to/from bytes" prop_integerToFromBytes , testProperty "Word16 to/from network byte order" prop_word16ToFromNet , testProperty "Word32 to/from network byte order" prop_word32ToFromNet , testProperty "Word64 to/from network byte order" prop_word64ToFromNet , testProperty "Numeric.Half to/from Float" prop_halfToFromFloat ] ] cborg-0.2.1.0/tests/Tests/Boundary.hs0000644000000000000000000001471513357736054015542 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Tests.Boundary ( testTree -- :: TestTree ) where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Either import Data.Int import Data.Word import qualified Data.Text as T import Codec.CBOR.Decoding import Codec.CBOR.Encoding import Codec.CBOR.Read import Codec.CBOR.Write import Tests.Util import Test.Tasty import Test.Tasty.QuickCheck #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif -- | CBOR can represent 64 bit negative and positive integers, hence we need -- wrapper for Integer to represent the whole range. newtype Int65 = Int65 Integer deriving (Eq, Ord, Enum, Num, Integral, Real, Show) instance Bounded Int65 where maxBound = Int65 (2^(64 :: Int) - 1) minBound = Int65 (-2^(64 :: Int)) instance Arbitrary Int65 where arbitrary = arbitraryBoundedIntegral encodeInt65 :: Int65 -> Encoding encodeInt65 (Int65 n) = encodeInteger n -- | Wrapper for bounded, integral type 'a' that potentially contains values -- outside of range of 'a'. newtype B a = B { unB :: BRep a } type family BRep a where BRep Word = Word64 BRep Word8 = Word64 BRep Word16 = Word64 BRep Word32 = Word64 BRep Word64 = Word64 BRep Int = Int65 BRep Int8 = Int64 BRep Int16 = Int64 BRep Int32 = Int64 BRep Int64 = Int65 instance Show (BRep a) => Show (B a) where showsPrec p = showsPrec p . unB instance (Arbitrary (BRep a), Num (BRep a), Bounded a, Integral a ) => Arbitrary (B a) where arbitrary = B <$> arbitraryWithBounds (undefined::a) -- | Check if deserialisation of values of type 'a' deals properly with the ones -- out of range, i.e. fails to decode them. boundaryTest :: forall a rep. (Bounded a, Integral a, Show a, rep ~ BRep a, Ord rep, Num rep) => (rep -> Encoding) -- ^ encode -> (forall s. Decoder s a) -- ^ decode -> B a -> Property boundaryTest enc dec a = if outsideRange then collect "outside" $ isLeft a' else collect "inside" $ isRight a' where a' = deserialiseFromBytes dec . toLazyByteString . enc $ unB a -- Note that this is always true for a ~ rep. outsideRange = unB a < fromIntegral (minBound :: a) || unB a > fromIntegral (maxBound :: a) mkBoundaryTest :: forall a rep. (Bounded a, Integral a, Show a, rep ~ BRep a, Arbitrary rep, Ord rep, Show rep, Num rep) => String -> (rep -> Encoding) -> (forall s. Decoder s a) -> (forall s. Decoder s a) -> [TestTree] mkBoundaryTest aName enc dec decCan = [ testProperty aName $ boundaryTest enc dec , testProperty (aName ++ " (canonical)") $ boundaryTest enc decCan ] ---------------------------------------- -- | Check if deserialisation of map/list length deals properly with the ones -- out of range, i.e. fails to decode them. lenBoundaryTest :: (Word -> Encoding) -> (forall s. Decoder s Int) -> Length -> Property lenBoundaryTest enc dec a = if outsideRange then collect "outside" $ isLeft a' else collect "inside" $ isRight a' where a' = deserialiseFromBytes dec . toLazyByteString . enc $ unLength a outsideRange = fromIntegral (unLength a) < (0::Int) mkLenBoundaryTest :: String -> (Word -> Encoding) -> (forall s. Decoder s Int) -> (forall s. Decoder s Int) -> [TestTree] mkLenBoundaryTest aName enc dec decCan = [ testProperty aName $ lenBoundaryTest enc dec , testProperty (aName ++ " (canonical)") $ lenBoundaryTest enc decCan ] ---------------------------------------- data StringLengthPrefix = StringLP Word BSL.ByteString deriving Show instance Arbitrary StringLengthPrefix where arbitrary = (\l -> StringLP (unLength l) (mkLengthPrefix True l)) <$> arbitrary data BytesLengthPrefix = BytesLP Word BSL.ByteString deriving Show instance Arbitrary BytesLengthPrefix where arbitrary = (\l -> BytesLP (unLength l) (mkLengthPrefix False l)) <$> arbitrary -- | Test that positive length prefixes of string/bytes are parsed successfully, -- whereas negative are not. stringBytesBoundaryTest :: [TestTree] stringBytesBoundaryTest = [ testProperty "String" $ \(StringLP w bs) -> case deserialiseFromBytes decodeString bs of Right (_rest, string) -> w == 0 && T.length string == 0 Left (DeserialiseFailure _ msg) -> if fromIntegral w < (0::Int) then msg == "expected string" else msg == "end of input" , testProperty "Bytes" $ \(BytesLP w bs) -> case deserialiseFromBytes decodeBytes bs of Right (_rest, bytes) -> w == 0 && BS.length bytes == 0 Left (DeserialiseFailure _ msg) -> if fromIntegral w < (0::Int) then msg == "expected bytes" else msg == "end of input" ] ---------------------------------------- testTree :: TestTree testTree = localOption (QuickCheckTests 1000) . testGroup "Boundary checks" $ concat [ mkBoundaryTest "Word" encodeWord64 decodeWord decodeWordCanonical , mkBoundaryTest "Word8" encodeWord64 decodeWord8 decodeWord8Canonical , mkBoundaryTest "Word16" encodeWord64 decodeWord16 decodeWord16Canonical , mkBoundaryTest "Word32" encodeWord64 decodeWord32 decodeWord32Canonical , mkBoundaryTest "Word64" encodeWord64 decodeWord64 decodeWord64Canonical , mkBoundaryTest "Int" encodeInt65 decodeInt decodeIntCanonical , mkBoundaryTest "Int8" encodeInt64 decodeInt8 decodeInt8Canonical , mkBoundaryTest "Int16" encodeInt64 decodeInt16 decodeInt16Canonical , mkBoundaryTest "Int32" encodeInt64 decodeInt32 decodeInt32Canonical , mkBoundaryTest "Int64" encodeInt65 decodeInt64 decodeInt64Canonical , mkLenBoundaryTest "ListLen" encodeListLen decodeListLen decodeListLenCanonical , mkLenBoundaryTest "MapLen" encodeMapLen decodeMapLen decodeMapLenCanonical , stringBytesBoundaryTest ] cborg-0.2.1.0/tests/Tests/Regress/0000755000000000000000000000000013357736054015025 5ustar0000000000000000cborg-0.2.1.0/tests/Tests/Regress/Issue162.hs0000644000000000000000000000526513357736054016712 0ustar0000000000000000module Tests.Regress.Issue162 ( testTree ) where import Control.Monad (void) import Data.Word import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LBS import Codec.CBOR.Decoding import Codec.CBOR.Read import Test.Tasty import Test.Tasty.HUnit -- This example demonstrates a bug in cborg canonical decoding. -- The bytes used here were drawn from a real application. -- Decodes bigBytes x assuming x is a canonical integer encoding. bigBytesDecoder :: Decoder s () bigBytesDecoder = () <$ decodeListLenCanonical <* decodeMapLenCanonical <* decodeListLenCanonical <* decodeListLenCanonical <* decodeWord16Canonical <* decodeWord16Canonical <* decodeWord8Canonical <* decodeMapLenCanonical <* decodeMapLenCanonical <* decodeMapLenCanonical <* decodeListLenCanonical <* decodeWord8Canonical <* decodeListLenCanonical <* decodeListLenCanonical <* decodeMapLenCanonical <* decodeWord8Canonical <* decodeListLenCanonical <* decodeIntegerCanonical <* decodeWord32Canonical <* decodeWord8Canonical <* decodeListLenCanonical <* decodeIntegerCanonical <* decodeWord32Canonical -- Encoding of 592033 :: BigInteger -- 0xc2 means bignum, 0x43 means a 3-byte sequence bigBytes :: [Word8] -> ByteString bigBytes someEncodedInteger = LBS.pack $ [ -- list of length 7 0x87 -- empty map , 0xa0 -- Just , 0x81 -- list of length 3, all items are 0 , 0x83 , 0x00, 0x00, 0x00 -- empty maps , 0xa0 , 0xa0 , 0xa0 -- singleton list (encoded Just) , 0x81 , 0x00 , 0x80 -- singleton list (encoded Just) , 0x81 , 0xa2 -- key 0 , 0x00 -- value 0: a pair of numbers. , 0x82 , 0x1a, 0x00, 0x04, 0xec, 0xf9 , 0x1a, 0x1a, 0xeb, 0x97, 0x7a -- key 1 , 0x01 -- value 1: a pair of numbers. , 0x82 ] ++ someEncodedInteger ++ [ 0x1a, 0x05, 0xee, 0x4d, 0x20 ] nonCanonicalInteger :: [Word8] nonCanonicalInteger = [0xc2, 0x43, 0x09, 0x08, 0xa1] shouldFailSimple :: Either DeserialiseFailure (LBS.ByteString, ()) shouldFailSimple = deserialiseFromBytes (void decodeIntegerCanonical) (LBS.pack nonCanonicalInteger) shouldFailComposite :: Either DeserialiseFailure (LBS.ByteString, ()) shouldFailComposite = deserialiseFromBytes bigBytesDecoder (bigBytes nonCanonicalInteger) testTree :: TestTree testTree = testGroup "Issue 162 - canonical decoding" [ testCase "simple" (Left (DeserialiseFailure 0 "non-canonical integer") @=? shouldFailSimple) , testCase "composite" (Left (DeserialiseFailure 34 "non-canonical integer") @=? shouldFailComposite) ] cborg-0.2.1.0/tests/Tests/Regress/FlatTerm.hs0000644000000000000000000000313613357736054017102 0ustar0000000000000000{-# LANGUAGE CPP #-} module Tests.Regress.FlatTerm ( testTree -- :: TestTree ) where import Data.Int #if !MIN_VERSION_base(4,8,0) import Data.Word #endif import Test.Tasty import Test.Tasty.HUnit import Codec.CBOR.Encoding import Codec.CBOR.Decoding import Codec.CBOR.FlatTerm -------------------------------------------------------------------------------- -- Tests and properties -- | Test an edge case in the FlatTerm implementation: when encoding a word -- larger than @'maxBound' :: 'Int'@, we store it as an @'Integer'@, and -- need to remember to handle this case when we decode. largeWordTest :: Either String Word largeWordTest = fromFlatTerm decodeWord $ toFlatTerm (encodeWord largeWord) largeWord :: Word largeWord = fromIntegral (maxBound :: Int) + 1 -- | Test an edge case in the FlatTerm implementation: when encoding an -- Int64 that is less than @'minBound' :: 'Int'@, make sure we use an -- @'Integer'@ to store the result, because sticking it into an @'Int'@ -- will result in overflow otherwise. smallInt64Test :: Either String Int64 smallInt64Test = fromFlatTerm decodeInt64 $ toFlatTerm (encodeInt64 smallInt64) smallInt64 :: Int64 smallInt64 = fromIntegral (minBound :: Int) - 1 -------------------------------------------------------------------------------- -- TestTree API testTree :: TestTree testTree = testGroup "FlatTerm regressions" [ testCase "Decoding of large-ish words" (Right largeWord @=? largeWordTest) , testCase "Encoding of Int64s on 32bit" (Right smallInt64 @=? smallInt64Test) ] cborg-0.2.1.0/tests/Tests/Regress/Issue160.hs0000644000000000000000000000422513357736054016703 0ustar0000000000000000module Tests.Regress.Issue160 ( testTree ) where import Codec.CBOR.Decoding import Codec.CBOR.Read import Control.DeepSeq import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Text (Text) import Test.Tasty import Test.Tasty.HUnit testTree :: TestTree testTree = testGroup "Issue 160 - decoder checks" [ nonUtf8FailureTest "fast path" (BSL.fromStrict $ BS.pack [0x61, 128]) , nonUtf8FailureTest "slow path" (BSL.fromChunks $ map BS.singleton [0x61, 128]) , testCase "decodeListLen doesn't produce negative lengths using a Word64" $ do let bs = BSL.fromStrict $ BS.pack [0x9b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff] case deserialiseFromBytes decodeListLen bs of Left err -> deepseq err $ pure () Right (rest, t) -> deepseq rest $ assertBool "Length is not negative" (t >= 0) , testCase "decodeMapLen doesn't produce negative lengths using a Word64" $ do let bs = BSL.fromStrict $ BS.pack [0xbb, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff] case deserialiseFromBytes decodeMapLen bs of Left err -> deepseq err $ pure () Right (rest, t) -> deepseq rest $ assertBool "Length is not negative" (t >= 0) , testCase "decodeBytes doesn't create bytestrings that cause segfaults or worse" $ do let bs = BSL.fromStrict $ BS.pack $ [0x5b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff] ++ replicate 100 0x00 case deserialiseFromBytes decodeBytes bs of Left err -> deepseq err $ pure () Right (rest, t) -> deepseq rest $ assertBool "Length is not negative" (BS.length t >= 0) ] where nonUtf8FailureTest pathType bs = let title = mconcat ["decodeString fails on non-utf8 bytes instead of crashing (" , pathType , ")" ] in testCase title $ do case deserialiseFromBytes decodeString bs of Left err -> deepseq err $ pure () Right (rest, t) -> deepseq (rest, t :: Text) $ pure () cborg-0.2.1.0/tests/Tests/Reference/0000755000000000000000000000000013357736054015311 5ustar0000000000000000cborg-0.2.1.0/tests/Tests/Reference/Implementation.hs0000644000000000000000000011354713357736054020645 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.CBOR -- Copyright : 2013 Simon Meier , -- 2013-2014 Duncan Coutts, -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : Duncan Coutts -- Stability : -- Portability : portable -- -- CBOR format support. -- ----------------------------------------------------------------------------- module Tests.Reference.Implementation ( serialise, deserialise, Term(..), reservedTag, reservedSimple, eqTerm, canonicaliseTerm, UInt(..), fromUInt, toUInt, canonicaliseUInt, Decoder, runDecoder, testDecode, decodeTerm, decodeTokens, decodeToken, canonicalNaN, diagnosticNotation, encodeTerm, encodeToken, prop_InitialByte, prop_AdditionalInfo, prop_TokenHeader, prop_TokenHeader2, prop_Token, prop_Term, -- properties of internal helpers prop_integerToFromBytes, prop_word16ToFromNet, prop_word32ToFromNet, prop_word64ToFromNet, prop_halfToFromFloat, arbitraryFullRangeIntegral, ) where import qualified Control.Monad.Fail as Fail import Data.Bits import Data.Word import Data.Int import Numeric.Half (Half(..)) import qualified Numeric.Half as Half import Data.List import Numeric import GHC.Float (float2Double) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Monoid ((<>)) import Foreign import System.IO.Unsafe import Control.Monad (ap) import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..)) import Control.Applicative #endif serialise :: Term -> LBS.ByteString serialise = LBS.pack . encodeTerm deserialise :: LBS.ByteString -> Term deserialise bytes = case runDecoder decodeTerm (LBS.unpack bytes) of Just (term, []) -> term Just _ -> error "ReferenceImpl.deserialise: trailing data" Nothing -> error "ReferenceImpl.deserialise: decoding failed" ------------------------------------------------------------------------ newtype Decoder a = Decoder { runDecoder :: [Word8] -> Maybe (a, [Word8]) } instance Functor Decoder where fmap f a = a >>= return . f instance Applicative Decoder where pure = return (<*>) = ap instance Monad Decoder where return x = Decoder (\ws -> Just (x, ws)) d >>= f = Decoder (\ws -> case runDecoder d ws of Nothing -> Nothing Just (x, ws') -> runDecoder (f x) ws') fail = Fail.fail instance Fail.MonadFail Decoder where fail _ = Decoder (\_ -> Nothing) getByte :: Decoder Word8 getByte = Decoder $ \ws -> case ws of w:ws' -> Just (w, ws') _ -> Nothing getBytes :: Integral n => n -> Decoder [Word8] getBytes n = Decoder $ \ws -> case genericSplitAt n ws of (ws', []) | genericLength ws' == n -> Just (ws', []) | otherwise -> Nothing (ws', ws'') -> Just (ws', ws'') eof :: Decoder Bool eof = Decoder $ \ws -> Just (null ws, ws) type Encoder a = a -> [Word8] -- The initial byte of each data item contains both information about -- the major type (the high-order 3 bits, described in Section 2.1) and -- additional information (the low-order 5 bits). data MajorType = MajorType0 | MajorType1 | MajorType2 | MajorType3 | MajorType4 | MajorType5 | MajorType6 | MajorType7 deriving (Show, Eq, Ord, Enum) instance Arbitrary MajorType where arbitrary = elements [MajorType0 .. MajorType7] encodeInitialByte :: MajorType -> Word -> Word8 encodeInitialByte mt ai | ai < 2^(5 :: Int) = fromIntegral (fromIntegral (fromEnum mt) `shiftL` 5 .|. ai) | otherwise = error "encodeInitialByte: invalid additional info value" decodeInitialByte :: Word8 -> (MajorType, Word) decodeInitialByte ib = ( toEnum $ fromIntegral $ ib `shiftR` 5 , fromIntegral $ ib .&. 0x1f) prop_InitialByte :: Bool prop_InitialByte = and [ (uncurry encodeInitialByte . decodeInitialByte) w8 == w8 | w8 <- [minBound..maxBound] ] -- When the value of the -- additional information is less than 24, it is directly used as a -- small unsigned integer. When it is 24 to 27, the additional bytes -- for a variable-length integer immediately follow; the values 24 to 27 -- of the additional information specify that its length is a 1-, 2-, -- 4-, or 8-byte unsigned integer, respectively. Additional information -- value 31 is used for indefinite-length items, described in -- Section 2.2. Additional information values 28 to 30 are reserved for -- future expansion. -- -- In all additional information values, the resulting integer is -- interpreted depending on the major type. It may represent the actual -- data: for example, in integer types, the resulting integer is used -- for the value itself. It may instead supply length information: for -- example, in byte strings it gives the length of the byte string data -- that follows. data UInt = UIntSmall Word | UInt8 Word8 | UInt16 Word16 | UInt32 Word32 | UInt64 Word64 deriving (Eq, Show) data AdditionalInformation = AiValue UInt | AiIndefLen | AiReserved Word deriving (Eq, Show) instance Arbitrary UInt where arbitrary = sized $ \n -> oneof $ take (1 + n `div` 2) [ UIntSmall <$> choose (0, 23) , UInt8 <$> arbitraryBoundedIntegral , UInt16 <$> arbitraryBoundedIntegral , UInt32 <$> arbitraryBoundedIntegral , UInt64 <$> arbitraryBoundedIntegral ] instance Arbitrary AdditionalInformation where arbitrary = frequency [ (7, AiValue <$> arbitrary) , (2, pure AiIndefLen) , (1, AiReserved <$> choose (28, 30)) ] decodeAdditionalInfo :: Word -> Decoder AdditionalInformation decodeAdditionalInfo = dec where dec n | n < 24 = return (AiValue (UIntSmall n)) dec 24 = do w <- getByte return (AiValue (UInt8 w)) dec 25 = do [w1,w0] <- getBytes (2 :: Int) let w = word16FromNet w1 w0 return (AiValue (UInt16 w)) dec 26 = do [w3,w2,w1,w0] <- getBytes (4 :: Int) let w = word32FromNet w3 w2 w1 w0 return (AiValue (UInt32 w)) dec 27 = do [w7,w6,w5,w4,w3,w2,w1,w0] <- getBytes (8 :: Int) let w = word64FromNet w7 w6 w5 w4 w3 w2 w1 w0 return (AiValue (UInt64 w)) dec 31 = return AiIndefLen dec n | n < 31 = return (AiReserved n) dec _ = fail "" encodeAdditionalInfo :: AdditionalInformation -> (Word, [Word8]) encodeAdditionalInfo = enc where enc (AiValue (UIntSmall n)) | n < 24 = (n, []) | otherwise = error "invalid UIntSmall value" enc (AiValue (UInt8 w)) = (24, [w]) enc (AiValue (UInt16 w)) = (25, [w1, w0]) where (w1, w0) = word16ToNet w enc (AiValue (UInt32 w)) = (26, [w3, w2, w1, w0]) where (w3, w2, w1, w0) = word32ToNet w enc (AiValue (UInt64 w)) = (27, [w7, w6, w5, w4, w3, w2, w1, w0]) where (w7, w6, w5, w4, w3, w2, w1, w0) = word64ToNet w enc AiIndefLen = (31, []) enc (AiReserved n) | n >= 28 && n < 31 = (n, []) | otherwise = error "invalid AiReserved value" prop_AdditionalInfo :: AdditionalInformation -> Bool prop_AdditionalInfo ai = let (w, ws) = encodeAdditionalInfo ai Just (ai', _) = runDecoder (decodeAdditionalInfo w) ws in ai == ai' data TokenHeader = TokenHeader MajorType AdditionalInformation deriving (Show, Eq) instance Arbitrary TokenHeader where arbitrary = TokenHeader <$> arbitrary <*> arbitrary decodeTokenHeader :: Decoder TokenHeader decodeTokenHeader = do b <- getByte let (mt, ai) = decodeInitialByte b ai' <- decodeAdditionalInfo ai return (TokenHeader mt ai') encodeTokenHeader :: Encoder TokenHeader encodeTokenHeader (TokenHeader mt ai) = let (w, ws) = encodeAdditionalInfo ai in encodeInitialByte mt w : ws prop_TokenHeader :: TokenHeader -> Bool prop_TokenHeader header = let ws = encodeTokenHeader header Just (header', _) = runDecoder decodeTokenHeader ws in header == header' prop_TokenHeader2 :: Bool prop_TokenHeader2 = and [ w8 : extraused == encoded | w8 <- [minBound..maxBound] , let extra = [1..8] Just (header, unused) = runDecoder decodeTokenHeader (w8 : extra) encoded = encodeTokenHeader header extraused = take (8 - length unused) extra ] data Token = MT0_UnsignedInt UInt | MT1_NegativeInt UInt | MT2_ByteString UInt [Word8] | MT2_ByteStringIndef | MT3_String UInt [Word8] | MT3_StringIndef | MT4_ArrayLen UInt | MT4_ArrayLenIndef | MT5_MapLen UInt | MT5_MapLenIndef | MT6_Tag UInt | MT7_Simple Word8 | MT7_Float16 Half | MT7_Float32 Float | MT7_Float64 Double | MT7_Break deriving (Show, Eq) instance Arbitrary Token where arbitrary = oneof [ MT0_UnsignedInt <$> arbitrary , MT1_NegativeInt <$> arbitrary , do ws <- arbitrary MT2_ByteString <$> arbitraryLengthUInt ws <*> pure ws , pure MT2_ByteStringIndef , do cs <- arbitrary let ws = encodeUTF8 cs MT3_String <$> arbitraryLengthUInt ws <*> pure ws , pure MT3_StringIndef , MT4_ArrayLen <$> arbitrary , pure MT4_ArrayLenIndef , MT5_MapLen <$> arbitrary , pure MT5_MapLenIndef , MT6_Tag <$> arbitrary , MT7_Simple <$> arbitrary , MT7_Float16 . getFloatSpecials <$> arbitrary , MT7_Float32 . getFloatSpecials <$> arbitrary , MT7_Float64 . getFloatSpecials <$> arbitrary , pure MT7_Break ] where arbitraryLengthUInt xs = let n = length xs in elements $ [ UIntSmall (fromIntegral n) | n < 24 ] ++ [ UInt8 (fromIntegral n) | n < 255 ] ++ [ UInt16 (fromIntegral n) | n < 65536 ] ++ [ UInt32 (fromIntegral n) , UInt64 (fromIntegral n) ] testDecode :: [Word8] -> Term testDecode ws = case runDecoder decodeTerm ws of Just (x, []) -> x _ -> error "testDecode: parse error" decodeTokens :: Decoder [Token] decodeTokens = do done <- eof if done then return [] else do tok <- decodeToken toks <- decodeTokens return (tok:toks) decodeToken :: Decoder Token decodeToken = do header <- decodeTokenHeader extra <- getBytes (tokenExtraLen header) either fail return (packToken header extra) tokenExtraLen :: TokenHeader -> Word64 tokenExtraLen (TokenHeader MajorType2 (AiValue n)) = fromUInt n -- bytestrings tokenExtraLen (TokenHeader MajorType3 (AiValue n)) = fromUInt n -- unicode strings tokenExtraLen _ = 0 packToken :: TokenHeader -> [Word8] -> Either String Token packToken (TokenHeader mt ai) extra = case (mt, ai) of -- Major type 0: an unsigned integer. The 5-bit additional information -- is either the integer itself (for additional information values 0 -- through 23) or the length of additional data. (MajorType0, AiValue n) -> return (MT0_UnsignedInt n) -- Major type 1: a negative integer. The encoding follows the rules -- for unsigned integers (major type 0), except that the value is -- then -1 minus the encoded unsigned integer. (MajorType1, AiValue n) -> return (MT1_NegativeInt n) -- Major type 2: a byte string. The string's length in bytes is -- represented following the rules for positive integers (major type 0). (MajorType2, AiValue n) -> return (MT2_ByteString n extra) (MajorType2, AiIndefLen) -> return MT2_ByteStringIndef -- Major type 3: a text string, specifically a string of Unicode -- characters that is encoded as UTF-8 [RFC3629]. The format of this -- type is identical to that of byte strings (major type 2), that is, -- as with major type 2, the length gives the number of bytes. (MajorType3, AiValue n) -> return (MT3_String n extra) (MajorType3, AiIndefLen) -> return MT3_StringIndef -- Major type 4: an array of data items. The array's length follows the -- rules for byte strings (major type 2), except that the length -- denotes the number of data items, not the length in bytes that the -- array takes up. (MajorType4, AiValue n) -> return (MT4_ArrayLen n) (MajorType4, AiIndefLen) -> return MT4_ArrayLenIndef -- Major type 5: a map of pairs of data items. A map is comprised of -- pairs of data items, each pair consisting of a key that is -- immediately followed by a value. The map's length follows the -- rules for byte strings (major type 2), except that the length -- denotes the number of pairs, not the length in bytes that the map -- takes up. (MajorType5, AiValue n) -> return (MT5_MapLen n) (MajorType5, AiIndefLen) -> return MT5_MapLenIndef -- Major type 6: optional semantic tagging of other major types. -- The initial bytes of the tag follow the rules for positive integers -- (major type 0). (MajorType6, AiValue n) -> return (MT6_Tag n) -- Major type 7 is for two types of data: floating-point numbers and -- "simple values" that do not need any content. Each value of the -- 5-bit additional information in the initial byte has its own separate -- meaning, as defined in Table 1. -- | 0..23 | Simple value (value 0..23) | -- | 24 | Simple value (value 32..255 in following byte) | -- | 25 | IEEE 754 Half-Precision Float (16 bits follow) | -- | 26 | IEEE 754 Single-Precision Float (32 bits follow) | -- | 27 | IEEE 754 Double-Precision Float (64 bits follow) | -- | 28-30 | (Unassigned) | -- | 31 | "break" stop code for indefinite-length items | (MajorType7, AiValue (UIntSmall w)) -> return (MT7_Simple (fromIntegral w)) (MajorType7, AiValue (UInt8 w)) -> return (MT7_Simple (fromIntegral w)) (MajorType7, AiValue (UInt16 w)) -> return (MT7_Float16 (wordToHalf w)) (MajorType7, AiValue (UInt32 w)) -> return (MT7_Float32 (wordToFloat w)) (MajorType7, AiValue (UInt64 w)) -> return (MT7_Float64 (wordToDouble w)) (MajorType7, AiIndefLen) -> return (MT7_Break) _ -> fail "invalid token header" encodeToken :: Encoder Token encodeToken tok = let (header, extra) = unpackToken tok in encodeTokenHeader header ++ extra unpackToken :: Token -> (TokenHeader, [Word8]) unpackToken tok = (\(mt, ai, ws) -> (TokenHeader mt ai, ws)) $ case tok of (MT0_UnsignedInt n) -> (MajorType0, AiValue n, []) (MT1_NegativeInt n) -> (MajorType1, AiValue n, []) (MT2_ByteString n ws) -> (MajorType2, AiValue n, ws) MT2_ByteStringIndef -> (MajorType2, AiIndefLen, []) (MT3_String n ws) -> (MajorType3, AiValue n, ws) MT3_StringIndef -> (MajorType3, AiIndefLen, []) (MT4_ArrayLen n) -> (MajorType4, AiValue n, []) MT4_ArrayLenIndef -> (MajorType4, AiIndefLen, []) (MT5_MapLen n) -> (MajorType5, AiValue n, []) MT5_MapLenIndef -> (MajorType5, AiIndefLen, []) (MT6_Tag n) -> (MajorType6, AiValue n, []) (MT7_Simple n) | n <= 23 -> (MajorType7, AiValue (UIntSmall (fromIntegral n)), []) | otherwise -> (MajorType7, AiValue (UInt8 n), []) (MT7_Float16 f) -> (MajorType7, AiValue (UInt16 (halfToWord f)), []) (MT7_Float32 f) -> (MajorType7, AiValue (UInt32 (floatToWord f)), []) (MT7_Float64 f) -> (MajorType7, AiValue (UInt64 (doubleToWord f)), []) MT7_Break -> (MajorType7, AiIndefLen, []) fromUInt :: UInt -> Word64 fromUInt (UIntSmall w) = fromIntegral w fromUInt (UInt8 w) = fromIntegral w fromUInt (UInt16 w) = fromIntegral w fromUInt (UInt32 w) = fromIntegral w fromUInt (UInt64 w) = fromIntegral w toUInt :: Word64 -> UInt toUInt n | n < 24 = UIntSmall (fromIntegral n) | n <= fromIntegral (maxBound :: Word8) = UInt8 (fromIntegral n) | n <= fromIntegral (maxBound :: Word16) = UInt16 (fromIntegral n) | n <= fromIntegral (maxBound :: Word32) = UInt32 (fromIntegral n) | otherwise = UInt64 n lengthUInt :: [a] -> UInt lengthUInt = toUInt . fromIntegral . length decodeUTF8 :: [Word8] -> Either String [Char] decodeUTF8 = either (fail . show) (return . T.unpack) . T.decodeUtf8' . BS.pack encodeUTF8 :: [Char] -> [Word8] encodeUTF8 = BS.unpack . T.encodeUtf8 . T.pack reservedSimple :: Word8 -> Bool reservedSimple w = w >= 20 && w <= 31 reservedTag :: Word64 -> Bool reservedTag w = w <= 5 prop_Token :: Token -> Bool prop_Token token = let ws = encodeToken token Just (token', []) = runDecoder decodeToken ws in token `eqToken` token' -- NaNs are so annoying... eqToken :: Token -> Token -> Bool eqToken (MT7_Float16 f) (MT7_Float16 f') | isNaN f && isNaN f' = True eqToken (MT7_Float32 f) (MT7_Float32 f') | isNaN f && isNaN f' = True eqToken (MT7_Float64 f) (MT7_Float64 f') | isNaN f && isNaN f' = True eqToken a b = a == b data Term = TUInt UInt | TNInt UInt | TBigInt Integer | TBytes [Word8] | TBytess [[Word8]] | TString [Char] | TStrings [[Char]] | TArray [Term] | TArrayI [Term] | TMap [(Term, Term)] | TMapI [(Term, Term)] | TTagged UInt Term | TTrue | TFalse | TNull | TUndef | TSimple Word8 | TFloat16 Half | TFloat32 Float | TFloat64 Double deriving (Show, Eq) instance Arbitrary Term where arbitrary = frequency [ (1, TUInt <$> arbitrary) , (1, TNInt <$> arbitrary) , (1, TBigInt . getLargeInteger <$> arbitrary) , (1, TBytes <$> arbitrary) , (1, TBytess <$> arbitrary) , (1, TString <$> arbitrary) , (1, TStrings <$> arbitrary) , (2, TArray <$> listOfSmaller arbitrary) , (2, TArrayI <$> listOfSmaller arbitrary) , (2, TMap <$> listOfSmaller ((,) <$> arbitrary <*> arbitrary)) , (2, TMapI <$> listOfSmaller ((,) <$> arbitrary <*> arbitrary)) , (1, TTagged <$> arbitraryTag <*> sized (\sz -> resize (max 0 (sz-1)) arbitrary)) , (1, pure TFalse) , (1, pure TTrue) , (1, pure TNull) , (1, pure TUndef) , (1, TSimple <$> arbitrary `suchThat` (not . reservedSimple)) , (1, TFloat16 <$> arbitrary) , (1, TFloat32 <$> arbitrary) , (1, TFloat64 <$> arbitrary) ] where listOfSmaller :: Gen a -> Gen [a] listOfSmaller gen = sized $ \n -> do k <- choose (0,n) vectorOf k (resize (n `div` (k+1)) gen) arbitraryTag = arbitrary `suchThat` (not . reservedTag . fromUInt) shrink (TUInt n) = [ TUInt n' | n' <- shrink n ] shrink (TNInt n) = [ TNInt n' | n' <- shrink n ] shrink (TBigInt n) = [ TBigInt n' | n' <- shrink n ] shrink (TBytes ws) = [ TBytes ws' | ws' <- shrink ws ] shrink (TBytess wss) = [ TBytess wss' | wss' <- shrink wss ] shrink (TString ws) = [ TString ws' | ws' <- shrink ws ] shrink (TStrings wss) = [ TStrings wss' | wss' <- shrink wss ] shrink (TArray xs@[x]) = x : [ TArray xs' | xs' <- shrink xs ] shrink (TArray xs) = [ TArray xs' | xs' <- shrink xs ] shrink (TArrayI xs@[x]) = x : [ TArrayI xs' | xs' <- shrink xs ] shrink (TArrayI xs) = [ TArrayI xs' | xs' <- shrink xs ] shrink (TMap xys@[(x,y)]) = x : y : [ TMap xys' | xys' <- shrink xys ] shrink (TMap xys) = [ TMap xys' | xys' <- shrink xys ] shrink (TMapI xys@[(x,y)]) = x : y : [ TMapI xys' | xys' <- shrink xys ] shrink (TMapI xys) = [ TMapI xys' | xys' <- shrink xys ] shrink (TTagged w t) = [ TTagged w' t' | (w', t') <- shrink (w, t) , not (reservedTag (fromUInt w')) ] shrink TFalse = [] shrink TTrue = [] shrink TNull = [] shrink TUndef = [] shrink (TSimple w) = [ TSimple w' | w' <- shrink w, not (reservedSimple w) ] shrink (TFloat16 f) = [ TFloat16 f' | f' <- shrink f ] shrink (TFloat32 f) = [ TFloat32 f' | f' <- shrink f ] shrink (TFloat64 f) = [ TFloat64 f' | f' <- shrink f ] decodeTerm :: Decoder Term decodeTerm = decodeToken >>= decodeTermFrom decodeTermFrom :: Token -> Decoder Term decodeTermFrom tk = case tk of MT0_UnsignedInt n -> return (TUInt n) MT1_NegativeInt n -> return (TNInt n) MT2_ByteString _ bs -> return (TBytes bs) MT2_ByteStringIndef -> decodeBytess [] MT3_String _ ws -> either fail (return . TString) (decodeUTF8 ws) MT3_StringIndef -> decodeStrings [] MT4_ArrayLen len -> decodeArrayN (fromUInt len) [] MT4_ArrayLenIndef -> decodeArray [] MT5_MapLen len -> decodeMapN (fromUInt len) [] MT5_MapLenIndef -> decodeMap [] MT6_Tag tag -> decodeTagged tag MT7_Simple 20 -> return TFalse MT7_Simple 21 -> return TTrue MT7_Simple 22 -> return TNull MT7_Simple 23 -> return TUndef MT7_Simple w -> return (TSimple w) MT7_Float16 f -> return (TFloat16 f) MT7_Float32 f -> return (TFloat32 f) MT7_Float64 f -> return (TFloat64 f) MT7_Break -> fail "unexpected" decodeBytess :: [[Word8]] -> Decoder Term decodeBytess acc = do tk <- decodeToken case tk of MT7_Break -> return $! TBytess (reverse acc) MT2_ByteString _ bs -> decodeBytess (bs : acc) _ -> fail "unexpected" decodeStrings :: [String] -> Decoder Term decodeStrings acc = do tk <- decodeToken case tk of MT7_Break -> return $! TStrings (reverse acc) MT3_String _ ws -> do cs <- either fail return (decodeUTF8 ws) decodeStrings (cs : acc) _ -> fail "unexpected" decodeArrayN :: Word64 -> [Term] -> Decoder Term decodeArrayN n acc = case n of 0 -> return $! TArray (reverse acc) _ -> do t <- decodeTerm decodeArrayN (n-1) (t : acc) decodeArray :: [Term] -> Decoder Term decodeArray acc = do tk <- decodeToken case tk of MT7_Break -> return $! TArrayI (reverse acc) _ -> do tm <- decodeTermFrom tk decodeArray (tm : acc) decodeMapN :: Word64 -> [(Term, Term)] -> Decoder Term decodeMapN n acc = case n of 0 -> return $! TMap (reverse acc) _ -> do tm <- decodeTerm tm' <- decodeTerm decodeMapN (n-1) ((tm, tm') : acc) decodeMap :: [(Term, Term)] -> Decoder Term decodeMap acc = do tk <- decodeToken case tk of MT7_Break -> return $! TMapI (reverse acc) _ -> do tm <- decodeTermFrom tk tm' <- decodeTerm decodeMap ((tm, tm') : acc) decodeTagged :: UInt -> Decoder Term decodeTagged tag | fromUInt tag == 2 = do MT2_ByteString _ bs <- decodeToken let !n = integerFromBytes bs return (TBigInt n) decodeTagged tag | fromUInt tag == 3 = do MT2_ByteString _ bs <- decodeToken let !n = integerFromBytes bs return (TBigInt (-1 - n)) decodeTagged tag = do tm <- decodeTerm return (TTagged tag tm) integerFromBytes :: [Word8] -> Integer integerFromBytes [] = 0 integerFromBytes (w0:ws0) = go (fromIntegral w0) ws0 where go !acc [] = acc go !acc (w:ws) = go (acc `shiftL` 8 + fromIntegral w) ws integerToBytes :: Integer -> [Word8] integerToBytes n0 | n0 == 0 = [0] | n0 < 0 = reverse (go (-n0)) | otherwise = reverse (go n0) where go n | n == 0 = [] | otherwise = narrow n : go (n `shiftR` 8) narrow :: Integer -> Word8 narrow = fromIntegral prop_integerToFromBytes :: LargeInteger -> Bool prop_integerToFromBytes (LargeInteger n) | n >= 0 = let ws = integerToBytes n n' = integerFromBytes ws in n == n' | otherwise = let ws = integerToBytes n n' = integerFromBytes ws in n == -n' ------------------------------------------------------------------------------- encodeTerm :: Encoder Term encodeTerm (TUInt n) = encodeToken (MT0_UnsignedInt n) encodeTerm (TNInt n) = encodeToken (MT1_NegativeInt n) encodeTerm (TBigInt n) | n >= 0 = encodeToken (MT6_Tag (UIntSmall 2)) <> let ws = integerToBytes n len = lengthUInt ws in encodeToken (MT2_ByteString len ws) | otherwise = encodeToken (MT6_Tag (UIntSmall 3)) <> let ws = integerToBytes (-1 - n) len = lengthUInt ws in encodeToken (MT2_ByteString len ws) encodeTerm (TBytes ws) = let len = lengthUInt ws in encodeToken (MT2_ByteString len ws) encodeTerm (TBytess wss) = encodeToken MT2_ByteStringIndef <> mconcat [ encodeToken (MT2_ByteString len ws) | ws <- wss , let len = lengthUInt ws ] <> encodeToken MT7_Break encodeTerm (TString cs) = let ws = encodeUTF8 cs len = lengthUInt ws in encodeToken (MT3_String len ws) encodeTerm (TStrings css) = encodeToken MT3_StringIndef <> mconcat [ encodeToken (MT3_String len ws) | cs <- css , let ws = encodeUTF8 cs len = lengthUInt ws ] <> encodeToken MT7_Break encodeTerm (TArray ts) = let len = lengthUInt ts in encodeToken (MT4_ArrayLen len) <> mconcat (map encodeTerm ts) encodeTerm (TArrayI ts) = encodeToken MT4_ArrayLenIndef <> mconcat (map encodeTerm ts) <> encodeToken MT7_Break encodeTerm (TMap kvs) = let len = lengthUInt kvs in encodeToken (MT5_MapLen len) <> mconcat [ encodeTerm k <> encodeTerm v | (k,v) <- kvs ] encodeTerm (TMapI kvs) = encodeToken MT5_MapLenIndef <> mconcat [ encodeTerm k <> encodeTerm v | (k,v) <- kvs ] <> encodeToken MT7_Break encodeTerm (TTagged tag t) = encodeToken (MT6_Tag tag) <> encodeTerm t encodeTerm TFalse = encodeToken (MT7_Simple 20) encodeTerm TTrue = encodeToken (MT7_Simple 21) encodeTerm TNull = encodeToken (MT7_Simple 22) encodeTerm TUndef = encodeToken (MT7_Simple 23) encodeTerm (TSimple w) = encodeToken (MT7_Simple w) encodeTerm (TFloat16 f) = encodeToken (MT7_Float16 f) encodeTerm (TFloat32 f) = encodeToken (MT7_Float32 f) encodeTerm (TFloat64 f) = encodeToken (MT7_Float64 f) ------------------------------------------------------------------------------- prop_Term :: Term -> Bool prop_Term term = let ws = encodeTerm term Just (term', []) = runDecoder decodeTerm ws in term `eqTerm` term' -- NaNs are so annoying... eqTerm :: Term -> Term -> Bool eqTerm (TArray ts) (TArray ts') = and (zipWith eqTerm ts ts') eqTerm (TArrayI ts) (TArrayI ts') = and (zipWith eqTerm ts ts') eqTerm (TMap ts) (TMap ts') = and (zipWith eqTermPair ts ts') eqTerm (TMapI ts) (TMapI ts') = and (zipWith eqTermPair ts ts') eqTerm (TTagged w t) (TTagged w' t') = w == w' && eqTerm t t' eqTerm (TFloat16 f) (TFloat16 f') | isNaN f && isNaN f' = True eqTerm (TFloat32 f) (TFloat32 f') | isNaN f && isNaN f' = True eqTerm (TFloat64 f) (TFloat64 f') | isNaN f && isNaN f' = True eqTerm a b = a == b eqTermPair :: (Term, Term) -> (Term, Term) -> Bool eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b' canonicaliseTerm :: Term -> Term canonicaliseTerm (TUInt n) = TUInt (canonicaliseUInt n) canonicaliseTerm (TNInt n) = TNInt (canonicaliseUInt n) canonicaliseTerm (TBigInt n) | n >= 0 && n <= fromIntegral (maxBound :: Word64) = TUInt (toUInt (fromIntegral n)) | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64) = 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) canonicaliseTerm (TArrayI ts) = TArrayI (map canonicaliseTerm ts) canonicaliseTerm (TMap ts) = TMap (map canonicaliseTermPair ts) canonicaliseTerm (TMapI ts) = TMapI (map canonicaliseTermPair ts) canonicaliseTerm (TTagged tag t) = TTagged (canonicaliseUInt tag) (canonicaliseTerm t) canonicaliseTerm t = t canonicaliseUInt :: UInt -> UInt canonicaliseUInt = toUInt . fromUInt canonicaliseHalf :: Half -> Half canonicaliseHalf f | isNaN f = canonicalNaN | otherwise = f canonicaliseTermPair :: (Term, Term) -> (Term, Term) canonicaliseTermPair (x,y) = (canonicaliseTerm x, canonicaliseTerm y) canonicalNaN :: Half canonicalNaN = Half 0x7e00 ------------------------------------------------------------------------------- diagnosticNotation :: Term -> String diagnosticNotation = \t -> showsTerm t "" where showsTerm tm = case tm of TUInt n -> shows (fromUInt n) TNInt n -> shows (-1 - fromIntegral (fromUInt n) :: Integer) TBigInt n -> shows n TBytes bs -> showsBytes bs TBytess bss -> surround '(' ')' (underscoreSpace . commaSep showsBytes bss) TString cs -> shows cs TStrings css -> surround '(' ')' (underscoreSpace . commaSep shows css) TArray ts -> surround '[' ']' (commaSep showsTerm ts) TArrayI ts -> surround '[' ']' (underscoreSpace . commaSep showsTerm ts) TMap ts -> surround '{' '}' (commaSep showsMapElem ts) TMapI ts -> surround '{' '}' (underscoreSpace . commaSep showsMapElem ts) TTagged tag t -> shows (fromUInt tag) . surround '(' ')' (showsTerm t) TTrue -> showString "true" TFalse -> showString "false" TNull -> showString "null" TUndef -> showString "undefined" TSimple n -> showString "simple" . surround '(' ')' (shows n) -- convert to float to work around https://github.com/ekmett/half/issues/2 TFloat16 f -> showFloatCompat (float2Double (Half.fromHalf f)) TFloat32 f -> showFloatCompat (float2Double f) TFloat64 f -> showFloatCompat f surround a b x = showChar a . x . showChar b commaSpace = showChar ',' . showChar ' ' underscoreSpace = showChar '_' . showChar ' ' showsMapElem (k,v) = showsTerm k . showChar ':' . showChar ' ' . showsTerm v catShows :: (a -> ShowS) -> [a] -> ShowS catShows f xs = \s -> foldr (\x r -> f x . r) id xs s sepShows :: ShowS -> (a -> ShowS) -> [a] -> ShowS sepShows sep f xs = foldr (.) id (intersperse sep (map f xs)) commaSep = sepShows commaSpace showsBytes :: [Word8] -> ShowS showsBytes bs = showChar 'h' . showChar '\'' . catShows showFHex bs . showChar '\'' showFHex n | n < 16 = showChar '0' . showHex n | otherwise = showHex n showFloatCompat n | exponent' >= -5 && exponent' <= 15 = showFFloat Nothing n | otherwise = showEFloat Nothing n where exponent' = snd (floatToDigits 10 n) word16FromNet :: Word8 -> Word8 -> Word16 word16FromNet w1 w0 = fromIntegral w1 `shiftL` (8*1) .|. fromIntegral w0 `shiftL` (8*0) word16ToNet :: Word16 -> (Word8, Word8) word16ToNet w = ( fromIntegral ((w `shiftR` (8*1)) .&. 0xff) , fromIntegral ((w `shiftR` (8*0)) .&. 0xff) ) word32FromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 word32FromNet w3 w2 w1 w0 = fromIntegral w3 `shiftL` (8*3) .|. fromIntegral w2 `shiftL` (8*2) .|. fromIntegral w1 `shiftL` (8*1) .|. fromIntegral w0 `shiftL` (8*0) word32ToNet :: Word32 -> (Word8, Word8, Word8, Word8) word32ToNet w = ( fromIntegral ((w `shiftR` (8*3)) .&. 0xff) , fromIntegral ((w `shiftR` (8*2)) .&. 0xff) , fromIntegral ((w `shiftR` (8*1)) .&. 0xff) , fromIntegral ((w `shiftR` (8*0)) .&. 0xff) ) word64FromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word64 word64FromNet w7 w6 w5 w4 w3 w2 w1 w0 = fromIntegral w7 `shiftL` (8*7) .|. fromIntegral w6 `shiftL` (8*6) .|. fromIntegral w5 `shiftL` (8*5) .|. fromIntegral w4 `shiftL` (8*4) .|. fromIntegral w3 `shiftL` (8*3) .|. fromIntegral w2 `shiftL` (8*2) .|. fromIntegral w1 `shiftL` (8*1) .|. fromIntegral w0 `shiftL` (8*0) word64ToNet :: Word64 -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) word64ToNet w = ( fromIntegral ((w `shiftR` (8*7)) .&. 0xff) , fromIntegral ((w `shiftR` (8*6)) .&. 0xff) , fromIntegral ((w `shiftR` (8*5)) .&. 0xff) , fromIntegral ((w `shiftR` (8*4)) .&. 0xff) , fromIntegral ((w `shiftR` (8*3)) .&. 0xff) , fromIntegral ((w `shiftR` (8*2)) .&. 0xff) , fromIntegral ((w `shiftR` (8*1)) .&. 0xff) , fromIntegral ((w `shiftR` (8*0)) .&. 0xff) ) prop_word16ToFromNet :: Word8 -> Word8 -> Bool prop_word16ToFromNet w1 w0 = word16ToNet (word16FromNet w1 w0) == (w1, w0) prop_word32ToFromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Bool prop_word32ToFromNet w3 w2 w1 w0 = word32ToNet (word32FromNet w3 w2 w1 w0) == (w3, w2, w1, w0) prop_word64ToFromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Bool prop_word64ToFromNet w7 w6 w5 w4 w3 w2 w1 w0 = word64ToNet (word64FromNet w7 w6 w5 w4 w3 w2 w1 w0) == (w7, w6, w5, w4, w3, w2, w1, w0) wordToHalf :: Word16 -> Half wordToHalf = Half.Half . fromIntegral wordToFloat :: Word32 -> Float wordToFloat = toFloat wordToDouble :: Word64 -> Double wordToDouble = toFloat toFloat :: (Storable word, Storable float) => word -> float toFloat w = unsafeDupablePerformIO $ alloca $ \buf -> do poke (castPtr buf) w peek buf halfToWord :: Half -> Word16 halfToWord (Half.Half w) = fromIntegral w floatToWord :: Float -> Word32 floatToWord = fromFloat doubleToWord :: Double -> Word64 doubleToWord = fromFloat fromFloat :: (Storable word, Storable float) => float -> word fromFloat float = unsafeDupablePerformIO $ alloca $ \buf -> do poke (castPtr buf) float peek buf -- Note: some NaNs do not roundtrip https://github.com/ekmett/half/issues/3 -- but all the others had better prop_halfToFromFloat :: Bool prop_halfToFromFloat = all (\w -> roundTrip w || isNaN (Half.Half w)) [minBound..maxBound] where roundTrip w = w == (Half.getHalf . Half.toHalf . Half.fromHalf . Half.Half $ w) instance Arbitrary Half where arbitrary = Half.Half . fromIntegral <$> (arbitrary :: Gen Word16) newtype FloatSpecials n = FloatSpecials { getFloatSpecials :: n } deriving (Show, Eq) instance (Arbitrary n, RealFloat n) => Arbitrary (FloatSpecials n) where arbitrary = frequency [ (7, FloatSpecials <$> arbitrary) , (1, pure (FloatSpecials (1/0)) ) -- +Infinity , (1, pure (FloatSpecials (0/0)) ) -- NaN , (1, pure (FloatSpecials (-1/0)) ) -- -Infinity ] newtype LargeInteger = LargeInteger { getLargeInteger :: Integer } deriving (Show, Eq) instance Arbitrary LargeInteger where arbitrary = sized $ \n -> oneof $ take (1 + n `div` 10) [ LargeInteger . fromIntegral <$> (arbitrary :: Gen Int8) , LargeInteger . fromIntegral <$> choose (minBound, maxBound :: Int64) , LargeInteger . bigger . fromIntegral <$> choose (minBound, maxBound :: Int64) ] where bigger n = n * abs n arbitraryFullRangeIntegral :: forall a. (Bounded a, #if MIN_VERSION_base(4,7,0) FiniteBits a, #else Bits a, #endif Integral a) => Gen a arbitraryFullRangeIntegral | isSigned (undefined :: a) = let maxBits = bitSize' (undefined :: a) - 1 in sized $ \s -> let bound = fromIntegral (maxBound :: a) `shiftR` ((maxBits - s) `max` 0) in fmap fromInteger $ choose (-bound, bound) | otherwise = let maxBits = bitSize' (undefined :: a) in sized $ \s -> let bound = fromIntegral (maxBound :: a) `shiftR` ((maxBits - s) `max` 0) in fmap fromInteger $ choose (0, bound) where bitSize' = #if MIN_VERSION_base(4,7,0) finiteBitSize #else bitSize #endif cborg-0.2.1.0/tests/test-vectors/0000755000000000000000000000000013357736054014753 5ustar0000000000000000cborg-0.2.1.0/tests/test-vectors/README.md0000644000000000000000000000206313357736054016233 0ustar0000000000000000test-vectors ============ This repo collects some simple test vectors in machine-processable form. appendix_a.json --------------- All examples in Appendix A of RFC 7049, encoded as a JSON array. Each element of the test vector is a map (JSON object) with the keys: - cbor: a base-64 encoded CBOR data item - hex: the same CBOR data item in hex encoding - roundtrip: a boolean that indicates whether a generic CBOR encoder would _typically_ produce identical CBOR on re-encoding the decoded data item (your mileage may vary) - decoded: the decoded data item if it can be represented in JSON - diagnostic: the representation of the data item in CBOR diagnostic notation, otherwise To make use of the cases that need diagnostic notation, a diagnostic notation printer is usually all that is needed: decode the CBOR, print the decoded data item in diagnostic notation, and compare. (Note that the diagnostic notation uses full decoration for the indefinite length byte string, while the decoded indefinite length text string represented in JSON necessarily doesn't.) cborg-0.2.1.0/tests/test-vectors/appendix_a.json0000644000000000000000000002356313357736054017767 0ustar0000000000000000[ { "cbor": "AA==", "hex": "00", "roundtrip": true, "decoded": 0 }, { "cbor": "AQ==", "hex": "01", "roundtrip": true, "decoded": 1 }, { "cbor": "Cg==", "hex": "0a", "roundtrip": true, "decoded": 10 }, { "cbor": "Fw==", "hex": "17", "roundtrip": true, "decoded": 23 }, { "cbor": "GBg=", "hex": "1818", "roundtrip": true, "decoded": 24 }, { "cbor": "GBk=", "hex": "1819", "roundtrip": true, "decoded": 25 }, { "cbor": "GGQ=", "hex": "1864", "roundtrip": true, "decoded": 100 }, { "cbor": "GQPo", "hex": "1903e8", "roundtrip": true, "decoded": 1000 }, { "cbor": "GgAPQkA=", "hex": "1a000f4240", "roundtrip": true, "decoded": 1000000 }, { "cbor": "GwAAAOjUpRAA", "hex": "1b000000e8d4a51000", "roundtrip": true, "decoded": 1000000000000 }, { "cbor": "G///////////", "hex": "1bffffffffffffffff", "roundtrip": true, "decoded": 18446744073709551615 }, { "cbor": "wkkBAAAAAAAAAAA=", "hex": "c249010000000000000000", "roundtrip": true, "decoded": 18446744073709551616 }, { "cbor": "O///////////", "hex": "3bffffffffffffffff", "roundtrip": true, "decoded": -18446744073709551616 }, { "cbor": "w0kBAAAAAAAAAAA=", "hex": "c349010000000000000000", "roundtrip": true, "decoded": -18446744073709551617 }, { "cbor": "IA==", "hex": "20", "roundtrip": true, "decoded": -1 }, { "cbor": "KQ==", "hex": "29", "roundtrip": true, "decoded": -10 }, { "cbor": "OGM=", "hex": "3863", "roundtrip": true, "decoded": -100 }, { "cbor": "OQPn", "hex": "3903e7", "roundtrip": true, "decoded": -1000 }, { "cbor": "+QAA", "hex": "f90000", "roundtrip": true, "decoded": 0.0 }, { "cbor": "+YAA", "hex": "f98000", "roundtrip": true, "decoded": -0.0 }, { "cbor": "+TwA", "hex": "f93c00", "roundtrip": true, "decoded": 1.0 }, { "cbor": "+z/xmZmZmZma", "hex": "fb3ff199999999999a", "roundtrip": true, "decoded": 1.1 }, { "cbor": "+T4A", "hex": "f93e00", "roundtrip": true, "decoded": 1.5 }, { "cbor": "+Xv/", "hex": "f97bff", "roundtrip": true, "decoded": 65504.0 }, { "cbor": "+kfDUAA=", "hex": "fa47c35000", "roundtrip": true, "decoded": 100000.0 }, { "cbor": "+n9///8=", "hex": "fa7f7fffff", "roundtrip": true, "decoded": 3.4028234663852886e+38 }, { "cbor": "+3435DyIAHWc", "hex": "fb7e37e43c8800759c", "roundtrip": true, "decoded": 1.0e+300 }, { "cbor": "+QAB", "hex": "f90001", "roundtrip": true, "decoded": 5.960464477539063e-08 }, { "cbor": "+QQA", "hex": "f90400", "roundtrip": true, "decoded": 6.103515625e-05 }, { "cbor": "+cQA", "hex": "f9c400", "roundtrip": true, "decoded": -4.0 }, { "cbor": "+8AQZmZmZmZm", "hex": "fbc010666666666666", "roundtrip": true, "decoded": -4.1 }, { "cbor": "+XwA", "hex": "f97c00", "roundtrip": true, "diagnostic": "Infinity" }, { "cbor": "+X4A", "hex": "f97e00", "roundtrip": true, "diagnostic": "NaN" }, { "cbor": "+fwA", "hex": "f9fc00", "roundtrip": true, "diagnostic": "-Infinity" }, { "cbor": "+n+AAAA=", "hex": "fa7f800000", "roundtrip": false, "diagnostic": "Infinity" }, { "cbor": "+v+AAAA=", "hex": "faff800000", "roundtrip": false, "diagnostic": "-Infinity" }, { "cbor": "+3/wAAAAAAAA", "hex": "fb7ff0000000000000", "roundtrip": false, "diagnostic": "Infinity" }, { "cbor": "+//wAAAAAAAA", "hex": "fbfff0000000000000", "roundtrip": false, "diagnostic": "-Infinity" }, { "cbor": "9A==", "hex": "f4", "roundtrip": true, "decoded": false }, { "cbor": "9Q==", "hex": "f5", "roundtrip": true, "decoded": true }, { "cbor": "9g==", "hex": "f6", "roundtrip": true, "decoded": null }, { "cbor": "9w==", "hex": "f7", "roundtrip": true, "diagnostic": "undefined" }, { "cbor": "8A==", "hex": "f0", "roundtrip": true, "diagnostic": "simple(16)" }, { "cbor": "+Bg=", "hex": "f818", "roundtrip": true, "diagnostic": "simple(24)" }, { "cbor": "+P8=", "hex": "f8ff", "roundtrip": true, "diagnostic": "simple(255)" }, { "cbor": "wHQyMDEzLTAzLTIxVDIwOjA0OjAwWg==", "hex": "c074323031332d30332d32315432303a30343a30305a", "roundtrip": true, "diagnostic": "0(\"2013-03-21T20:04:00Z\")" }, { "cbor": "wRpRS2ew", "hex": "c11a514b67b0", "roundtrip": true, "diagnostic": "1(1363896240)" }, { "cbor": "wftB1FLZ7CAAAA==", "hex": "c1fb41d452d9ec200000", "roundtrip": true, "diagnostic": "1(1363896240.5)" }, { "cbor": "10QBAgME", "hex": "d74401020304", "roundtrip": true, "diagnostic": "23(h'01020304')" }, { "cbor": "2BhFZElFVEY=", "hex": "d818456449455446", "roundtrip": true, "diagnostic": "24(h'6449455446')" }, { "cbor": "2CB2aHR0cDovL3d3dy5leGFtcGxlLmNvbQ==", "hex": "d82076687474703a2f2f7777772e6578616d706c652e636f6d", "roundtrip": true, "diagnostic": "32(\"http://www.example.com\")" }, { "cbor": "QA==", "hex": "40", "roundtrip": true, "diagnostic": "h''" }, { "cbor": "RAECAwQ=", "hex": "4401020304", "roundtrip": true, "diagnostic": "h'01020304'" }, { "cbor": "YA==", "hex": "60", "roundtrip": true, "decoded": "" }, { "cbor": "YWE=", "hex": "6161", "roundtrip": true, "decoded": "a" }, { "cbor": "ZElFVEY=", "hex": "6449455446", "roundtrip": true, "decoded": "IETF" }, { "cbor": "YiJc", "hex": "62225c", "roundtrip": true, "decoded": "\"\\" }, { "cbor": "YsO8", "hex": "62c3bc", "roundtrip": true, "decoded": "ü" }, { "cbor": "Y+awtA==", "hex": "63e6b0b4", "roundtrip": true, "decoded": "水" }, { "cbor": "ZPCQhZE=", "hex": "64f0908591", "roundtrip": true, "decoded": "𐅑" }, { "cbor": "gA==", "hex": "80", "roundtrip": true, "decoded": [ ] }, { "cbor": "gwECAw==", "hex": "83010203", "roundtrip": true, "decoded": [ 1, 2, 3 ] }, { "cbor": "gwGCAgOCBAU=", "hex": "8301820203820405", "roundtrip": true, "decoded": [ 1, [ 2, 3 ], [ 4, 5 ] ] }, { "cbor": "mBkBAgMEBQYHCAkKCwwNDg8QERITFBUWFxgYGBk=", "hex": "98190102030405060708090a0b0c0d0e0f101112131415161718181819", "roundtrip": true, "decoded": [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 ] }, { "cbor": "oA==", "hex": "a0", "roundtrip": true, "decoded": { } }, { "cbor": "ogECAwQ=", "hex": "a201020304", "roundtrip": true, "diagnostic": "{1: 2, 3: 4}" }, { "cbor": "omFhAWFiggID", "hex": "a26161016162820203", "roundtrip": true, "decoded": { "a": 1, "b": [ 2, 3 ] } }, { "cbor": "gmFhoWFiYWM=", "hex": "826161a161626163", "roundtrip": true, "decoded": [ "a", { "b": "c" } ] }, { "cbor": "pWFhYUFhYmFCYWNhQ2FkYURhZWFF", "hex": "a56161614161626142616361436164614461656145", "roundtrip": true, "decoded": { "a": "A", "b": "B", "c": "C", "d": "D", "e": "E" } }, { "cbor": "X0IBAkMDBAX/", "hex": "5f42010243030405ff", "roundtrip": false, "diagnostic": "(_ h'0102', h'030405')" }, { "cbor": "f2VzdHJlYWRtaW5n/w==", "hex": "7f657374726561646d696e67ff", "roundtrip": false, "decoded": "streaming" }, { "cbor": "n/8=", "hex": "9fff", "roundtrip": false, "decoded": [ ] }, { "cbor": "nwGCAgOfBAX//w==", "hex": "9f018202039f0405ffff", "roundtrip": false, "decoded": [ 1, [ 2, 3 ], [ 4, 5 ] ] }, { "cbor": "nwGCAgOCBAX/", "hex": "9f01820203820405ff", "roundtrip": false, "decoded": [ 1, [ 2, 3 ], [ 4, 5 ] ] }, { "cbor": "gwGCAgOfBAX/", "hex": "83018202039f0405ff", "roundtrip": false, "decoded": [ 1, [ 2, 3 ], [ 4, 5 ] ] }, { "cbor": "gwGfAgP/ggQF", "hex": "83019f0203ff820405", "roundtrip": false, "decoded": [ 1, [ 2, 3 ], [ 4, 5 ] ] }, { "cbor": "nwECAwQFBgcICQoLDA0ODxAREhMUFRYXGBgYGf8=", "hex": "9f0102030405060708090a0b0c0d0e0f101112131415161718181819ff", "roundtrip": false, "decoded": [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 ] }, { "cbor": "v2FhAWFinwID//8=", "hex": "bf61610161629f0203ffff", "roundtrip": false, "decoded": { "a": 1, "b": [ 2, 3 ] } }, { "cbor": "gmFhv2FiYWP/", "hex": "826161bf61626163ff", "roundtrip": false, "decoded": [ "a", { "b": "c" } ] }, { "cbor": "v2NGdW71Y0FtdCH/", "hex": "bf6346756ef563416d7421ff", "roundtrip": false, "decoded": { "Fun": true, "Amt": -2 } } ]