diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,33 @@ +Copyright (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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cborg.cabal b/cborg.cabal new file mode 100644 --- /dev/null +++ b/cborg.cabal @@ -0,0 +1,84 @@ +name: cborg +version: 0.1.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 + +description: + This package (formerly @binary-serialise-cbor@) provides an efficient + implementation of the Concise Binary Object Representation (CBOR), as + specified by RFC 7049. + . + If you are looking for a library for serialisation of Haskell values, + have a look at the @serialise@ package, which is built upon this library. + +extra-source-files: + src/cbits/cbor.h + +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 + + 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.6, + ghc-prim >= 0.3 && < 0.6, + half >= 0.2.2.3 && < 0.3, + 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.* diff --git a/src/Codec/CBOR.hs b/src/Codec/CBOR.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR.hs @@ -0,0 +1,14 @@ +-- | +-- 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 + ( + ) where diff --git a/src/Codec/CBOR/Decoding.hs b/src/Codec/CBOR/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Decoding.hs @@ -0,0 +1,593 @@ +{-# 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 () + , decodeString -- :: Decoder s Text + , decodeStringIndef -- :: Decoder s () + , 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(..) + + -- ** 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 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)) + +-- 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)) +#endif + + | ConsumeInteger (Integer -> ST s (DecodeAction s a)) + | ConsumeFloat (Float# -> ST s (DecodeAction s a)) + | ConsumeDouble (Double# -> ST s (DecodeAction s a)) + | ConsumeBytes (ByteString -> ST s (DecodeAction s a)) + | ConsumeString (Text -> ST s (DecodeAction s a)) + | ConsumeBool (Bool -> ST s (DecodeAction s a)) + | ConsumeSimple (Word# -> ST s (DecodeAction s a)) + + | 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) + +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)) + + +--------------------------------------- +-- 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 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 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 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 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 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 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 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 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 #-} + + +-------------------------------------------------------------- +-- 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 n = do + n' <- decodeWord + if n == n' then return () + else fail $ "expected word " ++ show n +{-# 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 len = do + len' <- decodeListLen + if len == len' then return () + else fail $ "expected list of length " ++ show len +{-# INLINE decodeListLenOf #-} + + +-------------------------------------------------------------- +-- 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 #-} + diff --git a/src/Codec/CBOR/Encoding.hs b/src/Codec/CBOR/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Encoding.hs @@ -0,0 +1,331 @@ +{-# 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 + , encodeString -- :: T.Text -> Encoding + , encodeStringIndef -- :: 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 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 + | TkString {-# UNPACK #-} !T.Text 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 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 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 diff --git a/src/Codec/CBOR/Encoding.hs-boot b/src/Codec/CBOR/Encoding.hs-boot new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Encoding.hs-boot @@ -0,0 +1,5 @@ +module Codec.CBOR.Encoding where + +newtype Encoding = Encoding (Tokens -> Tokens) + +data Tokens diff --git a/src/Codec/CBOR/FlatTerm.hs b/src/Codec/CBOR/FlatTerm.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/FlatTerm.hs @@ -0,0 +1,486 @@ +{-# 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 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 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.TkString st ts) = TkString st : convFlatTerm ts +convFlatTerm (Enc.TkStringBegin ts) = TkStringBegin : 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 + +#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 + + -- 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 +#endif + + go (TkFloat16 f : ts) (ConsumeFloat k) = k (unF# f) >>= go ts + go (TkFloat32 f : ts) (ConsumeFloat k) = k (unF# f) >>= go ts + go (TkFloat16 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts + go (TkFloat32 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts + go (TkFloat64 f : ts) (ConsumeDouble k) = k (unD# f) >>= go ts + go (TkBytes bs : ts) (ConsumeBytes k) = k bs >>= go ts + go (TkString st : ts) (ConsumeString k) = k st >>= go ts + go (TkBool b : ts) (ConsumeBool k) = k b >>= go ts + go (TkSimple n : ts) (ConsumeSimple k) = k (unW8# n) >>= go ts + + go (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 (ConsumeFloat _) = unexpected "decodeFloat" ts + go ts (ConsumeDouble _) = unexpected "decodeDouble" ts + go ts (ConsumeBytes _) = unexpected "decodeBytes" ts + go ts (ConsumeString _) = unexpected "decodeString" ts + go ts (ConsumeBool _) = unexpected "decodeBool" ts + go ts (ConsumeSimple _) = unexpected "decodeSimple" 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 +#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 diff --git a/src/Codec/CBOR/FlatTerm.hs-boot b/src/Codec/CBOR/FlatTerm.hs-boot new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/FlatTerm.hs-boot @@ -0,0 +1,10 @@ +module Codec.CBOR.FlatTerm where + +import {-# SOURCE #-} Codec.CBOR.Encoding + +type FlatTerm = [TermToken] + +data TermToken +instance Show TermToken + +toFlatTerm :: Encoding -> FlatTerm diff --git a/src/Codec/CBOR/Magic.hs b/src/Codec/CBOR/Magic.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Magic.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- 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 + + -- * @'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 + +#include "cbor.h" + +import GHC.Exts +import GHC.ST (ST(ST)) +import GHC.IO (IO(IO), unsafeDupablePerformIO) +import GHC.Word +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 qualified Numeric.Half as Half + +#if !defined(HAVE_BYTESWAP_PRIMOPS) || !defined(MEM_UNALIGNED_OPS) +import Data.Bits ((.|.), unsafeShiftL) + +#if defined(ARCH_32bit) +import GHC.IntWord64 (wordToWord64#) +#endif +#endif + +-------------------------------------------------------------------------------- + +-- | Grab a 8-bit @'Word'@ given a @'Ptr'@ to some address. +grabWord8 :: Ptr () -> Word +{-# INLINE grabWord8 #-} + +-- | Grab a 16-bit @'Word'@ given a @'Ptr'@ to some address. +grabWord16 :: Ptr () -> Word +{-# INLINE grabWord16 #-} + +-- | Grab a 32-bit @'Word'@ given a @'Ptr'@ to some address. +grabWord32 :: Ptr () -> Word +{-# 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#) = W# (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#) = W# (narrow16Word# (byteSwap16# (indexWord16OffAddr# ip# 0#))) +grabWord32 (Ptr ip#) = W# (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#) = W# (indexWord16OffAddr# ip# 0#) +grabWord32 (Ptr ip#) = W# (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# -> W# w0# `unsafeShiftL` 8 .|. + W# 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# -> W# w0# `unsafeShiftL` 24 .|. + W# w1# `unsafeShiftL` 16 .|. + W# w2# `unsafeShiftL` 8 .|. + W# 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 -> Word +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 -> Word +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 -> Word +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 _) = +#if MIN_VERSION_bytestring(0,10,6) + BS.accursedUnutterablePerformIO $ withForeignPtr x $ + \(Ptr addr#) -> return $! (f (Ptr addr# `plusPtr` off)) +#else + unsafeDupablePerformIO $ withForeignPtr x $ + \(Ptr addr#) -> return $! (f (Ptr addr# `plusPtr` off)) +#endif +{-# INLINE withBsPtr #-} + +-------------------------------------------------------------------------------- +-- Half floats + +-- | Convert a @'Word'@ to a half-sized @'Float'@. +wordToFloat16 :: Word -> Float +wordToFloat16 = \x -> Half.fromHalf (Half.Half (fromIntegral x)) +{-# INLINE wordToFloat16 #-} + +-- | Convert a half-sized @'Float'@ to a @'Word'@. +floatToWord16 :: Float -> Word16 +floatToWord16 = \x -> fromIntegral (Half.getHalf (Half.toHalf x)) +{-# 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 @'Word'@ to a @'Float'@. +wordToFloat32 :: Word -> Float +wordToFloat32 (W# 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# #-} + +-------------------------------------------------------------------------------- +-- 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', () #)) diff --git a/src/Codec/CBOR/Pretty.hs b/src/Codec/CBOR/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Pretty.hs @@ -0,0 +1,307 @@ +{-# 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 (TkString t tks) = Just (TkString t TkEnd,tks) +unconsToken (TkStringBegin tks) = Just (TkStringBegin 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 diff --git a/src/Codec/CBOR/Read.hs b/src/Codec/CBOR/Read.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Read.hs @@ -0,0 +1,1952 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- 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) + , 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.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 +import GHC.Exts +import GHC.Float (float2Double) +import Data.Typeable +import Control.Exception + +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 (Show, Typeable) + +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 = + runIDecode (deserialiseIncremental d) lbs + + +runIDecode :: (forall s. ST s (IDecode s a)) + -> LBS.ByteString + -> Either DeserialiseFailure (LBS.ByteString, a) +runIDecode d lbs = + runST (go lbs =<< d) + where + go :: LBS.ByteString + -> IDecode s a + -> ST s (Either DeserialiseFailure (LBS.ByteString, a)) + go _ (Fail _ _ err) = return (Left err) + go lbs' (Done bs _ x) = return (Right (LBS.Chunk bs lbs', x)) + go LBS.Empty (Partial k) = k Nothing >>= go LBS.Empty + go (LBS.Chunk bs lbs') (Partial k) = k (Just bs) >>= go lbs' + +-- | 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 + | SlowConsumeTokenString {-# UNPACK #-} !ByteString (T.Text -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int + | SlowConsumeTokenBytes {-# UNPACK #-} !ByteString (ByteString -> ST s (DecodeAction s a)) {-# UNPACK #-} !Int + | SlowDecodeAction {-# UNPACK #-} !ByteString (DecodeAction s a) + | SlowFail {-# UNPACK #-} !ByteString String + + +-- 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) + +#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) +#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@(ConsumeString k) = + case tryConsumeString (BS.unsafeHead bs) bs of + DecodeFailure -> go_fast_end bs da + DecodedToken sz (Fits str) -> k str >>= go_fast (BS.unsafeDrop sz bs) + DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenString (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@(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` fromIntegral 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` fromIntegral 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) + +#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 word64" + 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) +#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 (ConsumeString k) = + case tryConsumeString (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected string" + DecodedToken sz (Fits str) -> k str >>= go_fast_end (BS.unsafeDrop sz bs) + DecodedToken sz (TooLong len) -> return $! SlowConsumeTokenString (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 (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 + fromIntegral (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' + fromIntegral len) + where + !offset' = offset + fromIntegral (BS.length bs - BS.length bs') + + SlowConsumeTokenString bs' k len -> do + (bstr, bs'') <- getTokenVarLen len bs' offset' + let !str = T.decodeUtf8 bstr -- TODO FIXME: utf8 validation + lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len) + where + !offset' = offset + fromIntegral (BS.length bs - BS.length bs') + + -- we didn't have enough input in the buffer + SlowDecodeAction bs' da' | BS.null bs' -> do + -- in this case we're exactly out of input + -- 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 + fromIntegral (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 + fromIntegral (BS.length bs - BS.length bs') + + SlowFail bs' msg -> decodeFail bs' offset' msg + where + !offset' = offset + fromIntegral (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 + fromIntegral 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'') <- if BS.length bs' < len + then getTokenVarLen len bs' offset' + else let !bstr = BS.take len bs' + !bs'' = BS.drop len bs' + in return (bstr, bs'') + lift (k bstr) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len) + + SlowConsumeTokenString bs_empty k len -> + assert (BS.null bs_empty) $ do + (bstr, bs'') <- if BS.length bs' < len + then getTokenVarLen len bs' offset' + else let !bstr = BS.take len bs' + !bs'' = BS.drop len bs' + in return (bstr, bs'') + let !str = T.decodeUtf8 bstr -- TODO FIXME: utf8 validation + lift (k str) >>= \daz -> go_slow daz bs'' (offset' + fromIntegral len) + + SlowFail bs_unconsumed msg -> + decodeFail (bs_unconsumed <> bs') offset'' msg + where + !offset'' = offset + fromIntegral (sz - BS.length bs_unconsumed) + + + +-- TODO FIXME: we can do slightly better here. If we're returning a +-- lazy string (String, lazy Text, lazy ByteString) then we don't have +-- to strictify here and if we're returning a strict string perhaps we +-- 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 = + fromIntegral $ + decodeTableSz `A.unsafeAt` (fromIntegral 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 :: Word -> Word -> Word8 +encodeHeader mt ai = fromIntegral (mt `shiftL` 5 .|. ai) + + +data DecodedToken a = DecodedToken !Int !a | DecodeFailure + deriving Show + +data LongToken a = Fits !a | TooLong !Int + deriving Show + + +-- 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 fromIntegral hdr :: Word 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 (eatTailWord8 bs) + 0x19 -> DecodedToken 3 (eatTailWord16 bs) + 0x1a -> DecodedToken 5 (eatTailWord32 bs) + 0x1b -> DecodedToken 9 (fromIntegral $ eatTailWord64 bs) -- TODO FIXME: overflow + _ -> DecodeFailure + + +{-# INLINE tryConsumeNegWord #-} +tryConsumeNegWord :: Word8 -> ByteString -> DecodedToken Word +tryConsumeNegWord hdr !bs = case fromIntegral hdr :: Word 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 (eatTailWord8 bs) + 0x39 -> DecodedToken 3 (eatTailWord16 bs) + 0x3a -> DecodedToken 5 (eatTailWord32 bs) + 0x3b -> DecodedToken 9 (fromIntegral $ eatTailWord64 bs) -- TODO FIXME: overflow + _ -> DecodeFailure + + +{-# INLINE tryConsumeInt #-} +tryConsumeInt :: Word8 -> ByteString -> DecodedToken Int +tryConsumeInt hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + + -- 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 - fromIntegral (eatTailWord8 bs)) + 0x39 -> DecodedToken 3 (-1 - fromIntegral (eatTailWord16 bs)) + 0x3a -> DecodedToken 5 (-1 - fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0x3b -> DecodedToken 9 (-1 - fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure + + +{-# INLINE tryConsumeInteger #-} +tryConsumeInteger :: Word8 -> ByteString -> DecodedToken (BigIntToken Integer) +tryConsumeInteger hdr !bs = case fromIntegral hdr :: Word of + + -- Positive integers (type 0) + 0x00 -> DecodedToken 1 (BigIntToken 0) + 0x01 -> DecodedToken 1 (BigIntToken 1) + 0x02 -> DecodedToken 1 (BigIntToken 2) + 0x03 -> DecodedToken 1 (BigIntToken 3) + 0x04 -> DecodedToken 1 (BigIntToken 4) + 0x05 -> DecodedToken 1 (BigIntToken 5) + 0x06 -> DecodedToken 1 (BigIntToken 6) + 0x07 -> DecodedToken 1 (BigIntToken 7) + 0x08 -> DecodedToken 1 (BigIntToken 8) + 0x09 -> DecodedToken 1 (BigIntToken 9) + 0x0a -> DecodedToken 1 (BigIntToken 10) + 0x0b -> DecodedToken 1 (BigIntToken 11) + 0x0c -> DecodedToken 1 (BigIntToken 12) + 0x0d -> DecodedToken 1 (BigIntToken 13) + 0x0e -> DecodedToken 1 (BigIntToken 14) + 0x0f -> DecodedToken 1 (BigIntToken 15) + 0x10 -> DecodedToken 1 (BigIntToken 16) + 0x11 -> DecodedToken 1 (BigIntToken 17) + 0x12 -> DecodedToken 1 (BigIntToken 18) + 0x13 -> DecodedToken 1 (BigIntToken 19) + 0x14 -> DecodedToken 1 (BigIntToken 20) + 0x15 -> DecodedToken 1 (BigIntToken 21) + 0x16 -> DecodedToken 1 (BigIntToken 22) + 0x17 -> DecodedToken 1 (BigIntToken 23) + 0x18 -> DecodedToken 2 (BigIntToken (fromIntegral (eatTailWord8 bs))) + 0x19 -> DecodedToken 3 (BigIntToken (fromIntegral (eatTailWord16 bs))) + 0x1a -> DecodedToken 5 (BigIntToken (fromIntegral (eatTailWord32 bs))) + 0x1b -> DecodedToken 9 (BigIntToken (fromIntegral (eatTailWord64 bs))) + + -- Negative integers (type 1) + 0x20 -> DecodedToken 1 (BigIntToken (-1)) + 0x21 -> DecodedToken 1 (BigIntToken (-2)) + 0x22 -> DecodedToken 1 (BigIntToken (-3)) + 0x23 -> DecodedToken 1 (BigIntToken (-4)) + 0x24 -> DecodedToken 1 (BigIntToken (-5)) + 0x25 -> DecodedToken 1 (BigIntToken (-6)) + 0x26 -> DecodedToken 1 (BigIntToken (-7)) + 0x27 -> DecodedToken 1 (BigIntToken (-8)) + 0x28 -> DecodedToken 1 (BigIntToken (-9)) + 0x29 -> DecodedToken 1 (BigIntToken (-10)) + 0x2a -> DecodedToken 1 (BigIntToken (-11)) + 0x2b -> DecodedToken 1 (BigIntToken (-12)) + 0x2c -> DecodedToken 1 (BigIntToken (-13)) + 0x2d -> DecodedToken 1 (BigIntToken (-14)) + 0x2e -> DecodedToken 1 (BigIntToken (-15)) + 0x2f -> DecodedToken 1 (BigIntToken (-16)) + 0x30 -> DecodedToken 1 (BigIntToken (-17)) + 0x31 -> DecodedToken 1 (BigIntToken (-18)) + 0x32 -> DecodedToken 1 (BigIntToken (-19)) + 0x33 -> DecodedToken 1 (BigIntToken (-20)) + 0x34 -> DecodedToken 1 (BigIntToken (-21)) + 0x35 -> DecodedToken 1 (BigIntToken (-22)) + 0x36 -> DecodedToken 1 (BigIntToken (-23)) + 0x37 -> DecodedToken 1 (BigIntToken (-24)) + 0x38 -> DecodedToken 2 (BigIntToken (-1 - fromIntegral (eatTailWord8 bs))) + 0x39 -> DecodedToken 3 (BigIntToken (-1 - fromIntegral (eatTailWord16 bs))) + 0x3a -> DecodedToken 5 (BigIntToken (-1 - fromIntegral (eatTailWord32 bs))) + 0x3b -> DecodedToken 9 (BigIntToken (-1 - fromIntegral (eatTailWord64 bs))) + + 0xc2 -> readBigUInt bs + 0xc3 -> readBigNInt bs + + _ -> DecodeFailure + + +{-# INLINE tryConsumeBytes #-} +tryConsumeBytes :: Word8 -> ByteString -> DecodedToken (LongToken ByteString) +tryConsumeBytes hdr !bs = case fromIntegral hdr :: Word 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 T.Text) +tryConsumeString hdr !bs = case fromIntegral hdr :: Word of + + -- Strings (type 3) + 0x60 -> readStringSmall 0 bs + 0x61 -> readStringSmall 1 bs + 0x62 -> readStringSmall 2 bs + 0x63 -> readStringSmall 3 bs + 0x64 -> readStringSmall 4 bs + 0x65 -> readStringSmall 5 bs + 0x66 -> readStringSmall 6 bs + 0x67 -> readStringSmall 7 bs + 0x68 -> readStringSmall 8 bs + 0x69 -> readStringSmall 9 bs + 0x6a -> readStringSmall 10 bs + 0x6b -> readStringSmall 11 bs + 0x6c -> readStringSmall 12 bs + 0x6d -> readStringSmall 13 bs + 0x6e -> readStringSmall 14 bs + 0x6f -> readStringSmall 15 bs + 0x70 -> readStringSmall 16 bs + 0x71 -> readStringSmall 17 bs + 0x72 -> readStringSmall 18 bs + 0x73 -> readStringSmall 19 bs + 0x74 -> readStringSmall 20 bs + 0x75 -> readStringSmall 21 bs + 0x76 -> readStringSmall 22 bs + 0x77 -> readStringSmall 23 bs + 0x78 -> readString8 bs + 0x79 -> readString16 bs + 0x7a -> readString32 bs + 0x7b -> readString64 bs + _ -> DecodeFailure + + +{-# INLINE tryConsumeListLen #-} +tryConsumeListLen :: Word8 -> ByteString -> DecodedToken Int +tryConsumeListLen hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure + + +{-# INLINE tryConsumeMapLen #-} +tryConsumeMapLen :: Word8 -> ByteString -> DecodedToken Int +tryConsumeMapLen hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure + + +{-# INLINE tryConsumeListLenIndef #-} +tryConsumeListLenIndef :: Word8 -> DecodedToken () +tryConsumeListLenIndef hdr = case fromIntegral hdr :: Word of + 0x9f -> DecodedToken 1 () + _ -> DecodeFailure + + +{-# INLINE tryConsumeMapLenIndef #-} +tryConsumeMapLenIndef :: Word8 -> DecodedToken () +tryConsumeMapLenIndef hdr = case fromIntegral hdr :: Word of + 0xbf -> DecodedToken 1 () + _ -> DecodeFailure + + +{-# INLINE tryConsumeListLenOrIndef #-} +tryConsumeListLenOrIndef :: Word8 -> ByteString -> DecodedToken Int +tryConsumeListLenOrIndef hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + 0x9f -> DecodedToken 1 (-1) -- indefinite length + _ -> DecodeFailure + + +{-# INLINE tryConsumeMapLenOrIndef #-} +tryConsumeMapLenOrIndef :: Word8 -> ByteString -> DecodedToken Int +tryConsumeMapLenOrIndef hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + 0xbf -> DecodedToken 1 (-1) -- indefinite length + _ -> DecodeFailure + + +{-# INLINE tryConsumeTag #-} +tryConsumeTag :: Word8 -> ByteString -> DecodedToken Word +tryConsumeTag hdr !bs = case fromIntegral hdr :: Word 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 (eatTailWord8 bs) + 0xd9 -> DecodedToken 3 (eatTailWord16 bs) + 0xda -> DecodedToken 5 (eatTailWord32 bs) + 0xdb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure + +-- +-- 64-on-32 bit code paths +-- + +#if defined(ARCH_32bit) +tryConsumeWord64 :: Word8 -> ByteString -> DecodedToken Word64 +tryConsumeWord64 hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) + 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure +{-# INLINE tryConsumeWord64 #-} + +tryConsumeNegWord64 :: Word8 -> ByteString -> DecodedToken Word64 +tryConsumeNegWord64 hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0x39 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0x3a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) + 0x3b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure +{-# INLINE tryConsumeNegWord64 #-} + +tryConsumeInt64 :: Word8 -> ByteString -> DecodedToken Int64 +tryConsumeInt64 hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0x19 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0x1a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0x1b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + + -- 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 - fromIntegral (eatTailWord8 bs)) + 0x39 -> DecodedToken 3 (-1 - fromIntegral (eatTailWord16 bs)) + 0x3a -> DecodedToken 5 (-1 - fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0x3b -> DecodedToken 9 (-1 - fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure +{-# INLINE tryConsumeInt64 #-} + +tryConsumeListLen64 :: Word8 -> ByteString -> DecodedToken Int64 +tryConsumeListLen64 hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0x99 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0x9a -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0x9b -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure +{-# INLINE tryConsumeListLen64 #-} + +tryConsumeMapLen64 :: Word8 -> ByteString -> DecodedToken Int64 +tryConsumeMapLen64 hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0xb9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0xba -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) -- TODO FIXME: overflow + 0xbb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure +{-# INLINE tryConsumeMapLen64 #-} + +tryConsumeTag64 :: Word8 -> ByteString -> DecodedToken Word64 +tryConsumeTag64 hdr !bs = case fromIntegral hdr :: Word 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 (fromIntegral (eatTailWord8 bs)) + 0xd9 -> DecodedToken 3 (fromIntegral (eatTailWord16 bs)) + 0xda -> DecodedToken 5 (fromIntegral (eatTailWord32 bs)) + 0xdb -> DecodedToken 9 (fromIntegral (eatTailWord64 bs)) -- TODO FIXME: overflow + _ -> DecodeFailure +{-# INLINE tryConsumeTag64 #-} +#endif + +{-# INLINE tryConsumeFloat #-} +tryConsumeFloat :: Word8 -> ByteString -> DecodedToken Float +tryConsumeFloat hdr !bs = case fromIntegral hdr :: Word 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 fromIntegral hdr :: Word 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 fromIntegral hdr :: Word of + 0xf4 -> DecodedToken 1 False + 0xf5 -> DecodedToken 1 True + _ -> DecodeFailure + + +{-# INLINE tryConsumeSimple #-} +tryConsumeSimple :: Word8 -> ByteString -> DecodedToken Word +tryConsumeSimple hdr !bs = case fromIntegral hdr :: Word 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 (eatTailWord8 bs) + _ -> DecodeFailure + + +{-# INLINE tryConsumeBytesIndef #-} +tryConsumeBytesIndef :: Word8 -> DecodedToken () +tryConsumeBytesIndef hdr = case fromIntegral hdr :: Word of + 0x5f -> DecodedToken 1 () + _ -> DecodeFailure + + +{-# INLINE tryConsumeStringIndef #-} +tryConsumeStringIndef :: Word8 -> DecodedToken () +tryConsumeStringIndef hdr = case fromIntegral hdr :: Word of + 0x7f -> DecodedToken 1 () + _ -> DecodeFailure + + +{-# INLINE tryConsumeNull #-} +tryConsumeNull :: Word8 -> DecodedToken () +tryConsumeNull hdr = case fromIntegral hdr :: Word of + 0xf6 -> DecodedToken 1 () + _ -> DecodeFailure + + +{-# INLINE tryConsumeBreakOr #-} +tryConsumeBreakOr :: Word8 -> DecodedToken () +tryConsumeBreakOr hdr = case fromIntegral hdr :: Word of + 0xff -> DecodedToken 1 () + _ -> DecodeFailure + + +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 $ + BS.unsafeTake n (BS.unsafeDrop hdrsz bs) + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 1 + +readBytes8, readBytes16, readBytes32, readBytes64 + :: ByteString -> DecodedToken (LongToken ByteString) + +readBytes8 bs + | n <= BS.length bs - hdrsz + = DecodedToken (n+hdrsz) $ Fits $ + BS.unsafeTake n (BS.unsafeDrop hdrsz bs) + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 2 + n = fromIntegral (eatTailWord8 bs) + +readBytes16 bs + | n <= BS.length bs - hdrsz + = DecodedToken (n+hdrsz) $ Fits $ + BS.unsafeTake n (BS.unsafeDrop hdrsz bs) + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 3 + n = fromIntegral (eatTailWord16 bs) + +readBytes32 bs + | n <= BS.length bs - hdrsz + = DecodedToken (n+hdrsz) $ Fits $ + BS.unsafeTake n (BS.unsafeDrop hdrsz bs) + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 5 + -- TODO FIXME: int overflow + n = fromIntegral (eatTailWord32 bs) + +readBytes64 bs + | n <= BS.length bs - hdrsz + = DecodedToken (n+hdrsz) $ Fits $ + BS.unsafeTake n (BS.unsafeDrop hdrsz bs) + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 5 + -- TODO FIXME: int overflow + n = fromIntegral (eatTailWord64 bs) + + +readStringSmall :: Int -> ByteString -> DecodedToken (LongToken T.Text) +readStringSmall n bs + -- if n <= bound then ok return it all + | n + hdrsz <= BS.length bs + = DecodedToken (n+hdrsz) $ Fits $ + T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) + -- TODO FIXME: utf8 validation + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 1 + +readString8, readString16, + readString32, readString64 :: ByteString -> DecodedToken (LongToken T.Text) +readString8 bs + | n <= BS.length bs - hdrsz + = DecodedToken (n+hdrsz) $ Fits $ + T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) + -- TODO FIXME: utf8 validation + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 2 + n = fromIntegral (eatTailWord8 bs) + +readString16 bs + | n <= BS.length bs - hdrsz + = DecodedToken (n+hdrsz) $ Fits $ + T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) + -- TODO FIXME: utf8 validation + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 3 + n = fromIntegral (eatTailWord16 bs) + +readString32 bs + | n <= BS.length bs - hdrsz + = DecodedToken (n+hdrsz) $ Fits $ + T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) + -- TODO FIXME: utf8 validation + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 5 + -- TODO FIXME: int overflow + n = fromIntegral (eatTailWord32 bs) + +readString64 bs + | n <= BS.length bs - hdrsz + = DecodedToken (n+hdrsz) $ Fits $ + T.decodeUtf8 (BS.unsafeTake n (BS.unsafeDrop hdrsz bs)) + -- TODO FIXME: utf8 validation + + -- if n > bound then slow path, multi-chunk + | otherwise + = DecodedToken hdrsz $ TooLong n + where + hdrsz = 5 + -- TODO FIXME: int overflow + n = fromIntegral (eatTailWord64 bs) + + +------------------------------------------------------------------------------ +-- Reading big integers +-- + +-- 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. + +data BigIntToken a = BigIntToken Integer + | BigUIntNeedBody Int + | BigNIntNeedBody 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 + +-- 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) + +-- 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 bstr) -> DecodedToken (1+sz) (BigIntToken (uintegerFromBytes bstr)) + DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigUIntNeedBody 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 bstr) -> DecodedToken (1+sz) (BigIntToken (nintegerFromBytes bstr)) + DecodedToken sz (TooLong len) -> DecodedToken (1+sz) (BigNIntNeedBody len) + + | otherwise + = DecodedToken 1 BigNIntNeedHeader diff --git a/src/Codec/CBOR/Term.hs b/src/Codec/CBOR/Term.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Term.hs @@ -0,0 +1,251 @@ +{-# 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) + diff --git a/src/Codec/CBOR/Write.hs b/src/Codec/CBOR/Write.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Write.hs @@ -0,0 +1,590 @@ +{-# 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 +import Data.Monoid +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 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' + + 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) + +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 + +{- + 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 + +halfMP :: P.BoundedPrim Float +halfMP = floatToWord16 >$< + withConstHeader 0xf9 P.word16BE + +floatMP :: P.BoundedPrim Float +floatMP = withConstHeader 0xfa P.floatBE + +doubleMP :: P.BoundedPrim Double +doubleMP = 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 diff --git a/src/cbits/cbor.h b/src/cbits/cbor.h new file mode 100644 --- /dev/null +++ b/src/cbits/cbor.h @@ -0,0 +1,48 @@ +/* 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