diff --git a/Data/BufferBuilder.hs b/Data/BufferBuilder.hs deleted file mode 100644 --- a/Data/BufferBuilder.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE OverloadedStrings, MagicHash, UnboxedTuples, BangPatterns, GeneralizedNewtypeDeriving #-} - -{-| -A library for efficiently building up a buffer of data. When given data -known to be strict, use of BufferBuilder compiles directly into a series -of efficient C function calls. --} -module Data.BufferBuilder ( - - -- * The BufferBuilder Monad - BufferBuilder - , runBufferBuilder - - -- * Appending bytes and byte strings - , appendByte - , appendChar8 - , appendBS - , appendLBS - , appendLiteral - , unsafeAppendLiteralN - - -- * Appending bytes and byte strings, truncated to 7 bits - , appendByte7 - , appendChar7 - , appendBS7 - , appendLiteral7 - , unsafeAppendLiteralN7 - - -- * UTF-8 encoding - , appendCharUtf8 - , appendStringUtf8 - - -- * Printing numbers - , appendDecimalSignedInt - , appendDecimalDouble - - -- * JSON escaping - , appendEscapedJson - , appendEscapedJsonLiteral - , appendEscapedJsonText - ) where - -import GHC.Base -import GHC.Word -import GHC.Ptr -import GHC.IO -import GHC.ForeignPtr -import Foreign.ForeignPtr -import Foreign.Marshal.Alloc -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Lazy as BSL -import Control.Monad.Reader -import Control.Applicative (Applicative) - -import Data.Text () -- Show -import Data.Text.Internal (Text (..)) -import Data.Text.Array (Array (..)) - -data Handle' -type Handle = Ptr Handle' - -foreign import ccall unsafe "strlen" c_strlen :: Ptr Word8 -> IO Int -foreign import ccall unsafe "bw_new" bw_new :: Int -> IO Handle -foreign import ccall unsafe "&bw_free" bw_free :: FunPtr (Handle -> IO ()) -foreign import ccall unsafe "bw_get_size" bw_get_size :: Handle -> IO Int -foreign import ccall unsafe "bw_trim_and_release_address" bw_trim_and_release_address :: Handle -> IO (Ptr Word8) - -foreign import ccall unsafe "bw_append_byte" bw_append_byte :: Handle -> Word8 -> IO () -foreign import ccall unsafe "bw_append_char_utf8" bw_append_char_utf8 :: Handle -> Char -> IO () -foreign import ccall unsafe "bw_append_bs" bw_append_bs :: Handle -> Int -> Ptr Word8 -> IO () -foreign import ccall unsafe "bw_append_bsz" bw_append_bsz :: Handle -> Ptr Word8 -> IO () - -foreign import ccall unsafe "bw_append_byte7" bw_append_byte7 :: Handle -> Word8 -> IO () -foreign import ccall unsafe "bw_append_bs7" bw_append_bs7 :: Handle -> Int -> Ptr Word8 -> IO () -foreign import ccall unsafe "bw_append_bsz7" bw_append_bsz7 :: Handle -> Ptr Word8 -> IO () - -foreign import ccall unsafe "bw_append_decimal_signed_int" bw_append_decimal_signed_int :: Handle -> Int -> IO () -foreign import ccall unsafe "bw_append_decimal_double" bw_append_decimal_double :: Handle -> Double -> IO () - -foreign import ccall unsafe "bw_append_json_escaped" bw_append_json_escaped :: Handle -> Int -> Ptr Word8 -> IO () -foreign import ccall unsafe "bw_append_json_escaped_utf16" bw_append_json_escaped_utf16 :: Handle -> Int -> Ptr Word16 -> IO () - --- | BufferBuilder is the type of a monadic action that appends to an implicit, --- growable buffer. Use 'runBufferBuilder' to extract the resulting --- buffer as a 'BS.ByteString'. -newtype BufferBuilder a = BB (ReaderT Handle IO a) - deriving (Functor, Applicative, Monad, MonadReader Handle) - -inBW :: IO a -> BufferBuilder a -inBW = BB . lift -{-# INLINE inBW #-} - -withHandle :: (Handle -> IO ()) -> BufferBuilder () -withHandle action = do - h <- ask - inBW $ action h -{-# INLINE withHandle #-} - -initialCapacity :: Int -initialCapacity = 20480 --- why 48? it's only 6 64-bit words... yet many small strings should fit. --- some quantitative analysis would be good. --- an option to set the initial capacity would be better. :) - --- | Run a sequence of 'BufferBuilder' actions and extract the resulting --- buffer as a 'BS.ByteString'. -runBufferBuilder :: BufferBuilder () -> BS.ByteString -runBufferBuilder = unsafeDupablePerformIO . runBufferBuilderIO initialCapacity - -runBufferBuilderIO :: Int -> BufferBuilder () -> IO BS.ByteString -runBufferBuilderIO !capacity !(BB bw) = do - handle <- bw_new capacity - handleFP <- newForeignPtr bw_free handle - () <- runReaderT bw handle - size <- bw_get_size handle - src <- bw_trim_and_release_address handle - - borrowed <- newForeignPtr finalizerFree src - let bs = BS.fromForeignPtr borrowed 0 size - touchForeignPtr handleFP - return bs - --- | Append a single byte to the output buffer. To append multiple bytes in sequence and --- avoid redundant bounds checks, consider using 'appendBS', 'appendLiteral', or 'unsafeAppendLiteralN'. -appendByte :: Word8 -> BufferBuilder () -appendByte b = withHandle $ \h -> bw_append_byte h b -{-# INLINE appendByte #-} - -c2w :: Char -> Word8 -c2w = fromIntegral . ord -{-# INLINE c2w #-} - --- | Appends a character to the buffer, truncating it to the bottom 8 bits. -appendChar8 :: Char -> BufferBuilder () -appendChar8 = appendByte . c2w -{-# INLINE appendChar8 #-} - --- | Appends a 'BS.ByteString' to the buffer. When appending constant, hardcoded strings, to --- avoid a CAF and the costs of its associated tag check and indirect jump, use --- 'appendLiteral' or 'unsafeAppendLiteralN' instead. -appendBS :: BS.ByteString -> BufferBuilder () -appendBS !(BS.PS fp offset len) = - withHandle $ \h -> - withForeignPtr fp $ \addr -> - bw_append_bs h len (plusPtr addr offset) -{-# INLINE appendBS #-} - --- | Appends a lazy 'BSL.ByteString' to the buffer. This function operates by traversing --- the lazy 'BSL.ByteString' chunks, appending each in turn. -appendLBS :: BSL.ByteString -> BufferBuilder () -appendLBS lbs = mapM_ appendBS $ BSL.toChunks lbs -{-# INLINABLE appendLBS #-} - --- | Appends a zero-terminated MagicHash string literal. Use this function instead of --- 'appendBS' for string constants. For example: --- --- > appendLiteral "true"# --- --- If the length of the string literal is known, calling --- 'unsafeAppendLiteralN' is faster, as 'unsafeAppendLiteralN' avoids a strlen --- operation which has nontrivial cost in some benchmarks. -appendLiteral :: Addr# -> BufferBuilder () -appendLiteral addr = - withHandle $ \h -> - bw_append_bsz h (Ptr addr) -{-# INLINE appendLiteral #-} - --- | Appends a MagicHash string literal with a known length. Use this when the --- string literal's length is known. For example: --- --- > unsafeAppendLiteralN 4 "true"# --- --- Per byte, this is the fastest append function. It amounts to a C function call --- with two constant arguments. The C function checks to see if it needs to grow --- the buffer and then it simply calls memcpy. --- --- __WARNING__: passing an incorrect length value is likely to cause an access --- violation or worse. -unsafeAppendLiteralN :: Int -> Addr# -> BufferBuilder () -unsafeAppendLiteralN len addr = - withHandle $ \h -> - bw_append_bs h len (Ptr addr) -{-# INLINE unsafeAppendLiteralN #-} - - --- 7-bit truncation - -appendByte7 :: Word8 -> BufferBuilder () -appendByte7 b = withHandle $ \h -> bw_append_byte7 h b -{-# INLINE appendByte7 #-} - -appendChar7 :: Char -> BufferBuilder () -appendChar7 = appendByte7 . c2w -{-# INLINE appendChar7 #-} - -appendBS7 :: BS.ByteString -> BufferBuilder () -appendBS7 !(BS.PS fp offset len) = - withHandle $ \h -> - withForeignPtr fp $ \addr -> - bw_append_bs7 h len (plusPtr addr offset) -{-# INLINE appendBS7 #-} - -appendLiteral7 :: Addr# -> BufferBuilder () -appendLiteral7 addr = - withHandle $ \h -> - bw_append_bsz7 h (Ptr addr) -{-# INLINE appendLiteral7 #-} - -unsafeAppendLiteralN7 :: Int -> Addr# -> BufferBuilder () -unsafeAppendLiteralN7 len addr = - withHandle $ \h -> - bw_append_bs7 h len (Ptr addr) -{-# INLINE unsafeAppendLiteralN7 #-} - --- Encoding UTF-8 - --- | Appends a UTF-8-encoded 'Char' to the buffer. -appendCharUtf8 :: Char -> BufferBuilder () -appendCharUtf8 c = withHandle $ \h -> bw_append_char_utf8 h c -{-# INLINE appendCharUtf8 #-} - --- | Appends a UTF-8-encoded 'String' to the buffer. The best way to improve performance here --- is to use 'BS.ByteString' or 'Text' instead of 'String'. -appendStringUtf8 :: String -> BufferBuilder () -appendStringUtf8 = mapM_ appendCharUtf8 -{-# INLINABLE appendStringUtf8 #-} - - --- Printing Numbers - --- | Appends a decimal integer, just like calling printf("%d", ...) -appendDecimalSignedInt :: Int -> BufferBuilder () -appendDecimalSignedInt i = - withHandle $ \h -> - bw_append_decimal_signed_int h i -{-# INLINE appendDecimalSignedInt #-} - --- | Appends a decimal double, just like calling printf("%f", ...) -appendDecimalDouble :: Double -> BufferBuilder () -appendDecimalDouble d = - withHandle $ \h -> - bw_append_decimal_double h d -{-# INLINE appendDecimalDouble #-} - - --- Encoding JSON - -appendEscapedJson :: BS.ByteString -> BufferBuilder () -appendEscapedJson !(BS.PS (ForeignPtr addr _) offset len) = - withHandle $ \h -> - bw_append_json_escaped h len (plusPtr (Ptr addr) offset) -{-# INLINE appendEscapedJson #-} - -appendEscapedJsonLiteral :: Addr# -> BufferBuilder () -appendEscapedJsonLiteral addr = - withHandle $ \h -> do - len <- c_strlen (Ptr addr) - bw_append_json_escaped h len (Ptr addr) -{-# INLINE appendEscapedJsonLiteral #-} - -appendEscapedJsonText :: Text -> BufferBuilder () -appendEscapedJsonText !(Text arr ofs len) = - let byteArray = aBA arr - in withHandle $ \h -> - bw_append_json_escaped_utf16 h len (Ptr (byteArrayContents# byteArray) `plusPtr` ofs) -{-# INLINE appendEscapedJsonText #-} diff --git a/Data/BufferBuilder/Json.hs b/Data/BufferBuilder/Json.hs deleted file mode 100644 --- a/Data/BufferBuilder/Json.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns, UndecidableInstances #-} - -{-| -A library for efficiently building up a valid JSON document. - -The difference between "Data.BufferBuilder.Json" and the excellent -"Data.Aeson" is that Aeson represents the JSON document as an -in-memory tree structure before encoding it into bytes. This module, -on the other hand, represents each value as an action that writes its -representation directly into the output buffer. At the cost of -reduced flexibility, this results in significantly improved encoding -performance. At the time of this writing, encoding a custom record -type into JSON using this module was almost 5x faster than using -Aeson. - -This module is built on top of "Data.Utf8Builder". --} -module Data.BufferBuilder.Json - ( - -- * Encoding Values - Value - , ToJson (..) - , encodeJson - - -- * Objects - , ObjectBuilder - , emptyObject - , (.=) - , (.=#) - - -- * Arrays - , array - - -- * Null - , nullValue - - -- * Unsafe - , unsafeAppendBS - , unsafeAppendUtf8Builder - ) where - -import GHC.Base -import Foreign.Storable -import Control.Monad (when, forM_) -import Data.BufferBuilder.Utf8 (Utf8Builder) -import qualified Data.BufferBuilder.Utf8 as UB -import Data.ByteString (ByteString) -import Data.Monoid -import Data.Text (Text) -import Data.Foldable (Foldable, foldMap) -import qualified Data.Vector as Vector -import qualified Data.Vector.Generic as GVector -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Unboxed as VU -import qualified Data.HashMap.Strict as HashMap - --- | Represents a JSON value. --- --- 'Value's are built up from either 'ToJson' instances or --- from primitives like 'emptyObject', 'array', and 'null'. --- --- In special cases, or when performance is of utmost importance, the --- unsafe functions 'unsafeAppendBS' and 'unsafeAppendUtf8Builder' are --- available. --- --- Internally, Value encodes an action or sequence of actions that append --- JSON-encoded text to the underlying 'Utf8Builder'. -newtype Value = Value { utf8Builder :: Utf8Builder () } - --- | The class of types that can be converted to JSON values. See --- 'ObjectBuilder' for an example of writing a 'ToJson' instance for a --- custom data type. --- --- 'ToJson' instances are provided for many common types. For --- example, to create a JSON array, call 'toJson' on a list or 'Vector.Vector'. --- To create a JSON object, call 'toJson' on a 'HashMap.HashMap'. -class ToJson a where - toJson :: a -> Value - ----- General JSON value support - --- | Encode a value into a 'ByteString' containing valid UTF-8-encoded JSON. --- The argument value must have a corresponding 'ToJson' instance. --- --- __WARNING__: There are three cases where the resulting 'ByteString' may not contain --- legal JSON: --- --- * An unsafe function was used to encode a JSON value. --- * The root value is not an object or array, as the JSON specification requires. --- * An object has multiple keys with the same value. For maximum efficiency, --- 'ObjectBuilder' does not check key names for uniqueness, so it's possible to --- construct objects with duplicate keys. -encodeJson :: ToJson a => a -> ByteString -encodeJson = UB.runUtf8Builder . utf8Builder . toJson -{-# INLINE encodeJson #-} - ----- Objects - --- | Builds a JSON object. --- --- An 'ObjectBuilder' builds one or more key-value pairs of a JSON object. They are constructed with the '.=' operator and --- combined with 'Data.Monoid.<>'. --- --- To turn an 'ObjectBuilder' into a 'Value', use its 'ToJson' class instance. --- --- @ --- data Friend = Friend --- { fId :: !Int --- , fName :: !Text --- } deriving (Eq, Show) --- --- instance ToJson Friend where --- toJson friend = toJson $ --- "id" .= fId friend --- <> "name" .= fName friend --- @ --- --- __WARNING__: 'ObjectBuilder' does not check uniqueness of object --- keys. If two keys with the same value are inserted, then the --- resulting JSON document will be illegal. -data ObjectBuilder = NoPair | Pair !(Utf8Builder ()) - -instance Monoid ObjectBuilder where - {-# INLINE mempty #-} - mempty = NoPair - - {-# INLINE mappend #-} - mappend NoPair a = a - mappend a NoPair = a - mappend (Pair a) (Pair b) = Pair $ do - a - UB.appendChar7 ',' - b - -instance ToJson ObjectBuilder where - {-# INLINE toJson #-} - toJson NoPair = Value $ do - UB.appendChar7 '{' - UB.appendChar7 '}' - - toJson (Pair a) = Value $ do - UB.appendChar7 '{' - a - UB.appendChar7 '}' - --- | A 'Value' that produces the empty object. -emptyObject :: Value -emptyObject = toJson NoPair -{-# INLINE emptyObject #-} - --- | Create an 'ObjectBuilder' from a key and a value. -(.=) :: ToJson a => Text -> a -> ObjectBuilder -a .= b = Pair $ do - UB.appendEscapedJsonText a - UB.appendChar7 ':' - utf8Builder $ toJson b -infixr 8 .= -{-# INLINE (.=) #-} - --- | Create an 'ObjectBuilder' from a key and a value. The key is an --- ASCII-7, unescaped, zero-terminated 'Addr#'. --- --- __WARNING__: This function is unsafe. If the key is NOT --- zero-terminated, then an access violation might result. If the key --- is not a sequence of unescaped ASCII characters, the resulting JSON --- document will be illegal. --- --- This function is provided for maximum performance in the common --- case that object keys are ASCII-7. It achieves performance by --- avoiding the CAF for a Text literal and avoiding the need to --- transcode UTF-16 to UTF-8 and escape. --- --- To use this function, the calling source file must have the --- MagicHash extension enabled. --- --- @ --- data Friend = Friend --- { fId :: !Int --- , fName :: !Text --- } deriving (Eq, Show) --- --- instance ToJson Friend where --- toJson friend = toJson $ --- "id"\# .=\# fId friend --- <> "name"\# .=\# fName friend --- @ -(.=#) :: ToJson a => Addr# -> a -> ObjectBuilder -a .=# b = Pair $ do - UB.appendEscapedJsonLiteral a - UB.appendChar7 ':' - utf8Builder $ toJson b -infixr 8 .=# -{-# INLINE (.=#) #-} - - -{-# INLINE writePair #-} -writePair :: ToJson a => (Text, a) -> Utf8Builder () -writePair (key, value) = do - UB.appendEscapedJsonText key - UB.appendChar7 ':' - utf8Builder $ toJson value - -instance ToJson a => ToJson (HashMap.HashMap Text a) where - {-# INLINABLE toJson #-} - toJson hm = Value $ do - UB.appendChar7 '{' - case HashMap.toList hm of - [] -> UB.appendChar7 '}' - (x:xs) -> do - writePair x - forM_ xs $ \p -> do - UB.appendChar7 ',' - writePair p - UB.appendChar7 '}' - ----- Arrays - --- | Serialize any 'Foldable' as a JSON array. This is generally --- slower than directly calling 'toJson' on a list or 'Vector.Vector', --- but it will convert any 'Foldable' type into an array. -array :: (Foldable t, ToJson a) => t a -> Value -array collection = Value $ do - UB.appendChar7 '[' - -- HACK: ObjectBuilder is not "type correct" but it has exactly the behaviour we want for this function. - case foldMap (Pair . utf8Builder . toJson) collection of - NoPair -> return () - (Pair b) -> b - UB.appendChar7 ']' -{-# INLINABLE array #-} - -instance ToJson a => ToJson [a] where - {-# INLINABLE toJson #-} - toJson !ls = Value $ do - UB.appendChar7 '[' - case ls of - [] -> UB.appendChar7 ']' - x:xs -> do - utf8Builder $ toJson x - forM_ xs $ \(!e) -> do - UB.appendChar7 ',' - utf8Builder $ toJson e - UB.appendChar7 ']' - -instance ToJson a => ToJson (Vector.Vector a) where - {-# INLINABLE toJson #-} - toJson = vector - -instance (Storable a, ToJson a) => ToJson (VS.Vector a) where - {-# INLINABLE toJson #-} - toJson = vector - -instance (VP.Prim a, ToJson a) => ToJson (VP.Vector a) where - {-# INLINABLE toJson #-} - toJson = vector - -instance (GVector.Vector VU.Vector a, ToJson a) => ToJson (VU.Vector a) where - {-# INLINABLE toJson #-} - toJson = vector - -{-# INLINABLE vector #-} -vector :: (GVector.Vector v a, ToJson a) => v a -> Value -vector !vec = Value $ do - UB.appendChar7 '[' - let len = GVector.length vec - when (len /= 0) $ do - utf8Builder $ toJson (vec `GVector.unsafeIndex` 0) - GVector.forM_ (GVector.tail vec) $ \e -> do - UB.appendChar7 ',' - utf8Builder $ toJson e - UB.appendChar7 ']' - - ----- - --- | Represents a JSON "null". -nullValue :: Value -nullValue = Value $ UB.unsafeAppendLiteralN 4 "null"# -{-# INLINE nullValue #-} - ----- Common JSON instances - -instance ToJson Value where - {-# INLINE toJson #-} - toJson = id - -instance ToJson Bool where - {-# INLINE toJson #-} - toJson True = Value $ UB.unsafeAppendLiteralN 4 "true"# - toJson False = Value $ UB.unsafeAppendLiteralN 5 "false"# - -instance ToJson a => ToJson (Maybe a) where - {-# INLINE toJson #-} - toJson m = case m of - Nothing -> Value $ UB.unsafeAppendLiteralN 4 "null"# - Just a -> toJson a - -instance ToJson Text where - {-# INLINE toJson #-} - toJson txt = Value $ UB.appendEscapedJsonText txt - -instance ToJson Double where - {-# INLINE toJson #-} - toJson a = Value $ UB.appendDecimalDouble a - -instance ToJson Int where - {-# INLINE toJson #-} - toJson a = Value $ UB.appendDecimalSignedInt a - - ----- Unsafe functions - --- | Unsafely append a string into a JSON document. --- This function does /not/ escape, quote, or otherwise decorate the string in any way. --- This function is /unsafe/ because you can trivially use it to generate illegal JSON. -unsafeAppendBS :: ByteString -> Value -unsafeAppendBS bs = Value $ UB.unsafeAppendBS bs - --- | Unsafely append a 'Utf8Builder' into a JSON document. --- This function does not escape, quote, or decorate the string in any way. --- This function is /unsafe/ because you can trivially use it to generate illegal JSON. -unsafeAppendUtf8Builder :: Utf8Builder () -> Value -unsafeAppendUtf8Builder utf8b = Value utf8b diff --git a/Data/BufferBuilder/Utf8.hs b/Data/BufferBuilder/Utf8.hs deleted file mode 100644 --- a/Data/BufferBuilder/Utf8.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, MagicHash, BangPatterns #-} - -{-| -A library for efficiently building up a buffer of UTF-8-encoded text. If only -safe functions are used, the resulting 'ByteString' is guaranteed to be valid -UTF-8. - -To run a sequence of Utf8Builder actions and retrieve the resulting buffer, use -'runUtf8Builder'. - -In special situations, for maximum performance, unsafe functions are -also provided. The unsafe functions do not guarantee the buffer is -correct UTF-8. - -This module is built on top of "Data.BufferBuilder". --} -module Data.BufferBuilder.Utf8 ( - - -- * The Utf8Builder Monad - Utf8Builder - , runUtf8Builder - - -- * Text encoding - , appendText - , appendString - , appendChar - - -- * ASCII-7 - , appendByte7 - , appendChar7 - , appendBS7 - , appendLiteral7 - - -- * Printing numbers - , appendDecimalSignedInt - , appendDecimalDouble - - -- * Escaped JSON - , appendEscapedJson - , appendEscapedJsonLiteral - , appendEscapedJsonText - - -- * Unsafe append operations - , unsafeAppendByte - , unsafeAppendChar8 - , unsafeAppendLiteral - , unsafeAppendLiteralN - , unsafeAppendBS - ) where - -import GHC.Base -import GHC.Word -import Control.Applicative -import Data.ByteString (ByteString) -import Data.BufferBuilder (BufferBuilder) -import qualified Data.BufferBuilder as BB -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) - -newtype Utf8Builder a = Utf8Builder { unBuilder :: BufferBuilder a } - deriving (Functor, Applicative, Monad) - --- | Run a sequence of 'Utf8Builder' actions and extracting the resulting --- buffer as a 'ByteString'. -runUtf8Builder :: Utf8Builder () -> ByteString -runUtf8Builder a = BB.runBufferBuilder $ unBuilder a -{-# INLINE runUtf8Builder #-} - - --- Text encoding - --- TODO: optimize appendText with custom UTF-16 -> UTF-8 encoder in C - --- | Encodes the given 'Text' in UTF-8, appending it to the buffer. -appendText :: Text -> Utf8Builder () -appendText a = Utf8Builder $ BB.appendBS $ encodeUtf8 a -{-# INLINE appendText #-} - --- | Encodes the given 'String' in UTF-8, appending it to the buffer. -appendString :: String -> Utf8Builder () -appendString s = mapM_ appendChar s -{-# INLINABLE appendString #-} - --- | Encodes a single 'Char' in UTF-8, appending it to the buffer. -appendChar :: Char -> Utf8Builder () -appendChar c = Utf8Builder $ BB.appendCharUtf8 c -{-# INLINE appendChar #-} - - --- ASCII-7 - --- | Appends the bottom 7 bits of a byte to the buffer. -appendByte7 :: Word8 -> Utf8Builder () -appendByte7 = Utf8Builder . BB.appendByte7 -{-# INLINE appendByte7 #-} - --- | Appends the bottom 7 bits of a 'Char' to the buffer. -appendChar7 :: Char -> Utf8Builder () -appendChar7 = Utf8Builder . BB.appendChar7 -{-# INLINE appendChar7 #-} - --- | Appends the given ByteString to the buffer, taking the bottom --- 7 bits of each byte. -appendBS7 :: ByteString -> Utf8Builder () -appendBS7 = Utf8Builder . BB.appendBS7 -{-# INLINE appendBS7 #-} - --- | Appends the zero-terminated byte string at the given address --- to the buffer, taking the bottom 7 bits of each byte. -appendLiteral7 :: Addr# -> Utf8Builder () -appendLiteral7 addr = Utf8Builder $ BB.appendLiteral7 addr -{-# INLINE appendLiteral7 #-} - - --- Printing numbers - -appendDecimalSignedInt :: Int -> Utf8Builder () -appendDecimalSignedInt a = Utf8Builder $ BB.appendDecimalSignedInt a -{-# INLINE appendDecimalSignedInt #-} - -appendDecimalDouble :: Double -> Utf8Builder () -appendDecimalDouble d = Utf8Builder $ BB.appendDecimalDouble d -{-# INLINE appendDecimalDouble #-} - - --- Escaped JSON - -appendEscapedJsonLiteral :: Addr# -> Utf8Builder () -appendEscapedJsonLiteral addr = Utf8Builder $ BB.appendEscapedJsonLiteral addr - -appendEscapedJson :: ByteString -> Utf8Builder () -appendEscapedJson a = Utf8Builder $ BB.appendEscapedJson a -{-# INLINE appendEscapedJson #-} - -appendEscapedJsonText :: Text -> Utf8Builder () -appendEscapedJsonText txt = Utf8Builder $ BB.appendEscapedJsonText txt -{-# INLINE appendEscapedJsonText #-} - - --- Unsafe - --- | Directly append a byte into the UTF-8 code stream. Incorrect use of --- this function can result in invalid UTF-8. -unsafeAppendByte :: Word8 -> Utf8Builder () -unsafeAppendByte = Utf8Builder . BB.appendByte -{-# INLINE unsafeAppendByte #-} - --- | Directly append the bottom 8 bits of the given character to the UTF-8 --- code stream. Incorrect use of this function can result in invalid UTF-8. -unsafeAppendChar8 :: Char -> Utf8Builder () -unsafeAppendChar8 = Utf8Builder . BB.appendChar8 -{-# INLINE unsafeAppendChar8 #-} - --- | Directly append the zero-terminated byte sequence pointed to by --- the given address. Be careful that the referenced byte sequence --- contains valid UTF-8. -unsafeAppendLiteral :: Addr# -> Utf8Builder () -unsafeAppendLiteral addr = Utf8Builder $ BB.appendLiteral addr -{-# INLINE unsafeAppendLiteral #-} - --- | Directly append the given byte sequence pointed to by the given address. --- Be careful that the referenced byte sequence contains valid UTF-8. --- --- __WARNING__: passing an incorrect length value is likely to cause an access --- violation or worse. -unsafeAppendLiteralN :: Int -> Addr# -> Utf8Builder () -unsafeAppendLiteralN !len addr = Utf8Builder $ BB.unsafeAppendLiteralN len addr -{-# INLINE unsafeAppendLiteralN #-} - --- | Directly append the given 'ByteString' to the output buffer. --- Be careful that the referenced 'ByteString' contains valid UTF-8. -unsafeAppendBS :: ByteString -> Utf8Builder () -unsafeAppendBS a = Utf8Builder $ BB.appendBS a -{-# INLINE unsafeAppendBS #-} diff --git a/bench/JsonBench.hs b/bench/JsonBench.hs --- a/bench/JsonBench.hs +++ b/bench/JsonBench.hs @@ -4,21 +4,18 @@ module Main (main) where +import Control.DeepSeq (NFData (..), force) import Criterion - import Criterion.Main - +import Data.Aeson ((.:)) import Data.Monoid ((<>)) - +import Data.Text (Text) +import qualified Data.Aeson as Aeson +import qualified Data.BufferBuilder.Json as Json import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL - -import qualified Data.BufferBuilder.Json as Json -import Data.Text (Text) -import qualified Data.Aeson as Aeson -import Data.Aeson ((.:)) +import qualified Data.Json.Builder as JB import qualified Data.Vector as Vector -import Control.DeepSeq (NFData (..), force) import qualified Data.Vector.Unboxed as UnboxedVector data EyeColor = Green | Blue | Brown @@ -224,6 +221,60 @@ <> "greeting"# Json..=# uGreeting <> "favoriteFruit"# Json..=# uFavouriteFruit +---- json-builder instances ---- + +instance JB.Value EyeColor where + toJson ec = JB.toJson $ case ec of + Green -> "green" :: Text + Blue -> "blue" + Brown -> "brown" + +instance JB.Value Gender where + toJson g = JB.toJson $ case g of + Male -> "male" :: Text + Female -> "female" + +instance JB.Value Fruit where + toJson f = JB.toJson $ case f of + Apple -> "apple" :: Text + Strawberry -> "strawberry" + Banana -> "banana" + +instance JB.Value Friend where + toJson Friend{..} = JB.toJson $ + ("_id" :: Text) `JB.row` fId + <> ("name" :: Text) `JB.row` fName + +instance JB.Value User where + toJson User{..} = + let t :: Text -> Text + t = id + in JB.toJson $ + t "_id" `JB.row` uId + <> t "index" `JB.row` uIndex + <> t "guid" `JB.row` uGuid + <> t "isActive" `JB.row` uIsActive + <> t "balance" `JB.row` uBalance + <> t "picture" `JB.row` uPicture + <> t "age" `JB.row` uAge + <> t "eyeColor" `JB.row` uEyeColor + <> t "name" `JB.row` uName + <> t "gender" `JB.row` uGender + <> t "company" `JB.row` uCompany + <> t "email" `JB.row` uEmail + <> t "phone" `JB.row` uPhone + <> t "address" `JB.row` uAddress + <> t "about" `JB.row` uAbout + <> t "registered" `JB.row` uRegistered + <> t "latitude" `JB.row` uLatitude + <> t "longitude" `JB.row` uLongitude + <> t "tags" `JB.row` uTags + <> t "friends" `JB.row` uFriends + <> t "greeting" `JB.row` uGreeting + <> t "favoriteFruit" `JB.row` uFavouriteFruit + +---- + encodeUserNaively :: User -> Json.Value encodeUserNaively User{..} = Json.toJson $ @@ -277,6 +328,7 @@ , bgroup "render" [ bench "bufferbuilder" $ nf Json.encodeJson parsedUserList , bench "aeson" $ nf Aeson.encode parsedUserList + , bench "json-builder" $ nf JB.toJsonLBS parsedUserList ] , bgroup "addr vs text keys" [ bench "addr" $ nf Json.encodeJson parsedUserList diff --git a/bench/UrlBench.hs b/bench/UrlBench.hs new file mode 100644 --- /dev/null +++ b/bench/UrlBench.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} + +module Main (main) where + +import qualified Data.BufferBuilder as BB +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Char8 as BSC +import Criterion +import Criterion.Main +import Data.Word (Word16) +import Data.Monoid +import Control.Monad +import Network.HTTP.Types (urlEncode) + +type Protocol = BS.ByteString +type PathPiece = BS.ByteString + +type Hash = BS.ByteString + +data SMaybe a = SNothing | SJust !a + deriving (Eq, Show, Ord) + +data UrlHost = UrlHost + { uhHostName :: !BS.ByteString + , uhPort :: {-# UNPACK #-} !Word16 -- 0 = no port + , uhUserName :: !BS.ByteString -- empty = no username + , uhPasswd :: !BS.ByteString -- empty = no password + } deriving (Show, Ord, Eq) + +{- | The type of a URL's query arguments. + The RFC does not specify any particular format for this section of a URL, but, since + it is so common to use form encoding, we include a representation which is a list of + parsed key=value&key=value pairs. + + When parsing a URL, we first assume that the query is form encoded. If this parse fails, + the 'UnparsedQuery' constructor is instead used to encode a URL whose query encoding is + unknown. +-} +data QueryPair = QueryPair !BS.ByteString !BS.ByteString + deriving (Show, Ord, Eq) +data Query + = UnparsedQuery !BS.ByteString + | ParsedQuery [QueryPair] + deriving (Show, Ord, Eq) + +{- | Symbolic URL type. + It is intended that this type can capture all \"conventional\" URLs losslessly and symbolically. + + In short, if you ever find yourself resorting to direct string parsing or generation, you are + either doing it wrong, or this library is missing something you need. + -} + +data UrlHead = FullyQualified !Protocol !UrlHost + | ProtocolRelative !UrlHost + | Absolute + | Relative + deriving (Eq, Ord, Show) + +data Url = Url + { urlHead :: !UrlHead + , urlPath :: ![PathPiece] + , urlQuery :: !(SMaybe Query) + , urlHash :: !(SMaybe Hash) + } deriving (Eq, Ord, Show) + + +builderToBS :: BSB.Builder -> BS.ByteString +builderToBS = BSL.toStrict . BSB.toLazyByteString + +escapeString :: BS.ByteString -> BSB.Builder +escapeString = BSB.byteString . urlEncode False + +toByteString :: Url -> BS.ByteString +toByteString = builderToBS . toBuilder + +toBuilder :: Url -> BSB.Builder +toBuilder Url{..} = + renderHead urlHead + <> renderPath urlPath + <> renderQuery urlQuery + <> renderHash urlHash + where + toBB = BSB.byteString + char = BSB.char7 + + renderHead :: UrlHead -> BSB.Builder + renderHead (FullyQualified protocol host) = toBB protocol <> char ':' <> renderHost host <> char '/' + renderHead (ProtocolRelative host) = renderHost host <> char '/' + renderHead Absolute = char '/' + renderHead Relative = mempty + + renderHost :: UrlHost -> BSB.Builder + renderHost UrlHost{..} = char '/' <> char '/' <> renderUser uhUserName uhPasswd <> renderHostName uhHostName uhPort + + renderPath :: [PathPiece] -> BSB.Builder + renderPath [] = mempty + renderPath path = interc (char '/') (map escapeString path) + + renderQuery :: SMaybe Query -> BSB.Builder + renderQuery SNothing = mempty + renderQuery (SJust (UnparsedQuery q)) = char '?' <> toBB q + renderQuery (SJust (ParsedQuery pairs)) = char '?' <> interc (char '&') (map renderPair pairs) + + renderPair (QueryPair k v) = escapeString k <> char '=' <> escapeString v + + renderHash h = case h of + SNothing -> mempty + SJust hash -> char '#' <> toBB hash + + renderHostName hostName hnPort + | 0 /= hnPort = toBB hostName <> char ':' <> BSB.intDec (fromIntegral hnPort) + | otherwise = toBB hostName + + renderUser uhName uhPasswd + | BS.null uhName = mempty + | BS.null uhPasswd = escapeString uhName <> char '@' + | otherwise = escapeString uhName <> char ':' <> escapeString uhPasswd <> char '@' + + interc _ [] = mempty + interc _ [x] = x + interc sep (x:y:xs) = x <> sep <> interc sep (y:xs) + +renderHost' :: UrlHost -> BB.BufferBuilder () +renderHost' UrlHost{..} = do + BB.appendChar8 '/' + BB.appendChar8 '/' + + when (not $ BS.null uhUserName) $ do + BB.appendUrlEncoded uhUserName + when (not $ BS.null uhPasswd) $ do + BB.appendChar8 ':' + BB.appendUrlEncoded uhPasswd + BB.appendChar8 '@' + + BB.appendBS uhHostName + if (uhPort /= 0) then do + BB.appendChar8 ':' + BB.appendDecimalSignedInt (fromIntegral uhPort) + else + return () + + BB.appendChar8 '/' + +renderPair' :: QueryPair -> BB.BufferBuilder () +renderPair' (QueryPair key value) = do + BB.appendUrlEncoded key + BB.appendChar8 '=' + BB.appendUrlEncoded value + +render :: Url -> BB.BufferBuilder () +render Url{..} = do + case urlHead of + (FullyQualified protocol host) -> do + BB.appendBS protocol + BB.appendChar8 ':' + renderHost' host + (ProtocolRelative host) -> renderHost' host + Absolute -> BB.appendChar8 '/' + Relative -> return () + + case urlPath of + [] -> return () + (x:xs) -> do + BB.appendUrlEncoded x + forM_ xs $ \ps -> do + BB.appendChar8 '/' + BB.appendUrlEncoded ps + + case urlQuery of + SNothing -> return () + (SJust (UnparsedQuery q)) -> do + BB.appendChar8 '?' + BB.appendBS q + (SJust (ParsedQuery pairs)) -> do + BB.appendChar8 '?' + case pairs of + [] -> return () + (x:xs) -> do + renderPair' x + forM_ xs $ \pair -> do + BB.appendChar8 '&' + renderPair' pair + + + case urlHash of + SNothing -> return () + (SJust h) -> do + BB.appendChar8 '#' + BB.appendBS h + +viaBufferBuilder :: Url -> BS.ByteString +viaBufferBuilder = BB.runBufferBuilder . render + +main :: IO () +main = do + let host = UrlHost + { uhHostName = "example.com" + , uhPort = 80 + , uhUserName = "" + , uhPasswd = "" + } + + let url = Url + { urlHead = FullyQualified "http" host + , urlPath = ["service", "one", "two", "three"] + , urlQuery = SJust (ParsedQuery + [ QueryPair "limit" "30" + , QueryPair "next" "123456" + , QueryPair "previous" "987654" + ]) + , urlHash = SJust "anchor" + } + + BSC.putStrLn $ "bytestring builder: " <> toByteString url + BSC.putStrLn $ "bufferbuilder: " <> viaBufferBuilder url + + defaultMain [ bgroup "render url" + [ bench "bufferbuilder" $ nf viaBufferBuilder url + , bench "bytestring builder" $ nf toByteString url + --, bench "vector text" $ nf Json.encodeJson (Vector.replicate 100000 ("hello world" :: Text)) + ] + ] diff --git a/branchlut.cpp b/branchlut.cpp deleted file mode 100644 --- a/branchlut.cpp +++ /dev/null @@ -1,275 +0,0 @@ -/** - */ - -#include -#include - -static const char gDigitsLut[200] = { - '0','0','0','1','0','2','0','3','0','4','0','5','0','6','0','7','0','8','0','9', - '1','0','1','1','1','2','1','3','1','4','1','5','1','6','1','7','1','8','1','9', - '2','0','2','1','2','2','2','3','2','4','2','5','2','6','2','7','2','8','2','9', - '3','0','3','1','3','2','3','3','3','4','3','5','3','6','3','7','3','8','3','9', - '4','0','4','1','4','2','4','3','4','4','4','5','4','6','4','7','4','8','4','9', - '5','0','5','1','5','2','5','3','5','4','5','5','5','6','5','7','5','8','5','9', - '6','0','6','1','6','2','6','3','6','4','6','5','6','6','6','7','6','8','6','9', - '7','0','7','1','7','2','7','3','7','4','7','5','7','6','7','7','7','8','7','9', - '8','0','8','1','8','2','8','3','8','4','8','5','8','6','8','7','8','8','8','9', - '9','0','9','1','9','2','9','3','9','4','9','5','9','6','9','7','9','8','9','9' -}; - -// Branching for different cases (forward) -// Use lookup table of two digits - -size_t u32toa_branchlut(uint32_t value, char* buffer) { - char* start = buffer; - - if (value < 10000) { - const uint32_t d1 = (value / 100) << 1; - const uint32_t d2 = (value % 100) << 1; - - if (value >= 1000) - *buffer++ = gDigitsLut[d1]; - if (value >= 100) - *buffer++ = gDigitsLut[d1 + 1]; - if (value >= 10) - *buffer++ = gDigitsLut[d2]; - *buffer++ = gDigitsLut[d2 + 1]; - } - else if (value < 100000000) { - // value = bbbbcccc - const uint32_t b = value / 10000; - const uint32_t c = value % 10000; - - const uint32_t d1 = (b / 100) << 1; - const uint32_t d2 = (b % 100) << 1; - - const uint32_t d3 = (c / 100) << 1; - const uint32_t d4 = (c % 100) << 1; - - if (value >= 10000000) - *buffer++ = gDigitsLut[d1]; - if (value >= 1000000) - *buffer++ = gDigitsLut[d1 + 1]; - if (value >= 100000) - *buffer++ = gDigitsLut[d2]; - *buffer++ = gDigitsLut[d2 + 1]; - - *buffer++ = gDigitsLut[d3]; - *buffer++ = gDigitsLut[d3 + 1]; - *buffer++ = gDigitsLut[d4]; - *buffer++ = gDigitsLut[d4 + 1]; - } - else { - // value = aabbbbcccc in decimal - - const uint32_t a = value / 100000000; // 1 to 42 - value %= 100000000; - - if (a >= 10) { - const unsigned i = a << 1; - *buffer++ = gDigitsLut[i]; - *buffer++ = gDigitsLut[i + 1]; - } - else - *buffer++ = '0' + static_cast(a); - - const uint32_t b = value / 10000; // 0 to 9999 - const uint32_t c = value % 10000; // 0 to 9999 - - const uint32_t d1 = (b / 100) << 1; - const uint32_t d2 = (b % 100) << 1; - - const uint32_t d3 = (c / 100) << 1; - const uint32_t d4 = (c % 100) << 1; - - *buffer++ = gDigitsLut[d1]; - *buffer++ = gDigitsLut[d1 + 1]; - *buffer++ = gDigitsLut[d2]; - *buffer++ = gDigitsLut[d2 + 1]; - *buffer++ = gDigitsLut[d3]; - *buffer++ = gDigitsLut[d3 + 1]; - *buffer++ = gDigitsLut[d4]; - *buffer++ = gDigitsLut[d4 + 1]; - } - return buffer - start; -} - -size_t i32toa_branchlut(int32_t value, char* buffer) { - size_t length = 0; - if (value < 0) { - ++length; - *buffer++ = '-'; - value = -value; - } - - return length + u32toa_branchlut(static_cast(value), buffer); -} - -size_t u64toa_branchlut(uint64_t value, char* buffer) { - char* start = buffer; - if (value < 100000000) { - uint32_t v = static_cast(value); - if (v < 10000) { - const uint32_t d1 = (v / 100) << 1; - const uint32_t d2 = (v % 100) << 1; - - if (v >= 1000) - *buffer++ = gDigitsLut[d1]; - if (v >= 100) - *buffer++ = gDigitsLut[d1 + 1]; - if (v >= 10) - *buffer++ = gDigitsLut[d2]; - *buffer++ = gDigitsLut[d2 + 1]; - } - else { - // value = bbbbcccc - const uint32_t b = v / 10000; - const uint32_t c = v % 10000; - - const uint32_t d1 = (b / 100) << 1; - const uint32_t d2 = (b % 100) << 1; - - const uint32_t d3 = (c / 100) << 1; - const uint32_t d4 = (c % 100) << 1; - - if (value >= 10000000) - *buffer++ = gDigitsLut[d1]; - if (value >= 1000000) - *buffer++ = gDigitsLut[d1 + 1]; - if (value >= 100000) - *buffer++ = gDigitsLut[d2]; - *buffer++ = gDigitsLut[d2 + 1]; - - *buffer++ = gDigitsLut[d3]; - *buffer++ = gDigitsLut[d3 + 1]; - *buffer++ = gDigitsLut[d4]; - *buffer++ = gDigitsLut[d4 + 1]; - } - } - else if (value < 10000000000000000) { - const uint32_t v0 = static_cast(value / 100000000); - const uint32_t v1 = static_cast(value % 100000000); - - const uint32_t b0 = v0 / 10000; - const uint32_t c0 = v0 % 10000; - - const uint32_t d1 = (b0 / 100) << 1; - const uint32_t d2 = (b0 % 100) << 1; - - const uint32_t d3 = (c0 / 100) << 1; - const uint32_t d4 = (c0 % 100) << 1; - - const uint32_t b1 = v1 / 10000; - const uint32_t c1 = v1 % 10000; - - const uint32_t d5 = (b1 / 100) << 1; - const uint32_t d6 = (b1 % 100) << 1; - - const uint32_t d7 = (c1 / 100) << 1; - const uint32_t d8 = (c1 % 100) << 1; - - if (value >= 1000000000000000) - *buffer++ = gDigitsLut[d1]; - if (value >= 100000000000000) - *buffer++ = gDigitsLut[d1 + 1]; - if (value >= 10000000000000) - *buffer++ = gDigitsLut[d2]; - if (value >= 1000000000000) - *buffer++ = gDigitsLut[d2 + 1]; - if (value >= 100000000000) - *buffer++ = gDigitsLut[d3]; - if (value >= 10000000000) - *buffer++ = gDigitsLut[d3 + 1]; - if (value >= 1000000000) - *buffer++ = gDigitsLut[d4]; - if (value >= 100000000) - *buffer++ = gDigitsLut[d4 + 1]; - - *buffer++ = gDigitsLut[d5]; - *buffer++ = gDigitsLut[d5 + 1]; - *buffer++ = gDigitsLut[d6]; - *buffer++ = gDigitsLut[d6 + 1]; - *buffer++ = gDigitsLut[d7]; - *buffer++ = gDigitsLut[d7 + 1]; - *buffer++ = gDigitsLut[d8]; - *buffer++ = gDigitsLut[d8 + 1]; - } - else { - const uint32_t a = static_cast(value / 10000000000000000); // 1 to 1844 - value %= 10000000000000000; - - if (a < 10) - *buffer++ = '0' + static_cast(a); - else if (a < 100) { - const uint32_t i = a << 1; - *buffer++ = gDigitsLut[i]; - *buffer++ = gDigitsLut[i + 1]; - } - else if (a < 1000) { - *buffer++ = '0' + static_cast(a / 100); - - const uint32_t i = (a % 100) << 1; - *buffer++ = gDigitsLut[i]; - *buffer++ = gDigitsLut[i + 1]; - } - else { - const uint32_t i = (a / 100) << 1; - const uint32_t j = (a % 100) << 1; - *buffer++ = gDigitsLut[i]; - *buffer++ = gDigitsLut[i + 1]; - *buffer++ = gDigitsLut[j]; - *buffer++ = gDigitsLut[j + 1]; - } - - const uint32_t v0 = static_cast(value / 100000000); - const uint32_t v1 = static_cast(value % 100000000); - - const uint32_t b0 = v0 / 10000; - const uint32_t c0 = v0 % 10000; - - const uint32_t d1 = (b0 / 100) << 1; - const uint32_t d2 = (b0 % 100) << 1; - - const uint32_t d3 = (c0 / 100) << 1; - const uint32_t d4 = (c0 % 100) << 1; - - const uint32_t b1 = v1 / 10000; - const uint32_t c1 = v1 % 10000; - - const uint32_t d5 = (b1 / 100) << 1; - const uint32_t d6 = (b1 % 100) << 1; - - const uint32_t d7 = (c1 / 100) << 1; - const uint32_t d8 = (c1 % 100) << 1; - - *buffer++ = gDigitsLut[d1]; - *buffer++ = gDigitsLut[d1 + 1]; - *buffer++ = gDigitsLut[d2]; - *buffer++ = gDigitsLut[d2 + 1]; - *buffer++ = gDigitsLut[d3]; - *buffer++ = gDigitsLut[d3 + 1]; - *buffer++ = gDigitsLut[d4]; - *buffer++ = gDigitsLut[d4 + 1]; - *buffer++ = gDigitsLut[d5]; - *buffer++ = gDigitsLut[d5 + 1]; - *buffer++ = gDigitsLut[d6]; - *buffer++ = gDigitsLut[d6 + 1]; - *buffer++ = gDigitsLut[d7]; - *buffer++ = gDigitsLut[d7 + 1]; - *buffer++ = gDigitsLut[d8]; - *buffer++ = gDigitsLut[d8 + 1]; - } - - return buffer - start; -} - -size_t i64toa_branchlut(int64_t value, char* buffer) { - size_t length = 0; - if (value < 0) { - ++length; - *buffer++ = '-'; - value = -value; - } - - return length + u64toa_branchlut(static_cast(value), buffer); -} diff --git a/branchlut.h b/branchlut.h deleted file mode 100644 --- a/branchlut.h +++ /dev/null @@ -1,11 +0,0 @@ -/** - */ - -#pragma once - -#include - -size_t u32toa_branchlut(uint32_t value, char* buffer); -size_t i32toa_branchlut(int32_t value, char* buffer); -size_t u64toa_branchlut(uint64_t value, char* buffer); -size_t i64toa_branchlut(int64_t value, char* buffer); diff --git a/buffer-builder.cabal b/buffer-builder.cabal --- a/buffer-builder.cabal +++ b/buffer-builder.cabal @@ -1,5 +1,5 @@ name: buffer-builder -version: 0.2.0.3 +version: 0.2.1.0 synopsis: Library for efficiently building up buffers, one piece at a time description: @@ -47,7 +47,7 @@ stability: experimental homepage: https://github.com/chadaustin/buffer-builder cabal-version: >=1.10 -extra-source-files: test/*.hs +extra-source-files: test/*.hs changelog.md library exposed-modules: @@ -64,9 +64,11 @@ default-language: Haskell2010 ghc-options: -O2 -Wall + --ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-opt-cmm -ddump-asm -ddump-to-file - c-sources: buffer.cpp branchlut.cpp - install-includes: branchlut.h + hs-source-dirs: src + c-sources: cbits/buffer.cpp cbits/branchlut.cpp + install-includes: cbits/branchlut.h cc-options: -O2 -Wall test-suite tests @@ -119,6 +121,21 @@ , vector , criterion , vector + , json-builder + +benchmark url + type: exitcode-stdio-1.0 + main-is: UrlBench.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -O2 -Wall + --ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-opt-cmm -ddump-asm -ddump-to-file + build-depends: base + , buffer-builder + , bytestring + , http-types + , text + , criterion test-suite tinyjson type: exitcode-stdio-1.0 diff --git a/buffer.cpp b/buffer.cpp deleted file mode 100644 --- a/buffer.cpp +++ /dev/null @@ -1,289 +0,0 @@ -#include -#include -#include -#include -#include - -#include "branchlut.h" - -const size_t TRIM_THRESHOLD = 8192; // minimum number of bytes saved to trim - -/* - * Append utf8, ASCII7, raw bytes, utf16 - * JSON encode utf8, ascii7, utf16 - */ - -#if defined(__clang__) - #define BW_NOINLINE __attribute__((noinline)) -#elif defined(__GNUC__) - #define BW_NOINLINE __attribute__((noinline)) -#else - #define BW_NOINLINE -#endif - -namespace { - struct BufferWriter { - unsigned char* data; - size_t size; - size_t capacity; - }; - - BW_NOINLINE void actuallyGrow(BufferWriter* bw, size_t amount) { - size_t newCapacity = bw->capacity; - do { - newCapacity *= 2; - } while (newCapacity < bw->size + amount); - - unsigned char* newData = reinterpret_cast(realloc(bw->data, newCapacity)); - assert(newData); - bw->data = newData; - bw->capacity = newCapacity; - } - - inline void grow(BufferWriter* bw, size_t amount) { - if (bw->size + amount > bw->capacity) { - actuallyGrow(bw, amount); - } - } -} - -// assumes malloc will not fail -// TODO: replace assert with some other error mechanism - -extern "C" BufferWriter* bw_new(size_t initialCapacity) { - assert(initialCapacity >= 1); - BufferWriter* bw = reinterpret_cast(malloc(sizeof(BufferWriter))); - assert(bw); - bw->data = reinterpret_cast(malloc(initialCapacity)); - assert(bw->data); - bw->size = 0; - bw->capacity = initialCapacity; - return bw; -} - -extern "C" void bw_free(BufferWriter* bw) { - free(bw->data); - free(bw); -} - -extern "C" size_t bw_get_size(BufferWriter* bw) { - return bw->size; -} - -extern "C" unsigned char* bw_trim_and_release_address(BufferWriter* bw) { - unsigned char* data = bw->data; - - if (bw->size + TRIM_THRESHOLD < bw->capacity) { - // try to shrink - data = reinterpret_cast(realloc(data, bw->size)); - if (!data) { - // no problem - data = bw->data; - } - } - - bw->data = 0; - return data; -} - -extern "C" void bw_append_byte(BufferWriter* bw, unsigned char byte) { - assert(bw->data); - grow(bw, 1); - bw->data[bw->size] = byte; - bw->size += 1; -} - -extern "C" void bw_append_char_utf8(BufferWriter* bw, uint32_t c) { - assert(bw->data); - grow(bw, 4); - - size_t size = bw->size; - unsigned char* data = bw->data + size; - - if (c <= 0x7F) { - data[0] = static_cast(c); - size += 1; - } else if (c <= 0x7FF) { - data[0] = static_cast(0xC0 | (c >> 6)); - data[1] = static_cast(0x80 | (c & 0x3F)); - size += 2; - } else if (c <= 0xFFFF) { - data[0] = static_cast(0xE0 | (c >> 12)); - data[1] = static_cast(0x80 | ((c >> 6) & 0x3F)); - data[2] = static_cast(0x80 | (c & 0x3F)); - size += 3; - } else if (c <= 0x1FFFFF) { - data[0] = static_cast(0xF0 | (c >> 18)); - data[1] = static_cast(0x80 | ((c >> 12) & 0x3F)); - data[2] = static_cast(0x80 | ((c >> 6) & 0x3F)); - data[3] = static_cast(0x80 | (c & 0x3F)); - size += 4; - } else { - // Unicode characters out of this range are illegal... - // should we assert? or just ignore... - } - bw->size = size; -} - -extern "C" void bw_append_bs(BufferWriter* bw, size_t size, const unsigned char* data) { - assert(bw->data); - grow(bw, size); - - memcpy(bw->data + bw->size, data, size); - bw->size += size; -} - -extern "C" void bw_append_bsz(BufferWriter* bw, const unsigned char* data) { - bw_append_bs(bw, strlen(reinterpret_cast(data)), data); -} - -extern "C" void bw_append_byte7(BufferWriter* bw, unsigned char byte) { - assert(bw->data); - grow(bw, 1); - bw->data[bw->size] = byte & 0x7F; - bw->size += 1; -} - -extern "C" void bw_append_bs7(BufferWriter* bw, size_t size, const unsigned char* data) { - assert(bw->data); - grow(bw, size); - - unsigned char* out = bw->data + bw->size; - for (size_t i = 0; i < size; ++i) { - out[i] = data[i] & 0x7F; - } - bw->size += size; -} - -extern "C" void bw_append_bsz7(BufferWriter* bw, const unsigned char* data) { - bw_append_bs7(bw, strlen(reinterpret_cast(data)), data); -} - -extern "C" void bw_append_json_escaped(BufferWriter* bw, size_t size, const unsigned char* data) { - assert(bw->data); - grow(bw, 2 + size * 2); - - unsigned char* dest = bw->data + bw->size; - *dest++ = '\"'; - - size_t i = 0; - while (i < size) { - switch (data[i]) { - case '\n': *dest++ = '\\'; *dest++ = 'n'; break; - case '\r': *dest++ = '\\'; *dest++ = 'r'; break; - case '\t': *dest++ = '\\'; *dest++ = 't'; break; - case '\\': *dest++ = '\\'; *dest++ = '\\'; break; - case '\"': *dest++ = '\\'; *dest++ = '\"'; break; - default: *dest++ = data[i]; - } - ++i; - } - - *dest++ = '\"'; - bw->size = dest - bw->data; -} - -extern "C" void bw_append_decimal_signed_int(BufferWriter* bw, int64_t i) { - assert(bw->data); - grow(bw, 32); // enough - - unsigned used = i64toa_branchlut(i, reinterpret_cast(bw->data + bw->size)); - bw->size += used; -} - -extern "C" void bw_append_decimal_double(BufferWriter* bw, double d) { - assert(bw->data); - grow(bw, 30); // ??? - - size_t used = sprintf(reinterpret_cast(bw->data + bw->size), "%f", d); - bw->size += used; -} - -// From -extern "C" void bw_encode_utf8(uint8_t **destp, const uint16_t *src, size_t srcoff, size_t srclen) { - const uint16_t *srcend; - uint8_t *dest = *destp; - - src += srcoff; - srcend = src + srclen; - - ascii: -#if defined(__x86_64__) - while (srcend - src >= 4) { - uint64_t w = *((uint64_t *) src); - - if (w & 0xFF80FF80FF80FF80ULL) { - if (!(w & 0x000000000000FF80ULL)) { - *dest++ = w & 0xFFFF; - src++; - if (!(w & 0x00000000FF800000ULL)) { - *dest++ = (w >> 16) & 0xFFFF; - src++; - if (!(w & 0x0000FF8000000000ULL)) { - *dest++ = (w >> 32) & 0xFFFF; - src++; - } - } - } - break; - } - *dest++ = w & 0xFFFF; - *dest++ = (w >> 16) & 0xFFFF; - *dest++ = (w >> 32) & 0xFFFF; - *dest++ = w >> 48; - src += 4; - } -#endif - -#if defined(__i386__) - while (srcend - src >= 2) { - uint32_t w = *((uint32_t *) src); - - if (w & 0xFF80FF80) - break; - *dest++ = w & 0xFFFF; - *dest++ = w >> 16; - src += 2; - } -#endif - - while (src < srcend) { - uint16_t w = *src++; - - if (w <= 0x7F) { - *dest++ = w; - /* An ASCII byte is likely to begin a run of ASCII bytes. - Falling back into the fast path really helps performance. */ - goto ascii; - } - else if (w <= 0x7FF) { - *dest++ = (w >> 6) | 0xC0; - *dest++ = (w & 0x3f) | 0x80; - } - else if (w < 0xD800 || w > 0xDBFF) { - *dest++ = (w >> 12) | 0xE0; - *dest++ = ((w >> 6) & 0x3F) | 0x80; - *dest++ = (w & 0x3F) | 0x80; - } else { - uint32_t c = ((((uint32_t) w) - 0xD800) << 10) + - (((uint32_t) *src++) - 0xDC00) + 0x10000; - *dest++ = (c >> 18) | 0xF0; - *dest++ = ((c >> 12) & 0x3F) | 0x80; - *dest++ = ((c >> 6) & 0x3F) | 0x80; - *dest++ = (c & 0x3F) | 0x80; - } - } - - *destp = dest; -} - -extern "C" void bw_append_json_escaped_utf16(BufferWriter* bw, size_t size, unsigned short* words) { - unsigned char* utf8 = reinterpret_cast(malloc(size * 4)); - unsigned char* utf8end = utf8; - - bw_encode_utf8(&utf8end, words, 0, size); - - bw_append_json_escaped(bw, utf8end - utf8, utf8); - - free(utf8); -} diff --git a/cbits/branchlut.cpp b/cbits/branchlut.cpp new file mode 100644 --- /dev/null +++ b/cbits/branchlut.cpp @@ -0,0 +1,271 @@ +/** + */ + +#include +#include + +static const char gDigitsLut[200] = { + '0','0','0','1','0','2','0','3','0','4','0','5','0','6','0','7','0','8','0','9', + '1','0','1','1','1','2','1','3','1','4','1','5','1','6','1','7','1','8','1','9', + '2','0','2','1','2','2','2','3','2','4','2','5','2','6','2','7','2','8','2','9', + '3','0','3','1','3','2','3','3','3','4','3','5','3','6','3','7','3','8','3','9', + '4','0','4','1','4','2','4','3','4','4','4','5','4','6','4','7','4','8','4','9', + '5','0','5','1','5','2','5','3','5','4','5','5','5','6','5','7','5','8','5','9', + '6','0','6','1','6','2','6','3','6','4','6','5','6','6','6','7','6','8','6','9', + '7','0','7','1','7','2','7','3','7','4','7','5','7','6','7','7','7','8','7','9', + '8','0','8','1','8','2','8','3','8','4','8','5','8','6','8','7','8','8','8','9', + '9','0','9','1','9','2','9','3','9','4','9','5','9','6','9','7','9','8','9','9' +}; + +// Branching for different cases (forward) +// Use lookup table of two digits + +size_t u32toa_branchlut(uint32_t value, char* buffer) { + char* start = buffer; + + if (value < 10000) { + const uint32_t d1 = (value / 100) << 1; + const uint32_t d2 = (value % 100) << 1; + + if (value >= 1000) + *buffer++ = gDigitsLut[d1]; + if (value >= 100) + *buffer++ = gDigitsLut[d1 + 1]; + if (value >= 10) + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + } + else if (value < 100000000) { + // value = bbbbcccc + const uint32_t b = value / 10000; + const uint32_t c = value % 10000; + + const uint32_t d1 = (b / 100) << 1; + const uint32_t d2 = (b % 100) << 1; + + const uint32_t d3 = (c / 100) << 1; + const uint32_t d4 = (c % 100) << 1; + + if (value >= 10000000) + *buffer++ = gDigitsLut[d1]; + if (value >= 1000000) + *buffer++ = gDigitsLut[d1 + 1]; + if (value >= 100000) + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + + *buffer++ = gDigitsLut[d3]; + *buffer++ = gDigitsLut[d3 + 1]; + *buffer++ = gDigitsLut[d4]; + *buffer++ = gDigitsLut[d4 + 1]; + } + else { + // value = aabbbbcccc in decimal + + const uint32_t a = value / 100000000; // 1 to 42 + value %= 100000000; + + if (a >= 10) { + const unsigned i = a << 1; + *buffer++ = gDigitsLut[i]; + *buffer++ = gDigitsLut[i + 1]; + } + else + *buffer++ = '0' + static_cast(a); + + const uint32_t b = value / 10000; // 0 to 9999 + const uint32_t c = value % 10000; // 0 to 9999 + + const uint32_t d1 = (b / 100) << 1; + const uint32_t d2 = (b % 100) << 1; + + const uint32_t d3 = (c / 100) << 1; + const uint32_t d4 = (c % 100) << 1; + + *buffer++ = gDigitsLut[d1]; + *buffer++ = gDigitsLut[d1 + 1]; + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + *buffer++ = gDigitsLut[d3]; + *buffer++ = gDigitsLut[d3 + 1]; + *buffer++ = gDigitsLut[d4]; + *buffer++ = gDigitsLut[d4 + 1]; + } + return buffer - start; +} + +size_t i32toa_branchlut(int32_t value, char* buffer) { + if (value < 0) { + *buffer++ = '-'; + return 1 + u32toa_branchlut(~static_cast(value) + 1u, buffer); + } else { + return u32toa_branchlut(static_cast(value), buffer); + } +} + +size_t u64toa_branchlut(uint64_t value, char* buffer) { + char* start = buffer; + if (value < 100000000) { + uint32_t v = static_cast(value); + if (v < 10000) { + const uint32_t d1 = (v / 100) << 1; + const uint32_t d2 = (v % 100) << 1; + + if (v >= 1000) + *buffer++ = gDigitsLut[d1]; + if (v >= 100) + *buffer++ = gDigitsLut[d1 + 1]; + if (v >= 10) + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + } + else { + // value = bbbbcccc + const uint32_t b = v / 10000; + const uint32_t c = v % 10000; + + const uint32_t d1 = (b / 100) << 1; + const uint32_t d2 = (b % 100) << 1; + + const uint32_t d3 = (c / 100) << 1; + const uint32_t d4 = (c % 100) << 1; + + if (value >= 10000000) + *buffer++ = gDigitsLut[d1]; + if (value >= 1000000) + *buffer++ = gDigitsLut[d1 + 1]; + if (value >= 100000) + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + + *buffer++ = gDigitsLut[d3]; + *buffer++ = gDigitsLut[d3 + 1]; + *buffer++ = gDigitsLut[d4]; + *buffer++ = gDigitsLut[d4 + 1]; + } + } + else if (value < 10000000000000000) { + const uint32_t v0 = static_cast(value / 100000000); + const uint32_t v1 = static_cast(value % 100000000); + + const uint32_t b0 = v0 / 10000; + const uint32_t c0 = v0 % 10000; + + const uint32_t d1 = (b0 / 100) << 1; + const uint32_t d2 = (b0 % 100) << 1; + + const uint32_t d3 = (c0 / 100) << 1; + const uint32_t d4 = (c0 % 100) << 1; + + const uint32_t b1 = v1 / 10000; + const uint32_t c1 = v1 % 10000; + + const uint32_t d5 = (b1 / 100) << 1; + const uint32_t d6 = (b1 % 100) << 1; + + const uint32_t d7 = (c1 / 100) << 1; + const uint32_t d8 = (c1 % 100) << 1; + + if (value >= 1000000000000000) + *buffer++ = gDigitsLut[d1]; + if (value >= 100000000000000) + *buffer++ = gDigitsLut[d1 + 1]; + if (value >= 10000000000000) + *buffer++ = gDigitsLut[d2]; + if (value >= 1000000000000) + *buffer++ = gDigitsLut[d2 + 1]; + if (value >= 100000000000) + *buffer++ = gDigitsLut[d3]; + if (value >= 10000000000) + *buffer++ = gDigitsLut[d3 + 1]; + if (value >= 1000000000) + *buffer++ = gDigitsLut[d4]; + if (value >= 100000000) + *buffer++ = gDigitsLut[d4 + 1]; + + *buffer++ = gDigitsLut[d5]; + *buffer++ = gDigitsLut[d5 + 1]; + *buffer++ = gDigitsLut[d6]; + *buffer++ = gDigitsLut[d6 + 1]; + *buffer++ = gDigitsLut[d7]; + *buffer++ = gDigitsLut[d7 + 1]; + *buffer++ = gDigitsLut[d8]; + *buffer++ = gDigitsLut[d8 + 1]; + } + else { + const uint32_t a = static_cast(value / 10000000000000000); // 1 to 1844 + value %= 10000000000000000; + + if (a < 10) + *buffer++ = '0' + static_cast(a); + else if (a < 100) { + const uint32_t i = a << 1; + *buffer++ = gDigitsLut[i]; + *buffer++ = gDigitsLut[i + 1]; + } + else if (a < 1000) { + *buffer++ = '0' + static_cast(a / 100); + + const uint32_t i = (a % 100) << 1; + *buffer++ = gDigitsLut[i]; + *buffer++ = gDigitsLut[i + 1]; + } + else { + const uint32_t i = (a / 100) << 1; + const uint32_t j = (a % 100) << 1; + *buffer++ = gDigitsLut[i]; + *buffer++ = gDigitsLut[i + 1]; + *buffer++ = gDigitsLut[j]; + *buffer++ = gDigitsLut[j + 1]; + } + + const uint32_t v0 = static_cast(value / 100000000); + const uint32_t v1 = static_cast(value % 100000000); + + const uint32_t b0 = v0 / 10000; + const uint32_t c0 = v0 % 10000; + + const uint32_t d1 = (b0 / 100) << 1; + const uint32_t d2 = (b0 % 100) << 1; + + const uint32_t d3 = (c0 / 100) << 1; + const uint32_t d4 = (c0 % 100) << 1; + + const uint32_t b1 = v1 / 10000; + const uint32_t c1 = v1 % 10000; + + const uint32_t d5 = (b1 / 100) << 1; + const uint32_t d6 = (b1 % 100) << 1; + + const uint32_t d7 = (c1 / 100) << 1; + const uint32_t d8 = (c1 % 100) << 1; + + *buffer++ = gDigitsLut[d1]; + *buffer++ = gDigitsLut[d1 + 1]; + *buffer++ = gDigitsLut[d2]; + *buffer++ = gDigitsLut[d2 + 1]; + *buffer++ = gDigitsLut[d3]; + *buffer++ = gDigitsLut[d3 + 1]; + *buffer++ = gDigitsLut[d4]; + *buffer++ = gDigitsLut[d4 + 1]; + *buffer++ = gDigitsLut[d5]; + *buffer++ = gDigitsLut[d5 + 1]; + *buffer++ = gDigitsLut[d6]; + *buffer++ = gDigitsLut[d6 + 1]; + *buffer++ = gDigitsLut[d7]; + *buffer++ = gDigitsLut[d7 + 1]; + *buffer++ = gDigitsLut[d8]; + *buffer++ = gDigitsLut[d8 + 1]; + } + + return buffer - start; +} + +size_t i64toa_branchlut(int64_t value, char* buffer) { + if (value < 0) { + *buffer++ = '-'; + return 1 + u64toa_branchlut(~static_cast(value) + 1u, buffer); + } else { + return u64toa_branchlut(static_cast(value), buffer); + } +} diff --git a/cbits/branchlut.h b/cbits/branchlut.h new file mode 100644 --- /dev/null +++ b/cbits/branchlut.h @@ -0,0 +1,11 @@ +/** + */ + +#pragma once + +#include + +size_t u32toa_branchlut(uint32_t value, char* buffer); +size_t i32toa_branchlut(int32_t value, char* buffer); +size_t u64toa_branchlut(uint64_t value, char* buffer); +size_t i64toa_branchlut(int64_t value, char* buffer); diff --git a/cbits/buffer.cpp b/cbits/buffer.cpp new file mode 100644 --- /dev/null +++ b/cbits/buffer.cpp @@ -0,0 +1,395 @@ +#include +#include +#include +#include +#include + +#include "branchlut.h" + +/* + * Append utf8, ASCII7, raw bytes, utf16 + * JSON encode utf8, ascii7, utf16 + */ + +#if defined(__clang__) || defined(__GNUC__) + #define BW_NOINLINE __attribute__((noinline)) +#else + #define BW_NOINLINE +#endif + +#if defined(__clang__) || defined(__GNUC__) + #define BW_LIKELY(x) __builtin_expect(!!(x), 1) + #define BW_UNLIKELY(x) __builtin_expect(!!(x), 0) +#else + #define BW_LIKELY(x) x + #define BW_UNLIKELY(x) x +#endif + +#define BW_ENSURE_CAPACITY(bw, cap) \ + do { \ + if (!ensureCapacity((bw), (cap))) { \ + return; \ + } \ + } while (0) + + +namespace { + struct BufferWriter { + unsigned char* end; // the most commonly-accessed field + unsigned char* capacity; + unsigned char* data; + + // invariants: + // if (end <= capacity), then data is non-null and end >= data + // if (capacity == 0), then data and end are null, and object is dead + + // Note: We mark the object dead upon growth failure in order + // to avoid the need to check for errors after every single + // append function. The error can be raised upon the final + // pointer release. + }; + + BW_NOINLINE bool actuallyGrow(BufferWriter* bw, size_t amount) { + if (bw->capacity == 0) { + // object is dead, ignore append request + return false; + } + + size_t size = bw->end - bw->data; + size_t newCapacity = bw->capacity - bw->data; + do { + // TODO: detect overflow? + newCapacity *= 2; + } while (newCapacity < size + amount); + + unsigned char* newData = reinterpret_cast(realloc(bw->data, newCapacity)); + if (newData) { + bw->data = newData; + bw->end = newData + size; + bw->capacity = newData + newCapacity; + return true; + } else { + // TODO: try smaller growth? + free(bw->data); + bw->data = 0; + bw->end = 0; + bw->capacity = 0; + return false; + } + } + + inline bool ensureCapacity(BufferWriter* bw, size_t amount) { + if (BW_LIKELY(bw->end + amount <= bw->capacity)) { + return true; + } else { + return actuallyGrow(bw, amount); + } + } +} + +// assumes malloc will not fail +// TODO: replace assert with some other error mechanism + +extern "C" BufferWriter* bw_new(size_t initialCapacity) { + if (!initialCapacity) { + initialCapacity = 1; + } + + BufferWriter* bw = reinterpret_cast(malloc(sizeof(BufferWriter))); + if (!bw) { + return 0; + } + + bw->data = reinterpret_cast(malloc(initialCapacity)); + if (!bw->data) { + free(bw); + return 0; + } + + bw->end = bw->data; + bw->capacity = bw->data + initialCapacity; + return bw; +} + +extern "C" void bw_free(BufferWriter* bw) { + free(bw->data); + free(bw); +} + +extern "C" void bw_trim(BufferWriter* bw) { + if (bw->data == 0) { + return; + } + + if (bw->end < bw->capacity) { + // try to shrink + size_t size = bw->end - bw->data; + unsigned char* data = reinterpret_cast(realloc(bw->data, size)); + if (data) { + bw->data = data; + bw->end = data + size; + bw->capacity = data + size; + } else { + // no problem + } + } + +} + +extern "C" size_t bw_get_size(BufferWriter* bw) { + return bw->end - bw->data; +} + +extern "C" unsigned char* bw_release_address(BufferWriter* bw) { + unsigned char* data = bw->data; + + bw->end = 0; + bw->capacity = 0; + bw->data = 0; + return data; // null if dead +} + +extern "C" void bw_append_byte(BufferWriter* bw, unsigned char byte) { + BW_ENSURE_CAPACITY(bw, 1); + + bw->end[0] = byte; + bw->end += 1; +} + +extern "C" void bw_append_char_utf8(BufferWriter* bw, uint32_t c) { + BW_ENSURE_CAPACITY(bw, 4); + + unsigned char* data = bw->end; + + if (c <= 0x7F) { + data[0] = static_cast(c); + data += 1; + } else if (c <= 0x7FF) { + data[0] = static_cast(0xC0 | (c >> 6)); + data[1] = static_cast(0x80 | (c & 0x3F)); + data += 2; + } else if (c <= 0xFFFF) { + data[0] = static_cast(0xE0 | (c >> 12)); + data[1] = static_cast(0x80 | ((c >> 6) & 0x3F)); + data[2] = static_cast(0x80 | (c & 0x3F)); + data += 3; + } else if (c <= 0x1FFFFF) { + data[0] = static_cast(0xF0 | (c >> 18)); + data[1] = static_cast(0x80 | ((c >> 12) & 0x3F)); + data[2] = static_cast(0x80 | ((c >> 6) & 0x3F)); + data[3] = static_cast(0x80 | (c & 0x3F)); + data += 4; + } else { + // Unicode characters out of this range are illegal... + // should we assert? or just ignore... + } + bw->end = data; +} + +extern "C" void bw_append_bs(BufferWriter* bw, size_t size, const unsigned char* data) { + BW_ENSURE_CAPACITY(bw, size); + + memcpy(bw->end, data, size); + bw->end += size; +} + +extern "C" void bw_append_bsz(BufferWriter* bw, const unsigned char* data) { + bw_append_bs(bw, strlen(reinterpret_cast(data)), data); +} + +extern "C" void bw_append_byte7(BufferWriter* bw, unsigned char byte) { + BW_ENSURE_CAPACITY(bw, 1); + + bw->end[0] = byte & 0x7F; + bw->end += 1; +} + +extern "C" void bw_append_bs7(BufferWriter* bw, size_t size, const unsigned char* data) { + BW_ENSURE_CAPACITY(bw, size); + + unsigned char* out = bw->end; + for (size_t i = 0; i < size; ++i) { + out[i] = data[i] & 0x7F; + } + bw->end += size; +} + +extern "C" void bw_append_bsz7(BufferWriter* bw, const unsigned char* data) { + bw_append_bs7(bw, strlen(reinterpret_cast(data)), data); +} + +extern "C" void bw_append_json_escaped(BufferWriter* bw, size_t size, const unsigned char* data) { + BW_ENSURE_CAPACITY(bw, 2 + size * 2); + + unsigned char* dest = bw->end; + *dest++ = '\"'; + + size_t i = 0; + while (i < size) { + switch (data[i]) { + case '\n': *dest++ = '\\'; *dest++ = 'n'; break; + case '\r': *dest++ = '\\'; *dest++ = 'r'; break; + case '\t': *dest++ = '\\'; *dest++ = 't'; break; + case '\\': *dest++ = '\\'; *dest++ = '\\'; break; + case '\"': *dest++ = '\\'; *dest++ = '\"'; break; + default: *dest++ = data[i]; + } + ++i; + } + + *dest++ = '\"'; + bw->end = dest; +} + +extern "C" void bw_append_decimal_signed_int(BufferWriter* bw, int64_t i) { + BW_ENSURE_CAPACITY(bw, 32); // enough + + unsigned used = i64toa_branchlut(i, reinterpret_cast(bw->end)); + bw->end += used; +} + +extern "C" void bw_append_decimal_double(BufferWriter* bw, double d) { + BW_ENSURE_CAPACITY(bw, 318); // sprintf("%f", -DBL_MAX); + + size_t used = sprintf(reinterpret_cast(bw->end), "%f", d); + bw->end += used; +} + +// From +extern "C" void bw_encode_utf8(uint8_t **destp, const uint16_t *src, size_t srcoff, size_t srclen) { + const uint16_t *srcend; + uint8_t *dest = *destp; + + src += srcoff; + srcend = src + srclen; + + ascii: +#if defined(__x86_64__) + while (srcend - src >= 4) { + uint64_t w = *((uint64_t *) src); + + if (w & 0xFF80FF80FF80FF80ULL) { + if (!(w & 0x000000000000FF80ULL)) { + *dest++ = w & 0xFFFF; + src++; + if (!(w & 0x00000000FF800000ULL)) { + *dest++ = (w >> 16) & 0xFFFF; + src++; + if (!(w & 0x0000FF8000000000ULL)) { + *dest++ = (w >> 32) & 0xFFFF; + src++; + } + } + } + break; + } + *dest++ = w & 0xFFFF; + *dest++ = (w >> 16) & 0xFFFF; + *dest++ = (w >> 32) & 0xFFFF; + *dest++ = w >> 48; + src += 4; + } +#endif + +#if defined(__i386__) + while (srcend - src >= 2) { + uint32_t w = *((uint32_t *) src); + + if (w & 0xFF80FF80) + break; + *dest++ = w & 0xFFFF; + *dest++ = w >> 16; + src += 2; + } +#endif + + while (src < srcend) { + uint16_t w = *src++; + + if (w <= 0x7F) { + *dest++ = w; + /* An ASCII byte is likely to begin a run of ASCII bytes. + Falling back into the fast path really helps performance. */ + goto ascii; + } + else if (w <= 0x7FF) { + *dest++ = (w >> 6) | 0xC0; + *dest++ = (w & 0x3f) | 0x80; + } + else if (w < 0xD800 || w > 0xDBFF) { + *dest++ = (w >> 12) | 0xE0; + *dest++ = ((w >> 6) & 0x3F) | 0x80; + *dest++ = (w & 0x3F) | 0x80; + } else { + uint32_t c = ((((uint32_t) w) - 0xD800) << 10) + + (((uint32_t) *src++) - 0xDC00) + 0x10000; + *dest++ = (c >> 18) | 0xF0; + *dest++ = ((c >> 12) & 0x3F) | 0x80; + *dest++ = ((c >> 6) & 0x3F) | 0x80; + *dest++ = (c & 0x3F) | 0x80; + } + } + + *destp = dest; +} + +extern "C" void bw_append_json_escaped_utf16(BufferWriter* bw, size_t size, unsigned short* words) { + // TODO: handle malloc failure + // ideally no temp buffer would be required here. + unsigned char* utf8 = reinterpret_cast(malloc(size * 4)); + assert(utf8); + unsigned char* utf8end = utf8; + + bw_encode_utf8(&utf8end, words, 0, size); + + bw_append_json_escaped(bw, utf8end - utf8, utf8); + + free(utf8); +} + +static const unsigned char UNRESERVED[256] = { + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,1,1,0, + 1,1,1,1, 1,1,1,1, 1,1,0,0, 0,0,0,0, + + 0,1,1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1, + 1,1,1,1, 1,1,1,1, 1,1,1,0, 0,0,0,1, + 0,1,1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1, + 1,1,1,1, 1,1,1,1, 1,1,1,0, 0,0,1,0, + + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0, + 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0 +}; + +static const unsigned char DEC2HEX[16] = { + '0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f' +}; + +extern "C" void bw_append_url_encoded(BufferWriter* bw, size_t size, const unsigned char* data) { + // worst case + BW_ENSURE_CAPACITY(bw, size * 3); + + const unsigned char* src = data; + unsigned char* dst = bw->end; + while (size--) { + unsigned char c = *src++; + if (UNRESERVED[c]) { + *dst++ = c; + } else { + dst[0] = '%'; + dst[1] = DEC2HEX[c >> 4]; + dst[2] = DEC2HEX[c & 0xF]; + dst += 3; + } + } + + bw->end = dst; +} diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +0.2.0.4 + +* Fix a buffer overrun in the double serializer diff --git a/src/Data/BufferBuilder.hs b/src/Data/BufferBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Data/BufferBuilder.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns, RecordWildCards, DeriveDataTypeable #-} + +{-| +A library for efficiently building up a buffer of data. When given data +known to be strict, use of BufferBuilder compiles directly into a series +of efficient C function calls. +-} +module Data.BufferBuilder ( + + -- * The BufferBuilder Monad + BufferBuilder + , runBufferBuilder + + -- * Optional configuration + , Options(..) + , runBufferBuilderWithOptions + + -- * Appending bytes and byte strings + , appendByte + , appendChar8 + , appendBS + , appendLBS + , appendLiteral + , unsafeAppendLiteralN + + -- * Appending bytes and byte strings, truncated to 7 bits + , appendByte7 + , appendChar7 + , appendBS7 + , appendLiteral7 + , unsafeAppendLiteralN7 + + -- * UTF-8 encoding + , appendCharUtf8 + , appendStringUtf8 + + -- * Printing numbers + , appendDecimalSignedInt + , appendDecimalDouble + + -- * JSON escaping + , appendEscapedJson + , appendEscapedJsonLiteral + , appendEscapedJsonText + + -- * URL percent-encoding + , appendUrlEncoded + ) where + +import GHC.Base +import GHC.Word +import GHC.Ptr +import GHC.IO +import GHC.ForeignPtr +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Lazy as BSL +import Control.Applicative (Applicative(..), pure) +import Control.Exception (Exception, throw) +import Control.Monad (when) +import Data.Typeable (Typeable) + +import Data.Text () -- Show +import Data.Text.Internal (Text (..)) +import Data.Text.Array (Array (..)) + +data Handle' +type Handle = Ptr Handle' + +foreign import ccall unsafe "strlen" c_strlen :: Ptr Word8 -> IO Int +foreign import ccall unsafe "bw_new" bw_new :: Int -> IO Handle +foreign import ccall unsafe "&bw_free" bw_free :: FunPtr (Handle -> IO ()) +foreign import ccall unsafe "bw_trim" bw_trim :: Handle -> IO () +foreign import ccall unsafe "bw_get_size" bw_get_size :: Handle -> IO Int +foreign import ccall unsafe "bw_release_address" bw_release_address :: Handle -> IO (Ptr Word8) + +foreign import ccall unsafe "bw_append_byte" bw_append_byte :: Handle -> Word8 -> IO () +foreign import ccall unsafe "bw_append_char_utf8" bw_append_char_utf8 :: Handle -> Char -> IO () +foreign import ccall unsafe "bw_append_bs" bw_append_bs :: Handle -> Int -> Ptr Word8 -> IO () +foreign import ccall unsafe "bw_append_bsz" bw_append_bsz :: Handle -> Ptr Word8 -> IO () + +foreign import ccall unsafe "bw_append_byte7" bw_append_byte7 :: Handle -> Word8 -> IO () +foreign import ccall unsafe "bw_append_bs7" bw_append_bs7 :: Handle -> Int -> Ptr Word8 -> IO () +foreign import ccall unsafe "bw_append_bsz7" bw_append_bsz7 :: Handle -> Ptr Word8 -> IO () + +foreign import ccall unsafe "bw_append_decimal_signed_int" bw_append_decimal_signed_int :: Handle -> Int -> IO () +foreign import ccall unsafe "bw_append_decimal_double" bw_append_decimal_double :: Handle -> Double -> IO () + +foreign import ccall unsafe "bw_append_json_escaped" bw_append_json_escaped :: Handle -> Int -> Ptr Word8 -> IO () +foreign import ccall unsafe "bw_append_json_escaped_utf16" bw_append_json_escaped_utf16 :: Handle -> Int -> Ptr Word16 -> IO () + +foreign import ccall unsafe "bw_append_url_encoded" bw_append_url_encoded :: Handle -> Int -> Ptr Word8 -> IO () + +-- | BufferBuilder is the type of a monadic action that appends to an implicit, +-- growable buffer. Use 'runBufferBuilder' to extract the resulting +-- buffer as a 'BS.ByteString'. +newtype BufferBuilder a = BB (Handle -> IO a) + --deriving (Applicative, Monad, MonadReader Handle) + +unBB :: BufferBuilder a -> (Handle -> IO a) +unBB (BB a) = a + +instance Functor BufferBuilder where + {-# INLINE fmap #-} + fmap f (BB a) = BB $ \h -> fmap f (a h) + +instance Applicative BufferBuilder where + {-# INLINE pure #-} + pure = BB . const . pure + + {-# INLINE (<*>) #-} + (BB f) <*> (BB a) = BB $ \h -> (f h) <*> (a h) + +instance Monad BufferBuilder where + {-# INLINE return #-} + return = BB . const . return + + {-# INLINE (>>=) #-} + (BB lhs) >>= next = BB $ \h -> do + a <- lhs h + unBB (next a) h + +withHandle :: (Handle -> IO ()) -> BufferBuilder () +withHandle = BB +{-# INLINE withHandle #-} + +data BufferOutOfMemoryError = BufferOutOfMemoryError + deriving (Show, Typeable) +instance Exception BufferOutOfMemoryError + +data Options = Options + { initialCapacity :: !Int + , trimFinalBuffer :: !Bool + } + +defaultOptions :: Options +defaultOptions = Options + { initialCapacity = 128 -- some quantitative data would be great + , trimFinalBuffer = False + } + +-- | Run a sequence of 'BufferBuilder' actions and extract the resulting +-- buffer as a 'BS.ByteString'. +runBufferBuilder :: BufferBuilder () -> BS.ByteString +runBufferBuilder = runBufferBuilderWithOptions defaultOptions + +runBufferBuilderWithOptions :: Options -> BufferBuilder () -> BS.ByteString +runBufferBuilderWithOptions options = unsafeDupablePerformIO . runBufferBuilderIO options + +runBufferBuilderIO :: Options-> BufferBuilder () -> IO BS.ByteString +runBufferBuilderIO !Options{..} !(BB bw) = do + handle <- bw_new initialCapacity + when (handle == nullPtr) $ do + throw BufferOutOfMemoryError + + handleFP <- newForeignPtr bw_free handle + () <- bw handle + + when trimFinalBuffer $ do + bw_trim handle + + -- FFI doesn't support returning multiple arguments, so we need + -- two calls: one for the size and the other to release the + -- pointer. + size <- bw_get_size handle + src <- bw_release_address handle + + when (src == nullPtr) $ do + throw BufferOutOfMemoryError + + borrowed <- newForeignPtr finalizerFree src + let bs = BS.fromForeignPtr borrowed 0 size + touchForeignPtr handleFP + return bs + +-- | Append a single byte to the output buffer. To append multiple bytes in sequence and +-- avoid redundant bounds checks, consider using 'appendBS', 'appendLiteral', or 'unsafeAppendLiteralN'. +appendByte :: Word8 -> BufferBuilder () +appendByte b = withHandle $ \h -> bw_append_byte h b +{-# INLINE appendByte #-} + +c2w :: Char -> Word8 +c2w = fromIntegral . ord +{-# INLINE c2w #-} + +-- | Appends a character to the buffer, truncating it to the bottom 8 bits. +appendChar8 :: Char -> BufferBuilder () +appendChar8 = appendByte . c2w +{-# INLINE appendChar8 #-} + +-- | Appends a 'BS.ByteString' to the buffer. When appending constant, hardcoded strings, to +-- avoid a CAF and the costs of its associated tag check and indirect jump, use +-- 'appendLiteral' or 'unsafeAppendLiteralN' instead. +appendBS :: BS.ByteString -> BufferBuilder () +appendBS !(BS.PS fp offset len) = + withHandle $ \h -> + withForeignPtr fp $ \addr -> + bw_append_bs h len (plusPtr addr offset) +{-# INLINE appendBS #-} + +-- | Appends a lazy 'BSL.ByteString' to the buffer. This function operates by traversing +-- the lazy 'BSL.ByteString' chunks, appending each in turn. +appendLBS :: BSL.ByteString -> BufferBuilder () +appendLBS lbs = mapM_ appendBS $ BSL.toChunks lbs +{-# INLINABLE appendLBS #-} + +-- | Appends a zero-terminated MagicHash string literal. Use this function instead of +-- 'appendBS' for string constants. For example: +-- +-- > appendLiteral "true"# +-- +-- If the length of the string literal is known, calling +-- 'unsafeAppendLiteralN' is faster, as 'unsafeAppendLiteralN' avoids a strlen +-- operation which has nontrivial cost in some benchmarks. +appendLiteral :: Addr# -> BufferBuilder () +appendLiteral addr = + withHandle $ \h -> + bw_append_bsz h (Ptr addr) +{-# INLINE appendLiteral #-} + +-- | Appends a MagicHash string literal with a known length. Use this when the +-- string literal's length is known. For example: +-- +-- > unsafeAppendLiteralN 4 "true"# +-- +-- Per byte, this is the fastest append function. It amounts to a C function call +-- with two constant arguments. The C function checks to see if it needs to grow +-- the buffer and then it simply calls memcpy. +-- +-- __WARNING__: passing an incorrect length value is likely to cause an access +-- violation or worse. +unsafeAppendLiteralN :: Int -> Addr# -> BufferBuilder () +unsafeAppendLiteralN len addr = + withHandle $ \h -> + bw_append_bs h len (Ptr addr) +{-# INLINE unsafeAppendLiteralN #-} + + +-- 7-bit truncation + +appendByte7 :: Word8 -> BufferBuilder () +appendByte7 b = withHandle $ \h -> bw_append_byte7 h b +{-# INLINE appendByte7 #-} + +appendChar7 :: Char -> BufferBuilder () +appendChar7 = appendByte7 . c2w +{-# INLINE appendChar7 #-} + +appendBS7 :: BS.ByteString -> BufferBuilder () +appendBS7 !(BS.PS fp offset len) = + withHandle $ \h -> + withForeignPtr fp $ \addr -> + bw_append_bs7 h len (plusPtr addr offset) +{-# INLINE appendBS7 #-} + +appendLiteral7 :: Addr# -> BufferBuilder () +appendLiteral7 addr = + withHandle $ \h -> + bw_append_bsz7 h (Ptr addr) +{-# INLINE appendLiteral7 #-} + +unsafeAppendLiteralN7 :: Int -> Addr# -> BufferBuilder () +unsafeAppendLiteralN7 len addr = + withHandle $ \h -> + bw_append_bs7 h len (Ptr addr) +{-# INLINE unsafeAppendLiteralN7 #-} + +-- Encoding UTF-8 + +-- | Appends a UTF-8-encoded 'Char' to the buffer. +appendCharUtf8 :: Char -> BufferBuilder () +appendCharUtf8 c = withHandle $ \h -> bw_append_char_utf8 h c +{-# INLINE appendCharUtf8 #-} + +-- | Appends a UTF-8-encoded 'String' to the buffer. The best way to improve performance here +-- is to use 'BS.ByteString' or 'Text' instead of 'String'. +appendStringUtf8 :: String -> BufferBuilder () +appendStringUtf8 = mapM_ appendCharUtf8 +{-# INLINABLE appendStringUtf8 #-} + + +-- Printing Numbers + +-- | Appends a decimal integer, just like calling printf("%d", ...) +appendDecimalSignedInt :: Int -> BufferBuilder () +appendDecimalSignedInt i = + withHandle $ \h -> + bw_append_decimal_signed_int h i +{-# INLINE appendDecimalSignedInt #-} + +-- | Appends a decimal double, just like calling printf("%f", ...) +appendDecimalDouble :: Double -> BufferBuilder () +appendDecimalDouble d = + withHandle $ \h -> + bw_append_decimal_double h d +{-# INLINE appendDecimalDouble #-} + + +-- Encoding JSON + +appendEscapedJson :: BS.ByteString -> BufferBuilder () +appendEscapedJson !(BS.PS (ForeignPtr addr _) offset len) = + withHandle $ \h -> + bw_append_json_escaped h len (plusPtr (Ptr addr) offset) +{-# INLINE appendEscapedJson #-} + +appendEscapedJsonLiteral :: Addr# -> BufferBuilder () +appendEscapedJsonLiteral addr = + withHandle $ \h -> do + len <- c_strlen (Ptr addr) + bw_append_json_escaped h len (Ptr addr) +{-# INLINE appendEscapedJsonLiteral #-} + +appendEscapedJsonText :: Text -> BufferBuilder () +appendEscapedJsonText !(Text arr ofs len) = + let byteArray = aBA arr + in withHandle $ \h -> + bw_append_json_escaped_utf16 h len (Ptr (byteArrayContents# byteArray) `plusPtr` ofs) +{-# INLINE appendEscapedJsonText #-} + +-- | Append a percent-encoded ByteString. All characters except for +-- alphanumerics, -, ., _, and ~ will be encoded. The string produced +-- by URL encoding is guaranteed ASCII-7 and thus valid UTF-8. +-- Moreover, it is not required to be JSON-escaped. +appendUrlEncoded :: BS.ByteString -> BufferBuilder () +appendUrlEncoded !(BS.PS (ForeignPtr addr _) offset len) = + withHandle $ \h -> + bw_append_url_encoded h len (plusPtr (Ptr addr) offset) +{-# INLINE appendUrlEncoded #-} diff --git a/src/Data/BufferBuilder/Json.hs b/src/Data/BufferBuilder/Json.hs new file mode 100644 --- /dev/null +++ b/src/Data/BufferBuilder/Json.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns, UndecidableInstances #-} + +{-| +A library for efficiently building up a valid JSON document. + +The difference between "Data.BufferBuilder.Json" and the excellent +"Data.Aeson" is that Aeson represents the JSON document as an +in-memory tree structure before encoding it into bytes. This module, +on the other hand, represents each value as an action that writes its +representation directly into the output buffer. At the cost of +reduced flexibility, this results in significantly improved encoding +performance. At the time of this writing, encoding a custom record +type into JSON using this module was almost 5x faster than using +Aeson. + +This module is built on top of "Data.Utf8Builder". +-} +module Data.BufferBuilder.Json + ( + -- * Encoding Values + Value + , ToJson (..) + , encodeJson + + -- * Objects + , ObjectBuilder + , emptyObject + , (.=) + , (.=#) + + -- * Arrays + , array + + -- * Null + , nullValue + + -- * Unsafe + , unsafeAppendBS + , unsafeAppendUtf8Builder + ) where + +import GHC.Base +import Foreign.Storable +import Control.Monad (when, forM_) +import Data.BufferBuilder.Utf8 (Utf8Builder) +import qualified Data.BufferBuilder.Utf8 as UB +import Data.ByteString (ByteString) +import Data.Monoid +import Data.Text (Text) +import Data.Foldable (Foldable, foldMap) +import qualified Data.Vector as Vector +import qualified Data.Vector.Generic as GVector +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Data.HashMap.Strict as HashMap + +-- | Represents a JSON value. +-- +-- 'Value's are built up from either 'ToJson' instances or +-- from primitives like 'emptyObject', 'array', and 'null'. +-- +-- In special cases, or when performance is of utmost importance, the +-- unsafe functions 'unsafeAppendBS' and 'unsafeAppendUtf8Builder' are +-- available. +-- +-- Internally, Value encodes an action or sequence of actions that append +-- JSON-encoded text to the underlying 'Utf8Builder'. +newtype Value = Value { utf8Builder :: Utf8Builder () } + +-- | The class of types that can be converted to JSON values. See +-- 'ObjectBuilder' for an example of writing a 'ToJson' instance for a +-- custom data type. +-- +-- 'ToJson' instances are provided for many common types. For +-- example, to create a JSON array, call 'toJson' on a list or 'Vector.Vector'. +-- To create a JSON object, call 'toJson' on a 'HashMap.HashMap'. +class ToJson a where + toJson :: a -> Value + +---- General JSON value support + +-- | Encode a value into a 'ByteString' containing valid UTF-8-encoded JSON. +-- The argument value must have a corresponding 'ToJson' instance. +-- +-- __WARNING__: There are three cases where the resulting 'ByteString' may not contain +-- legal JSON: +-- +-- * An unsafe function was used to encode a JSON value. +-- * The root value is not an object or array, as the JSON specification requires. +-- * An object has multiple keys with the same value. For maximum efficiency, +-- 'ObjectBuilder' does not check key names for uniqueness, so it's possible to +-- construct objects with duplicate keys. +encodeJson :: ToJson a => a -> ByteString +encodeJson = UB.runUtf8Builder . utf8Builder . toJson +{-# INLINE encodeJson #-} + +---- Objects + +-- | Builds a JSON object. +-- +-- An 'ObjectBuilder' builds one or more key-value pairs of a JSON object. They are constructed with the '.=' operator and +-- combined with 'Data.Monoid.<>'. +-- +-- To turn an 'ObjectBuilder' into a 'Value', use its 'ToJson' class instance. +-- +-- @ +-- data Friend = Friend +-- { fId :: !Int +-- , fName :: !Text +-- } deriving (Eq, Show) +-- +-- instance ToJson Friend where +-- toJson friend = toJson $ +-- "id" .= fId friend +-- <> "name" .= fName friend +-- @ +-- +-- __WARNING__: 'ObjectBuilder' does not check uniqueness of object +-- keys. If two keys with the same value are inserted, then the +-- resulting JSON document will be illegal. +data ObjectBuilder = NoPair | Pair !(Utf8Builder ()) + +instance Monoid ObjectBuilder where + {-# INLINE mempty #-} + mempty = NoPair + + {-# INLINE mappend #-} + mappend NoPair a = a + mappend a NoPair = a + mappend (Pair a) (Pair b) = Pair $ do + a + UB.appendChar7 ',' + b + +instance ToJson ObjectBuilder where + {-# INLINE toJson #-} + toJson NoPair = Value $ do + UB.appendChar7 '{' + UB.appendChar7 '}' + + toJson (Pair a) = Value $ do + UB.appendChar7 '{' + a + UB.appendChar7 '}' + +-- | A 'Value' that produces the empty object. +emptyObject :: Value +emptyObject = toJson NoPair +{-# INLINE emptyObject #-} + +-- | Create an 'ObjectBuilder' from a key and a value. +(.=) :: ToJson a => Text -> a -> ObjectBuilder +a .= b = Pair $ do + UB.appendEscapedJsonText a + UB.appendChar7 ':' + utf8Builder $ toJson b +infixr 8 .= +{-# INLINE (.=) #-} + +-- | Create an 'ObjectBuilder' from a key and a value. The key is an +-- ASCII-7, unescaped, zero-terminated 'Addr#'. +-- +-- __WARNING__: This function is unsafe. If the key is NOT +-- zero-terminated, then an access violation might result. If the key +-- is not a sequence of unescaped ASCII characters, the resulting JSON +-- document will be illegal. +-- +-- This function is provided for maximum performance in the common +-- case that object keys are ASCII-7. It achieves performance by +-- avoiding the CAF for a Text literal and avoiding the need to +-- transcode UTF-16 to UTF-8 and escape. +-- +-- To use this function, the calling source file must have the +-- MagicHash extension enabled. +-- +-- @ +-- data Friend = Friend +-- { fId :: !Int +-- , fName :: !Text +-- } deriving (Eq, Show) +-- +-- instance ToJson Friend where +-- toJson friend = toJson $ +-- "id"\# .=\# fId friend +-- <> "name"\# .=\# fName friend +-- @ +(.=#) :: ToJson a => Addr# -> a -> ObjectBuilder +a .=# b = Pair $ do + UB.appendEscapedJsonLiteral a + UB.appendChar7 ':' + utf8Builder $ toJson b +infixr 8 .=# +{-# INLINE (.=#) #-} + + +{-# INLINE writePair #-} +writePair :: ToJson a => (Text, a) -> Utf8Builder () +writePair (key, value) = do + UB.appendEscapedJsonText key + UB.appendChar7 ':' + utf8Builder $ toJson value + +instance ToJson a => ToJson (HashMap.HashMap Text a) where + {-# INLINABLE toJson #-} + toJson hm = Value $ do + UB.appendChar7 '{' + case HashMap.toList hm of + [] -> UB.appendChar7 '}' + (x:xs) -> do + writePair x + forM_ xs $ \p -> do + UB.appendChar7 ',' + writePair p + UB.appendChar7 '}' + +---- Arrays + +-- | Serialize any 'Foldable' as a JSON array. This is generally +-- slower than directly calling 'toJson' on a list or 'Vector.Vector', +-- but it will convert any 'Foldable' type into an array. +array :: (Foldable t, ToJson a) => t a -> Value +array collection = Value $ do + UB.appendChar7 '[' + -- HACK: ObjectBuilder is not "type correct" but it has exactly the behaviour we want for this function. + case foldMap (Pair . utf8Builder . toJson) collection of + NoPair -> return () + (Pair b) -> b + UB.appendChar7 ']' +{-# INLINABLE array #-} + +instance ToJson a => ToJson [a] where + {-# INLINABLE toJson #-} + toJson !ls = Value $ do + UB.appendChar7 '[' + case ls of + [] -> UB.appendChar7 ']' + x:xs -> do + utf8Builder $ toJson x + forM_ xs $ \(!e) -> do + UB.appendChar7 ',' + utf8Builder $ toJson e + UB.appendChar7 ']' + +instance ToJson a => ToJson (Vector.Vector a) where + {-# INLINABLE toJson #-} + toJson = vector + +instance (Storable a, ToJson a) => ToJson (VS.Vector a) where + {-# INLINABLE toJson #-} + toJson = vector + +instance (VP.Prim a, ToJson a) => ToJson (VP.Vector a) where + {-# INLINABLE toJson #-} + toJson = vector + +instance (GVector.Vector VU.Vector a, ToJson a) => ToJson (VU.Vector a) where + {-# INLINABLE toJson #-} + toJson = vector + +{-# INLINABLE vector #-} +vector :: (GVector.Vector v a, ToJson a) => v a -> Value +vector !vec = Value $ do + UB.appendChar7 '[' + let len = GVector.length vec + when (len /= 0) $ do + utf8Builder $ toJson (vec `GVector.unsafeIndex` 0) + GVector.forM_ (GVector.tail vec) $ \e -> do + UB.appendChar7 ',' + utf8Builder $ toJson e + UB.appendChar7 ']' + + +---- + +-- | Represents a JSON "null". +nullValue :: Value +nullValue = Value $ UB.unsafeAppendLiteralN 4 "null"# +{-# INLINE nullValue #-} + +---- Common JSON instances + +instance ToJson Value where + {-# INLINE toJson #-} + toJson = id + +instance ToJson Bool where + {-# INLINE toJson #-} + toJson True = Value $ UB.unsafeAppendLiteralN 4 "true"# + toJson False = Value $ UB.unsafeAppendLiteralN 5 "false"# + +instance ToJson a => ToJson (Maybe a) where + {-# INLINE toJson #-} + toJson m = case m of + Nothing -> Value $ UB.unsafeAppendLiteralN 4 "null"# + Just a -> toJson a + +instance ToJson Text where + {-# INLINE toJson #-} + toJson txt = Value $ UB.appendEscapedJsonText txt + +instance ToJson Double where + {-# INLINE toJson #-} + toJson a = Value $ UB.appendDecimalDouble a + +instance ToJson Int where + {-# INLINE toJson #-} + toJson a = Value $ UB.appendDecimalSignedInt a + + +---- Unsafe functions + +-- | Unsafely append a string into a JSON document. +-- This function does /not/ escape, quote, or otherwise decorate the string in any way. +-- This function is /unsafe/ because you can trivially use it to generate illegal JSON. +unsafeAppendBS :: ByteString -> Value +unsafeAppendBS bs = Value $ UB.unsafeAppendBS bs + +-- | Unsafely append a 'Utf8Builder' into a JSON document. +-- This function does not escape, quote, or decorate the string in any way. +-- This function is /unsafe/ because you can trivially use it to generate illegal JSON. +unsafeAppendUtf8Builder :: Utf8Builder () -> Value +unsafeAppendUtf8Builder utf8b = Value utf8b diff --git a/src/Data/BufferBuilder/Utf8.hs b/src/Data/BufferBuilder/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Data/BufferBuilder/Utf8.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MagicHash, BangPatterns #-} + +{-| +A library for efficiently building up a buffer of UTF-8-encoded text. If only +safe functions are used, the resulting 'ByteString' is guaranteed to be valid +UTF-8. + +To run a sequence of Utf8Builder actions and retrieve the resulting buffer, use +'runUtf8Builder'. + +In special situations, for maximum performance, unsafe functions are +also provided. The unsafe functions do not guarantee the buffer is +correct UTF-8. + +This module is built on top of "Data.BufferBuilder". +-} +module Data.BufferBuilder.Utf8 ( + + -- * The Utf8Builder Monad + Utf8Builder + , runUtf8Builder + + -- * Text encoding + , appendText + , appendString + , appendChar + + -- * ASCII-7 + , appendByte7 + , appendChar7 + , appendBS7 + , appendLiteral7 + + -- * Printing numbers + , appendDecimalSignedInt + , appendDecimalDouble + + -- * Escaped JSON + , appendEscapedJson + , appendEscapedJsonLiteral + , appendEscapedJsonText + + -- * Unsafe append operations + , unsafeAppendByte + , unsafeAppendChar8 + , unsafeAppendLiteral + , unsafeAppendLiteralN + , unsafeAppendBS + ) where + +import GHC.Base +import GHC.Word +import Control.Applicative +import Data.ByteString (ByteString) +import Data.BufferBuilder (BufferBuilder) +import qualified Data.BufferBuilder as BB +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) + +newtype Utf8Builder a = Utf8Builder { unBuilder :: BufferBuilder a } + deriving (Functor, Applicative, Monad) + +-- | Run a sequence of 'Utf8Builder' actions and extracting the resulting +-- buffer as a 'ByteString'. +runUtf8Builder :: Utf8Builder () -> ByteString +runUtf8Builder a = BB.runBufferBuilder $ unBuilder a +{-# INLINE runUtf8Builder #-} + + +-- Text encoding + +-- TODO: optimize appendText with custom UTF-16 -> UTF-8 encoder in C + +-- | Encodes the given 'Text' in UTF-8, appending it to the buffer. +appendText :: Text -> Utf8Builder () +appendText a = Utf8Builder $ BB.appendBS $ encodeUtf8 a +{-# INLINE appendText #-} + +-- | Encodes the given 'String' in UTF-8, appending it to the buffer. +appendString :: String -> Utf8Builder () +appendString s = mapM_ appendChar s +{-# INLINABLE appendString #-} + +-- | Encodes a single 'Char' in UTF-8, appending it to the buffer. +appendChar :: Char -> Utf8Builder () +appendChar c = Utf8Builder $ BB.appendCharUtf8 c +{-# INLINE appendChar #-} + + +-- ASCII-7 + +-- | Appends the bottom 7 bits of a byte to the buffer. +appendByte7 :: Word8 -> Utf8Builder () +appendByte7 = Utf8Builder . BB.appendByte7 +{-# INLINE appendByte7 #-} + +-- | Appends the bottom 7 bits of a 'Char' to the buffer. +appendChar7 :: Char -> Utf8Builder () +appendChar7 = Utf8Builder . BB.appendChar7 +{-# INLINE appendChar7 #-} + +-- | Appends the given ByteString to the buffer, taking the bottom +-- 7 bits of each byte. +appendBS7 :: ByteString -> Utf8Builder () +appendBS7 = Utf8Builder . BB.appendBS7 +{-# INLINE appendBS7 #-} + +-- | Appends the zero-terminated byte string at the given address +-- to the buffer, taking the bottom 7 bits of each byte. +appendLiteral7 :: Addr# -> Utf8Builder () +appendLiteral7 addr = Utf8Builder $ BB.appendLiteral7 addr +{-# INLINE appendLiteral7 #-} + + +-- Printing numbers + +appendDecimalSignedInt :: Int -> Utf8Builder () +appendDecimalSignedInt a = Utf8Builder $ BB.appendDecimalSignedInt a +{-# INLINE appendDecimalSignedInt #-} + +appendDecimalDouble :: Double -> Utf8Builder () +appendDecimalDouble d = Utf8Builder $ BB.appendDecimalDouble d +{-# INLINE appendDecimalDouble #-} + + +-- Escaped JSON + +appendEscapedJsonLiteral :: Addr# -> Utf8Builder () +appendEscapedJsonLiteral addr = Utf8Builder $ BB.appendEscapedJsonLiteral addr + +appendEscapedJson :: ByteString -> Utf8Builder () +appendEscapedJson a = Utf8Builder $ BB.appendEscapedJson a +{-# INLINE appendEscapedJson #-} + +appendEscapedJsonText :: Text -> Utf8Builder () +appendEscapedJsonText txt = Utf8Builder $ BB.appendEscapedJsonText txt +{-# INLINE appendEscapedJsonText #-} + + +-- Unsafe + +-- | Directly append a byte into the UTF-8 code stream. Incorrect use of +-- this function can result in invalid UTF-8. +unsafeAppendByte :: Word8 -> Utf8Builder () +unsafeAppendByte = Utf8Builder . BB.appendByte +{-# INLINE unsafeAppendByte #-} + +-- | Directly append the bottom 8 bits of the given character to the UTF-8 +-- code stream. Incorrect use of this function can result in invalid UTF-8. +unsafeAppendChar8 :: Char -> Utf8Builder () +unsafeAppendChar8 = Utf8Builder . BB.appendChar8 +{-# INLINE unsafeAppendChar8 #-} + +-- | Directly append the zero-terminated byte sequence pointed to by +-- the given address. Be careful that the referenced byte sequence +-- contains valid UTF-8. +unsafeAppendLiteral :: Addr# -> Utf8Builder () +unsafeAppendLiteral addr = Utf8Builder $ BB.appendLiteral addr +{-# INLINE unsafeAppendLiteral #-} + +-- | Directly append the given byte sequence pointed to by the given address. +-- Be careful that the referenced byte sequence contains valid UTF-8. +-- +-- __WARNING__: passing an incorrect length value is likely to cause an access +-- violation or worse. +unsafeAppendLiteralN :: Int -> Addr# -> Utf8Builder () +unsafeAppendLiteralN !len addr = Utf8Builder $ BB.unsafeAppendLiteralN len addr +{-# INLINE unsafeAppendLiteralN #-} + +-- | Directly append the given 'ByteString' to the output buffer. +-- Be careful that the referenced 'ByteString' contains valid UTF-8. +unsafeAppendBS :: ByteString -> Utf8Builder () +unsafeAppendBS a = Utf8Builder $ BB.appendBS a +{-# INLINE unsafeAppendBS #-} diff --git a/test/BufferTest.hs b/test/BufferTest.hs --- a/test/BufferTest.hs +++ b/test/BufferTest.hs @@ -33,6 +33,20 @@ appendLiteral "bar"# assertEqual "matches" "foobar" result +case_append_url_encoded_safe :: Assertion +case_append_url_encoded_safe = do + let safe = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_" + let result = runBufferBuilder $ do + appendUrlEncoded safe + assertEqual "matches" safe result + +case_append_url_encoded_unsafe :: Assertion +case_append_url_encoded_unsafe = do + let safe = "\0\1 /\\$%" + let result = runBufferBuilder $ do + appendUrlEncoded safe + assertEqual "matches" "%00%01%20%2f%5c%24%25" result + prop_match_intDec :: Int -> Bool prop_match_intDec i = runBufferBuilder (appendDecimalSignedInt i) == (BSC.pack $ show i)