diff --git a/Blaze/ByteString/Builder.hs b/Blaze/ByteString/Builder.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Blaze.ByteString.Builder +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- "Blaze.ByteString.Builder" is the main module, which you should import as a user +-- of the @blaze-builder@ library. +-- +-- > import Blaze.ByteString.Builder +-- +-- It provides you with a type 'Builder' that allows to efficiently construct +-- lazy bytestrings with a large average chunk size. +-- +-- Intuitively, a 'Builder' denotes the construction of a part of a lazy +-- bytestring. Builders can either be created using one of the primitive +-- combinators in "Blaze.ByteString.Builder.Write" or by using one of the predefined +-- combinators for standard Haskell values (see the exposed modules of this +-- package). Concatenation of builders is done using 'mappend' from the +-- 'Monoid' typeclass. +-- +-- Here is a small example that serializes a list of strings using the UTF-8 +-- encoding. +-- +-- @ import "Blaze.ByteString.Builder.Char.Utf8"@ +-- +-- > strings :: [String] +-- > strings = replicate 10000 "Hello there!" +-- +-- The function @'fromString'@ creates a 'Builder' denoting the UTF-8 encoded +-- argument. Hence, UTF-8 encoding and concatenating all @strings@ can be done +-- follows. +-- +-- > concatenation :: Builder +-- > concatenation = mconcat $ map fromString strings +-- +-- The function 'toLazyByteString' can be used to execute a 'Builder' and +-- obtain the resulting lazy bytestring. +-- +-- > result :: L.ByteString +-- > result = toLazyByteString concatenation +-- +-- The @result@ is a lazy bytestring containing 10000 repetitions of the string +-- @\"Hello there!\"@ encoded using UTF-8. The corresponding 120000 bytes are +-- distributed among three chunks of 32kb and a last chunk of 6kb. +-- +-- /A note on history./ This serialization library was inspired by the +-- @Data.Binary.Builder@ module provided by the @binary@ package. It was +-- originally developed with the specific needs of the @blaze-html@ package in +-- mind. Since then it has been restructured to serve as a drop-in replacement +-- for @Data.Binary.Builder@, which it improves upon both in speed as well as +-- expressivity. +-- +------------------------------------------------------------------------------ + +module Blaze.ByteString.Builder + ( + -- * The 'Builder' type + B.Builder + + -- * Creating builders + , module Blaze.ByteString.Builder.Int + , module Blaze.ByteString.Builder.Word + , module Blaze.ByteString.Builder.ByteString + , B.flush + + -- * Executing builders + , B.toLazyByteString + , toLazyByteStringWith + , toByteString + , toByteStringIO + , toByteStringIOWith + + -- * 'Write's + , W.Write + , W.fromWrite + , W.fromWriteSingleton + , W.fromWriteList + , writeToByteString + + -- ** Writing 'Storable's + , W.writeStorable + , W.fromStorable + , W.fromStorables + + ) where + +import Control.Monad(unless) + +#if __GLASGOW_HASKELL__ >= 702 +import Foreign +import qualified Foreign.ForeignPtr.Unsafe as Unsafe +#else +import Foreign as Unsafe +#endif + +import qualified Blaze.ByteString.Builder.Internal.Write as W +import Blaze.ByteString.Builder.ByteString +import Blaze.ByteString.Builder.Word +import Blaze.ByteString.Builder.Int + +import Data.ByteString.Builder ( Builder ) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B + +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L + +#if __GLASGOW_HASKELL__ >= 702 +import System.IO.Unsafe (unsafeDupablePerformIO) +#else +unsafeDupablePerformIO :: IO a -> a +unsafeDupablePerformIO = unsafePerformIO +#endif + + + +-- | Pack the chunks of a lazy bytestring into a single strict bytestring. +packChunks :: L.ByteString -> S.ByteString +packChunks lbs = do + S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs) + where + copyChunks !L.Empty !_pf = return () + copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do + withForeignPtr fpbuf $ \pbuf -> + copyBytes pf (pbuf `plusPtr` o) l + copyChunks lbs' (pf `plusPtr` l) + +-- | Run the builder to construct a strict bytestring containing the sequence +-- of bytes denoted by the builder. This is done by first serializing to a lazy bytestring and then packing its +-- chunks to a appropriately sized strict bytestring. +-- +-- > toByteString = packChunks . toLazyByteString +-- +-- Note that @'toByteString'@ is a 'Monoid' homomorphism. +-- +-- > toByteString mempty == mempty +-- > toByteString (x `mappend` y) == toByteString x `mappend` toByteString y +-- +-- However, in the second equation, the left-hand-side is generally faster to +-- execute. +-- +toByteString :: Builder -> S.ByteString +toByteString = packChunks . B.toLazyByteString + +-- | Default size (~32kb) for the buffer that becomes a chunk of the output +-- stream once it is filled. +-- +defaultBufferSize :: Int +defaultBufferSize = 32 * 1024 - overhead -- Copied from Data.ByteString.Lazy. + where overhead = 2 * sizeOf (undefined :: Int) + + +-- | @toByteStringIOWith bufSize io b@ runs the builder @b@ with a buffer of +-- at least the size @bufSize@ and executes the 'IO' action @io@ whenever the +-- buffer is full. +-- +-- Compared to 'toLazyByteStringWith' this function requires less allocation, +-- as the output buffer is only allocated once at the start of the +-- serialization and whenever something bigger than the current buffer size has +-- to be copied into the buffer, which should happen very seldomly for the +-- default buffer size of 32kb. Hence, the pressure on the garbage collector is +-- reduced, which can be an advantage when building long sequences of bytes. +-- +toByteStringIO :: (S.ByteString -> IO ()) -> Builder -> IO () +toByteStringIO = toByteStringIOWith defaultBufferSize + +toByteStringIOWith :: Int -- ^ Buffer size (upper bounds + -- the number of bytes forced + -- per call to the 'IO' action). + -> (S.ByteString -> IO ()) -- ^ 'IO' action to execute per + -- full buffer, which is + -- referenced by a strict + -- 'S.ByteString'. + -> Builder -- ^ 'Builder' to run. + -> IO () -- ^ Resulting 'IO' action. +toByteStringIOWith !bufSize io builder = do + S.mallocByteString bufSize >>= getBuffer (B.runBuilder builder) bufSize + where + getBuffer writer !size fp = do + let !ptr = Unsafe.unsafeForeignPtrToPtr fp + (bytes, next) <- writer ptr size + case next of + B.Done -> io $! S.PS fp 0 bytes + B.More req writer' -> do + io $! S.PS fp 0 bytes + let !size' = max bufSize req + S.mallocByteString size' >>= getBuffer writer' size' + B.Chunk bs' writer' -> do + if bytes > 0 + then do + io $! S.PS fp 0 bytes + unless (S.null bs') (io bs') + S.mallocByteString bufSize >>= getBuffer writer' bufSize + else do + unless (S.null bs') (io bs') + getBuffer writer' size fp + + +-- | Run a 'Builder' with the given buffer sizes. +-- +-- Use this function for integrating the 'Builder' type with other libraries +-- that generate lazy bytestrings. +-- +-- Note that the builders should guarantee that on average the desired chunk +-- size is attained. Builders may decide to start a new buffer and not +-- completely fill the existing buffer, if this is faster. However, they should +-- not spill too much of the buffer, if they cannot compensate for it. +-- +-- FIXME: Note that the following paragraphs are not entirely correct as of +-- blaze-builder-0.4: +-- +-- A call @toLazyByteStringWith bufSize minBufSize firstBufSize@ will generate +-- a lazy bytestring according to the following strategy. First, we allocate +-- a buffer of size @firstBufSize@ and start filling it. If it overflows, we +-- allocate a buffer of size @minBufSize@ and copy the first buffer to it in +-- order to avoid generating a too small chunk. Finally, every next buffer will +-- be of size @bufSize@. This, slow startup strategy is required to achieve +-- good speed for short (<200 bytes) resulting bytestrings, as for them the +-- allocation cost is of a large buffer cannot be compensated. Moreover, this +-- strategy also allows us to avoid spilling too much memory for short +-- resulting bytestrings. +-- +-- Note that setting @firstBufSize >= minBufSize@ implies that the first buffer +-- is no longer copied but allocated and filled directly. Hence, setting +-- @firstBufSize = bufSize@ means that all chunks will use an underlying buffer +-- of size @bufSize@. This is recommended, if you know that you always output +-- more than @minBufSize@ bytes. +toLazyByteStringWith + :: Int -- ^ Buffer size (upper-bounds the resulting chunk size). + -> Int -- ^ This parameter is ignored as of blaze-builder-0.4 + -> Int -- ^ Size of the first buffer to be used and copied for + -- larger resulting sequences + -> Builder -- ^ Builder to run. + -> L.ByteString -- ^ Lazy bytestring to output after the builder is + -- finished. + -> L.ByteString -- ^ Resulting lazy bytestring +toLazyByteStringWith bufSize _minBufSize firstBufSize builder k = + B.toLazyByteStringWith (B.safeStrategy firstBufSize bufSize) k builder + +-- | Run a 'Write' to produce a strict 'S.ByteString'. +-- This is equivalent to @('toByteString' . 'fromWrite')@, but is more +-- efficient because it uses just one appropriately-sized buffer. +writeToByteString :: W.Write -> S.ByteString +writeToByteString !w = unsafeDupablePerformIO $ do + fptr <- S.mallocByteString (W.getBound w) + len <- withForeignPtr fptr $ \ptr -> do + end <- W.runWrite w ptr + return $! end `minusPtr` ptr + return $! S.fromForeignPtr fptr 0 len +{-# INLINE writeToByteString #-} diff --git a/Blaze/ByteString/Builder/ByteString.hs b/Blaze/ByteString/Builder/ByteString.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/ByteString.hs @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Blaze.ByteString.Builder.ByteString +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- 'Write's and 'B.Builder's for strict and lazy bytestrings. +-- +-- We assume the following qualified imports in order to differentiate between +-- strict and lazy bytestrings in the code examples. +-- +-- > import qualified Data.ByteString as S +-- > import qualified Data.ByteString.Lazy as L +-- +------------------------------------------------------------------------------ + +module Blaze.ByteString.Builder.ByteString + ( + -- * Strict bytestrings + writeByteString + , fromByteString + , fromByteStringWith + , copyByteString + , insertByteString + + -- * Lazy bytestrings + , fromLazyByteString + , fromLazyByteStringWith + , copyLazyByteString + , insertLazyByteString + + ) where + + +import Blaze.ByteString.Builder.Internal.Write ( Write, exactWrite ) +import Foreign +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L + + +-- | Write a strict 'S.ByteString' to a buffer. +writeByteString :: S.ByteString -> Write +writeByteString bs = exactWrite l io + where + (fptr, o, l) = S.toForeignPtr bs + io pf = withForeignPtr fptr $ \p -> copyBytes pf (p `plusPtr` o) l +{-# INLINE writeByteString #-} + +-- | Create a 'B.Builder' denoting the same sequence of bytes as a strict +-- 'S.ByteString'. +-- The 'B.Builder' inserts large 'S.ByteString's directly, but copies small ones +-- to ensure that the generated chunks are large on average. +fromByteString :: S.ByteString -> B.Builder +fromByteString = B.byteString +{-# INLINE fromByteString #-} + + +-- | Construct a 'B.Builder' that copies the strict 'S.ByteString's, if it is +-- smaller than the treshold, and inserts it directly otherwise. +-- +-- For example, @fromByteStringWith 1024@ copies strict 'S.ByteString's whose size +-- is less or equal to 1kb, and inserts them directly otherwise. This implies +-- that the average chunk-size of the generated lazy 'L.ByteString' may be as +-- low as 513 bytes, as there could always be just a single byte between the +-- directly inserted 1025 byte, strict 'S.ByteString's. +-- +fromByteStringWith :: Int -- ^ Maximal number of bytes to copy. + -> S.ByteString -- ^ Strict 'S.ByteString' to serialize. + -> B.Builder -- ^ Resulting 'B.Builder'. +fromByteStringWith = B.byteStringThreshold +{-# INLINE fromByteStringWith #-} + +-- | Construct a 'B.Builder' that copies the strict 'S.ByteString'. +-- +-- Use this function to create 'B.Builder's from smallish (@<= 4kb@) +-- 'S.ByteString's or if you need to guarantee that the 'S.ByteString' is not +-- shared with the chunks generated by the 'B.Builder'. +-- +copyByteString :: S.ByteString -> B.Builder +copyByteString = B.byteStringCopy +{-# INLINE copyByteString #-} + +-- | Construct a 'B.Builder' that always inserts the strict 'S.ByteString' +-- directly as a chunk. +-- +-- This implies flushing the output buffer, even if it contains just +-- a single byte. You should therefore use 'insertByteString' only for large +-- (@> 8kb@) 'S.ByteString's. Otherwise, the generated chunks are too +-- fragmented to be processed efficiently afterwards. +-- +insertByteString :: S.ByteString -> B.Builder +insertByteString = B.byteStringInsert +{-# INLINE insertByteString #-} + +-- | Create a 'B.Builder' denoting the same sequence of bytes as a lazy +-- 'S.ByteString'. +-- The 'B.Builder' inserts large chunks of the lazy 'L.ByteString' directly, +-- but copies small ones to ensure that the generated chunks are large on +-- average. +-- +fromLazyByteString :: L.ByteString -> B.Builder +fromLazyByteString = B.lazyByteString +{-# INLINE fromLazyByteString #-} + +-- | Construct a 'B.Builder' that uses the thresholding strategy of 'fromByteStringWith' +-- for each chunk of the lazy 'L.ByteString'. +-- +fromLazyByteStringWith :: Int -> L.ByteString -> B.Builder +fromLazyByteStringWith = B.lazyByteStringThreshold +{-# INLINE fromLazyByteStringWith #-} + +-- | Construct a 'B.Builder' that copies the lazy 'L.ByteString'. +-- +copyLazyByteString :: L.ByteString -> B.Builder +copyLazyByteString = B.lazyByteStringCopy +{-# INLINE copyLazyByteString #-} + +-- | Construct a 'B.Builder' that inserts all chunks of the lazy 'L.ByteString' +-- directly. +-- +insertLazyByteString :: L.ByteString -> B.Builder +insertLazyByteString = B.lazyByteStringInsert +{-# INLINE insertLazyByteString #-} diff --git a/Blaze/ByteString/Builder/Char8.hs b/Blaze/ByteString/Builder/Char8.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Char8.hs @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Blaze.ByteString.Builder.Char8 +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- //Note:// This package is intended for low-level use like implementing +-- protocols. If you need to //serialize// Unicode characters use one of the +-- UTF encodings (e.g. 'Blaze.ByteString.Builder.Char.UTF-8'). +-- +-- 'Write's and 'Builder's for serializing the lower 8-bits of characters. +-- +-- This corresponds to what the 'bytestring' package offer in +-- 'Data.ByteString.Char8'. +-- +------------------------------------------------------------------------------ + +module Blaze.ByteString.Builder.Char8 + ( + -- * Writing Latin-1 (ISO 8859-1) encodable characters to a buffer + writeChar + + -- * Creating Builders from Latin-1 (ISO 8859-1) encodable characters + , fromChar + , fromString + , fromShow + , fromText + , fromLazyText + ) where + +import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed ) +import Data.ByteString.Builder ( Builder ) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.Text as TS +import qualified Data.Text.Lazy as TL + +-- | Write the lower 8-bits of a character to a buffer. +writeChar :: Char -> Write +writeChar = writePrimFixed P.char8 +{-# INLINE writeChar #-} + +-- | /O(1)/. Serialize the lower 8-bits of a character. +fromChar :: Char -> Builder +fromChar = B.char8 +{-# INLINE fromChar #-} + +-- | /O(n)/. Serialize the lower 8-bits of all characters of a string +fromString :: String -> Builder +fromString = P.primMapListFixed P.char8 +{-# INLINE fromString #-} + +-- | /O(n)/. Serialize a value by 'Show'ing it and serializing the lower 8-bits +-- of the resulting string. +fromShow :: Show a => a -> Builder +fromShow = fromString . show +{-# INLINE fromShow #-} + +-- | /O(n)/. Serialize the lower 8-bits of all characters in the strict text. +fromText :: TS.Text -> Builder +fromText = fromString . TS.unpack +{-# INLINE fromText #-} + +-- | /O(n)/. Serialize the lower 8-bits of all characters in the lazy text. +fromLazyText :: TL.Text -> Builder +fromLazyText = fromString . TL.unpack +{-# INLINE fromLazyText #-} diff --git a/Blaze/ByteString/Builder/Compat/Write.hs b/Blaze/ByteString/Builder/Compat/Write.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Compat/Write.hs @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Blaze.ByteString.Builder.Compat.Write +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Conversions from the new Prims to the old Writes. +-- +------------------------------------------------------------------------------ + +module Blaze.ByteString.Builder.Compat.Write + ( Write + , writePrimFixed + , writePrimBounded + ) where + +import Data.ByteString.Builder.Prim.Internal (BoundedPrim, FixedPrim + , runB, runF, size, sizeBound) +import Blaze.ByteString.Builder.Internal.Write (Poke(..), Write + , boundedWrite, exactWrite) + +writePrimFixed :: FixedPrim a -> a -> Write +writePrimFixed fe a = exactWrite (size fe) (runF fe a) +{-# INLINE writePrimFixed #-} + +writePrimBounded :: BoundedPrim a -> a -> Write +writePrimBounded be a = boundedWrite (sizeBound be) (Poke (runB be a)) +{-# INLINE writePrimBounded #-} diff --git a/Blaze/ByteString/Builder/Int.hs b/Blaze/ByteString/Builder/Int.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Int.hs @@ -0,0 +1,258 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Blaze.ByteString.Builder.Int +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- 'Write's and 'Builder's for serializing integers. +-- +-- See "Blaze.ByteString.Builder.Word" for information about how to best write several +-- integers at once. +-- +------------------------------------------------------------------------------ + +module Blaze.ByteString.Builder.Int + ( + -- * Writing integers to a buffer + + writeInt8 + + -- ** Big-endian writes + , writeInt16be -- :: Int16 -> Write + , writeInt32be -- :: Int32 -> Write + , writeInt64be -- :: Int64 -> Write + + -- ** Little-endian writes + , writeInt16le -- :: Int16 -> Write + , writeInt32le -- :: Int32 -> Write + , writeInt64le -- :: Int64 -> Write + + -- ** Host-endian writes + , writeInthost -- :: Int -> Write + , writeInt16host -- :: Int16 -> Write + , writeInt32host -- :: Int32 -> Write + , writeInt64host -- :: Int64 -> Write + + -- * Creating builders from integers + + -- | We provide serialization functions both for singleton integers as well as + -- for lists of integers. Using these list serialization functions is /much/ faster + -- than using @mconcat . map fromInt/@, as the list serialization + -- functions use a tighter inner loop. + + , fromInt8 + , fromInt8s + + -- ** Big-endian serialization + , fromInt16be -- :: Int16 -> Builder + , fromInt32be -- :: Int32 -> Builder + , fromInt64be -- :: Int64 -> Builder + , fromInt32sbe -- :: [Int32] -> Builder + , fromInt16sbe -- :: [Int16] -> Builder + , fromInt64sbe -- :: [Int64] -> Builder + + -- ** Little-endian serialization + , fromInt16le -- :: Int16 -> Builder + , fromInt32le -- :: Int32 -> Builder + , fromInt64le -- :: Int64 -> Builder + , fromInt16sle -- :: [Int16] -> Builder + , fromInt32sle -- :: [Int32] -> Builder + , fromInt64sle -- :: [Int64] -> Builder + + -- ** Host-endian serialization + , fromInthost -- :: Int -> Builder + , fromInt16host -- :: Int16 -> Builder + , fromInt32host -- :: Int32 -> Builder + , fromInt64host -- :: Int64 -> Builder + , fromIntshost -- :: [Int] -> Builder + , fromInt16shost -- :: [Int16] -> Builder + , fromInt32shost -- :: [Int32] -> Builder + , fromInt64shost -- :: [Int64] -> Builder + + ) where + +import Data.Int +import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed ) +import Data.ByteString.Builder ( Builder ) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +import qualified Data.ByteString.Builder.Prim as P + +-- | Write a single signed byte. +-- +writeInt8 :: Int8 -> Write +writeInt8 = writePrimFixed P.int8 +{-# INLINE writeInt8 #-} + +-- | Write an 'Int16' in big endian format. +writeInt16be :: Int16 -> Write +writeInt16be = writePrimFixed P.int16BE +{-# INLINE writeInt16be #-} + +-- | Write an 'Int32' in big endian format. +writeInt32be :: Int32 -> Write +writeInt32be = writePrimFixed P.int32BE +{-# INLINE writeInt32be #-} + +-- | Write an 'Int64' in big endian format. +writeInt64be :: Int64 -> Write +writeInt64be = writePrimFixed P.int64BE +{-# INLINE writeInt64be #-} + +-- | Write an 'Int16' in little endian format. +writeInt16le :: Int16 -> Write +writeInt16le = writePrimFixed P.int16LE +{-# INLINE writeInt16le #-} + +-- | Write an 'Int32' in little endian format. +writeInt32le :: Int32 -> Write +writeInt32le = writePrimFixed P.int32LE +{-# INLINE writeInt32le #-} + +-- | Write an 'Int64' in little endian format. +writeInt64le :: Int64 -> Write +writeInt64le = writePrimFixed P.int64LE +{-# INLINE writeInt64le #-} + +-- | Write a single native machine 'Int'. The 'Int' is written in host order, +-- host endian form, for the machine you're on. On a 64 bit machine the 'Int' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this way +-- are not portable to different endian or integer sized machines, without +-- conversion. +-- +writeInthost :: Int -> Write +writeInthost = writePrimFixed P.intHost +{-# INLINE writeInthost #-} + +-- | Write an 'Int16' in native host order and host endianness. +writeInt16host :: Int16 -> Write +writeInt16host = writePrimFixed P.int16Host +{-# INLINE writeInt16host #-} + +-- | Write an 'Int32' in native host order and host endianness. +writeInt32host :: Int32 -> Write +writeInt32host = writePrimFixed P.int32Host +{-# INLINE writeInt32host #-} + +-- | Write an 'Int64' in native host order and host endianness. +writeInt64host :: Int64 -> Write +writeInt64host = writePrimFixed P.int64Host +{-# INLINE writeInt64host #-} + +-- | Serialize a single byte. +fromInt8 :: Int8 -> Builder +fromInt8 = B.int8 +{-# INLINE fromInt8 #-} + +-- | Serialize a list of bytes. +fromInt8s :: [Int8] -> Builder +fromInt8s = P.primMapListFixed P.int8 +{-# INLINE fromInt8s #-} + +-- | Serialize an 'Int16' in big endian format. +fromInt16be :: Int16 -> Builder +fromInt16be = B.int16BE +{-# INLINE fromInt16be #-} + +-- | Serialize an 'Int32' in big endian format. +fromInt32be :: Int32 -> Builder +fromInt32be = B.int32BE +{-# INLINE fromInt32be #-} + +-- | Serialize an 'Int64' in big endian format. +fromInt64be :: Int64 -> Builder +fromInt64be = B.int64BE +{-# INLINE fromInt64be #-} + +-- | Serialize a list of 'Int32's in big endian format. +fromInt32sbe :: [Int32] -> Builder +fromInt32sbe = P.primMapListFixed P.int32BE +{-# INLINE fromInt32sbe #-} + +-- | Serialize a list of 'Int16's in big endian format. +fromInt16sbe :: [Int16] -> Builder +fromInt16sbe = P.primMapListFixed P.int16BE +{-# INLINE fromInt16sbe #-} + +-- | Serialize a list of 'Int64's in big endian format. +fromInt64sbe :: [Int64] -> Builder +fromInt64sbe = P.primMapListFixed P.int64BE +{-# INLINE fromInt64sbe #-} + +-- | Serialize an 'Int16' in little endian format. +fromInt16le :: Int16 -> Builder +fromInt16le = B.int16LE +{-# INLINE fromInt16le #-} + +-- | Serialize an 'Int32' in little endian format. +fromInt32le :: Int32 -> Builder +fromInt32le = B.int32LE +{-# INLINE fromInt32le #-} + +-- | Serialize an 'Int64' in little endian format. +fromInt64le :: Int64 -> Builder +fromInt64le = B.int64LE +{-# INLINE fromInt64le #-} + +-- | Serialize a list of 'Int16's in little endian format. +fromInt16sle :: [Int16] -> Builder +fromInt16sle = P.primMapListFixed P.int16LE +{-# INLINE fromInt16sle #-} + +-- | Serialize a list of 'Int32's in little endian format. +fromInt32sle :: [Int32] -> Builder +fromInt32sle = P.primMapListFixed P.int32LE +{-# INLINE fromInt32sle #-} + +-- | Serialize a list of 'Int64's in little endian format. +fromInt64sle :: [Int64] -> Builder +fromInt64sle = P.primMapListFixed P.int64LE +{-# INLINE fromInt64sle #-} + +-- | Serialize a single native machine 'Int'. The 'Int' is serialized in host +-- order, host endian form, for the machine you're on. On a 64 bit machine the +-- 'Int' is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this +-- way are not portable to different endian or integer sized machines, without +-- conversion. +-- +fromInthost :: Int -> Builder +fromInthost = B.intHost +{-# INLINE fromInthost #-} + +-- | Write an 'Int16' in native host order and host endianness. +fromInt16host :: Int16 -> Builder +fromInt16host = B.int16Host +{-# INLINE fromInt16host #-} + +-- | Write an 'Int32' in native host order and host endianness. +fromInt32host :: Int32 -> Builder +fromInt32host = B.int32Host +{-# INLINE fromInt32host #-} + +-- | Write an 'Int64' in native host order and host endianness. +fromInt64host :: Int64 -> Builder +fromInt64host = B.int64Host +{-# INLINE fromInt64host #-} + +-- | Serialize a list of 'Int's. +-- See 'fromInthost' for usage considerations. +fromIntshost :: [Int] -> Builder +fromIntshost = P.primMapListFixed P.intHost +{-# INLINE fromIntshost #-} + +-- | Write a list of 'Int16's in native host order and host endianness. +fromInt16shost :: [Int16] -> Builder +fromInt16shost = P.primMapListFixed P.int16Host +{-# INLINE fromInt16shost #-} + +-- | Write a list of 'Int32's in native host order and host endianness. +fromInt32shost :: [Int32] -> Builder +fromInt32shost = P.primMapListFixed P.int32Host +{-# INLINE fromInt32shost #-} + +-- | Write a list of 'Int64's in native host order and host endianness. +fromInt64shost :: [Int64] -> Builder +fromInt64shost = P.primMapListFixed P.int64Host +{-# INLINE fromInt64shost #-} diff --git a/Blaze/ByteString/Builder/Internal/Write.hs b/Blaze/ByteString/Builder/Internal/Write.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Internal/Write.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +-- | +-- Module : Blaze.ByteString.Builder.Internal.Poke +-- Copyright : (c) 2010 Simon Meier +-- (c) 2010 Jasper van der Jeugt +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Leon Smith +-- Stability : experimental +-- Portability : tested on GHC only +-- +-- A general and efficient write type that allows for the easy construction of +-- builders for (smallish) bounded size writes to a buffer. +-- +-- FIXME: Improve documentation. +-- +module Blaze.ByteString.Builder.Internal.Write ( + -- * Poking a buffer + Poke(..) + , pokeN + + -- * Writing to abuffer + , Write(..) + , runWrite + , getBound + , getBound' + , getPoke + + , exactWrite + , boundedWrite + , writeLiftIO + , writeIf + , writeEq + , writeOrdering + , writeOrd + + -- * Constructing builders from writes + , fromWrite + , fromWriteSingleton + , fromWriteList + + -- * Writing 'Storable's + , writeStorable + , fromStorable + , fromStorables + + ) where + +import Foreign + +import Control.Monad + +import Data.ByteString.Builder.Internal + +import Data.Monoid (Monoid(..)) +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +#endif + +import Prelude -- Silence redundant import warnings + +------------------------------------------------------------------------------ +-- Poking a buffer and writing to a buffer +------------------------------------------------------------------------------ + +-- Sadly GHC is not smart enough: code where we branch and each branch should +-- execute a few IO actions and then return a value cannot be taught to GHC. At +-- least not such that it returns the value of the branches unpacked. +-- +-- Hmm.. at least he behaves much better for the Monoid instance of Write +-- than the one for Poke. Serializing UTF-8 chars gets a slowdown of a +-- factor 2 when 2 chars are composed. Perhaps I should try out the writeList +-- instances also, as they may be more sensitive to to much work per Char. +-- + +-- | Changing a sequence of bytes starting from the given pointer. 'Poke's are +-- the most primitive buffer manipulation. In most cases, you don't use the +-- explicitely but as part of a 'Write', which also tells how many bytes will +-- be changed at most. +newtype Poke = + Poke { runPoke :: Ptr Word8 -> IO (Ptr Word8) } + +-- | A write of a bounded number of bytes. +-- +-- When defining a function @write :: a -> Write@ for some @a@, then it is +-- important to ensure that the bound on the number of bytes written is +-- data-independent. Formally, +-- +-- @ forall x y. getBound (write x) = getBound (write y) @ +-- +-- The idea is that this data-independent bound is specified such that the +-- compiler can optimize the check, if there are enough free bytes in the buffer, +-- to a single subtraction between the pointer to the next free byte and the +-- pointer to the end of the buffer with this constant bound of the maximal +-- number of bytes to be written. +-- +data Write = Write {-# UNPACK #-} !Int Poke + +-- | Extract the 'Poke' action of a write. +{-# INLINE getPoke #-} +getPoke :: Write -> Poke +getPoke (Write _ wio) = wio + +-- | Run the 'Poke' action of a write. +{-# INLINE runWrite #-} +runWrite :: Write -> Ptr Word8 -> IO (Ptr Word8) +runWrite = runPoke . getPoke + +-- | Extract the maximal number of bytes that this write could write. +{-# INLINE getBound #-} +getBound :: Write -> Int +getBound (Write bound _) = bound + +-- | Extract the maximal number of bytes that this write could write in any +-- case. Assumes that the bound of the write is data-independent. +{-# INLINE getBound' #-} +getBound' :: String -- ^ Name of caller: for debugging purposes. + -> (a -> Write) + -> Int +getBound' msg write = + getBound $ write $ error $ + "getBound' called from " ++ msg ++ ": write bound is not data-independent." + +#if MIN_VERSION_base(4,9,0) +instance Semigroup Poke where + {-# INLINE (<>) #-} + (Poke po1) <> (Poke po2) = Poke $ po1 >=> po2 + + {-# INLINE sconcat #-} + sconcat = foldr (<>) mempty +#endif + +instance Monoid Poke where + {-# INLINE mempty #-} + mempty = Poke $ return + +#if !(MIN_VERSION_base(4,11,0)) + {-# INLINE mappend #-} + (Poke po1) `mappend` (Poke po2) = Poke $ po1 >=> po2 +#endif + + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty + +#if MIN_VERSION_base(4,9,0) +instance Semigroup Write where + {-# INLINE (<>) #-} + (Write bound1 w1) <> (Write bound2 w2) = + Write (bound1 + bound2) (w1 <> w2) + + {-# INLINE sconcat #-} + sconcat = foldr (<>) mempty +#endif + +instance Monoid Write where + {-# INLINE mempty #-} + mempty = Write 0 mempty + +#if !(MIN_VERSION_base(4,11,0)) + {-# INLINE mappend #-} + (Write bound1 w1) `mappend` (Write bound2 w2) = + Write (bound1 + bound2) (w1 `mappend` w2) +#endif + + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty + +-- | @pokeN size io@ creates a write that denotes the writing of @size@ bytes +-- to a buffer using the IO action @io@. Note that @io@ MUST write EXACTLY @size@ +-- bytes to the buffer! +{-# INLINE pokeN #-} +pokeN :: Int + -> (Ptr Word8 -> IO ()) -> Poke +pokeN size io = Poke $ \op -> io op >> (return $! (op `plusPtr` size)) + + +-- | @exactWrite size io@ creates a bounded write that can later be converted to +-- a builder that writes exactly @size@ bytes. Note that @io@ MUST write +-- EXACTLY @size@ bytes to the buffer! +{-# INLINE exactWrite #-} +exactWrite :: Int + -> (Ptr Word8 -> IO ()) + -> Write +exactWrite size io = Write size (pokeN size io) + +-- | @boundedWrite size write@ creates a bounded write from a @write@ that does +-- not write more than @size@ bytes. +{-# INLINE boundedWrite #-} +boundedWrite :: Int -> Poke -> Write +boundedWrite = Write + +-- | @writeLiftIO io write@ creates a write executes the @io@ action to compute +-- the value that is then written. +{-# INLINE writeLiftIO #-} +writeLiftIO :: (a -> Write) -> IO a -> Write +writeLiftIO write io = + Write (getBound' "writeLiftIO" write) + (Poke $ \pf -> do x <- io; runWrite (write x) pf) + +-- | @writeIf p wTrue wFalse x@ creates a 'Write' with a 'Poke' equal to @wTrue +-- x@, if @p x@ and equal to @wFalse x@ otherwise. The bound of this new +-- 'Write' is the maximum of the bounds for either 'Write'. This yields a data +-- independent bound, if the bound for @wTrue@ and @wFalse@ is already data +-- independent. +{-# INLINE writeIf #-} +writeIf :: (a -> Bool) -> (a -> Write) -> (a -> Write) -> (a -> Write) +writeIf p wTrue wFalse x = + boundedWrite (max (getBound $ wTrue x) (getBound $ wFalse x)) + (if p x then getPoke $ wTrue x else getPoke $ wFalse x) + +-- | Compare the value to a test value and use the first write action for the +-- equal case and the second write action for the non-equal case. +{-# INLINE writeEq #-} +writeEq :: Eq a => a -> (a -> Write) -> (a -> Write) -> (a -> Write) +writeEq test = writeIf (test ==) + +-- | TODO: Test this. It might well be too difficult to use. +-- FIXME: Better name required! +{-# INLINE writeOrdering #-} +writeOrdering :: (a -> Ordering) + -> (a -> Write) -> (a -> Write) -> (a -> Write) + -> (a -> Write) +writeOrdering ord wLT wEQ wGT x = + boundedWrite bound (case ord x of LT -> getPoke $ wLT x; + EQ -> getPoke $ wEQ x; + GT -> getPoke $ wGT x) + where + bound = max (getBound $ wLT x) (max (getBound $ wEQ x) (getBound $ wGT x)) + +-- | A write combinator useful to build decision trees for deciding what value +-- to write with a constant bound on the maximal number of bytes written. +{-# INLINE writeOrd #-} +writeOrd :: Ord a + => a + -> (a -> Write) -> (a -> Write) -> (a -> Write) + -> (a -> Write) +writeOrd test = writeOrdering (`compare` test) + +-- | Create a builder that execute a single 'Write'. +{-# INLINE fromWrite #-} +fromWrite :: Write -> Builder +fromWrite (Write maxSize wio) = + builder step + where + step k (BufferRange op ope) + | op `plusPtr` maxSize <= ope = do + op' <- runPoke wio op + let !br' = BufferRange op' ope + k br' + | otherwise = return $ bufferFull maxSize op (step k) + +{-# INLINE fromWriteSingleton #-} +fromWriteSingleton :: (a -> Write) -> (a -> Builder) +fromWriteSingleton write = + mkBuilder + where + mkBuilder x = builder step + where + step k (BufferRange op ope) + | op `plusPtr` maxSize <= ope = do + op' <- runPoke wio op + let !br' = BufferRange op' ope + k br' + | otherwise = return $ bufferFull maxSize op (step k) + where + Write maxSize wio = write x + + +-- | Construct a 'Builder' writing a list of data one element at a time. +fromWriteList :: (a -> Write) -> [a] -> Builder +fromWriteList write = + makeBuilder + where + makeBuilder xs0 = builder $ step xs0 + where + step xs1 k !(BufferRange op0 ope0) = go xs1 op0 + where + go [] !op = do + let !br' = BufferRange op ope0 + k br' + + go xs@(x':xs') !op + | op `plusPtr` maxSize <= ope0 = do + !op' <- runPoke wio op + go xs' op' + | otherwise = return $ bufferFull maxSize op (step xs k) + where + Write maxSize wio = write x' +{-# INLINE fromWriteList #-} + + + +------------------------------------------------------------------------------ +-- Writing storables +------------------------------------------------------------------------------ + + +-- | Write a storable value. +{-# INLINE writeStorable #-} +writeStorable :: Storable a => a -> Write +writeStorable x = exactWrite (sizeOf x) (\op -> poke (castPtr op) x) + +-- | A builder that serializes a storable value. No alignment is done. +{-# INLINE fromStorable #-} +fromStorable :: Storable a => a -> Builder +fromStorable = fromWriteSingleton writeStorable + +-- | A builder that serializes a list of storable values by writing them +-- consecutively. No alignment is done. Parsing information needs to be +-- provided externally. +fromStorables :: Storable a => [a] -> Builder +fromStorables = fromWriteList writeStorable diff --git a/Blaze/ByteString/Builder/Word.hs b/Blaze/ByteString/Builder/Word.hs new file mode 100644 --- /dev/null +++ b/Blaze/ByteString/Builder/Word.hs @@ -0,0 +1,268 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Blaze.ByteString.Builder.Word +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- 'Write's and 'Builder's for serializing words. +-- +-- Note that for serializing a three tuple @(x,y,z)@ of bytes (or other word +-- values) you should use the expression +-- +-- > fromWrite $ writeWord8 x `mappend` writeWord8 y `mappend` writeWord z +-- +-- instead of +-- +-- > fromWord8 x `mappend` fromWord8 y `mappend` fromWord z +-- +-- The first expression will result in a single atomic write of three bytes, +-- while the second expression will check for each byte, if there is free space +-- left in the output buffer. Coalescing these checks can improve performance +-- quite a bit, as long as you use it sensibly. +-- +------------------------------------------------------------------------------ + +module Blaze.ByteString.Builder.Word + ( + -- * Writing words to a buffer + + writeWord8 + + -- ** Big-endian writes + , writeWord16be -- :: Word16 -> Write + , writeWord32be -- :: Word32 -> Write + , writeWord64be -- :: Word64 -> Write + + -- ** Little-endian writes + , writeWord16le -- :: Word16 -> Write + , writeWord32le -- :: Word32 -> Write + , writeWord64le -- :: Word64 -> Write + + -- ** Host-endian writes + , writeWordhost -- :: Word -> Write + , writeWord16host -- :: Word16 -> Write + , writeWord32host -- :: Word32 -> Write + , writeWord64host -- :: Word64 -> Write + + -- * Creating builders from words + + -- | We provide serialization functions both for singleton words as well as + -- for lists of words. Using these list serialization functions is /much/ faster + -- than using @mconcat . map fromWord/@, as the list serialization + -- functions use a tighter inner loop. + + , fromWord8 + , fromWord8s + + -- ** Big-endian serialization + , fromWord16be -- :: Word16 -> Builder + , fromWord32be -- :: Word32 -> Builder + , fromWord64be -- :: Word64 -> Builder + , fromWord32sbe -- :: [Word32] -> Builder + , fromWord16sbe -- :: [Word16] -> Builder + , fromWord64sbe -- :: [Word64] -> Builder + + -- ** Little-endian serialization + , fromWord16le -- :: Word16 -> Builder + , fromWord32le -- :: Word32 -> Builder + , fromWord64le -- :: Word64 -> Builder + , fromWord16sle -- :: [Word16] -> Builder + , fromWord32sle -- :: [Word32] -> Builder + , fromWord64sle -- :: [Word64] -> Builder + + -- ** Host-endian serialization + , fromWordhost -- :: Word -> Builder + , fromWord16host -- :: Word16 -> Builder + , fromWord32host -- :: Word32 -> Builder + , fromWord64host -- :: Word64 -> Builder + , fromWordshost -- :: [Word] -> Builder + , fromWord16shost -- :: [Word16] -> Builder + , fromWord32shost -- :: [Word32] -> Builder + , fromWord64shost -- :: [Word64] -> Builder + + ) where + +import Data.Word +import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed ) +import Data.ByteString.Builder ( Builder ) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +import qualified Data.ByteString.Builder.Prim as P + +-- | Write a single byte. +-- +writeWord8 :: Word8 -> Write +writeWord8 = writePrimFixed P.word8 +{-# INLINE writeWord8 #-} + +-- | Write a 'Word16' in big endian format. +writeWord16be :: Word16 -> Write +writeWord16be = writePrimFixed P.word16BE +{-# INLINE writeWord16be #-} + +-- | Write a 'Word32' in big endian format. +writeWord32be :: Word32 -> Write +writeWord32be = writePrimFixed P.word32BE +{-# INLINE writeWord32be #-} + +-- | Write a 'Word64' in big endian format. +writeWord64be :: Word64 -> Write +writeWord64be = writePrimFixed P.word64BE +{-# INLINE writeWord64be #-} + +-- | Write a 'Word16' in little endian format. +writeWord16le :: Word16 -> Write +writeWord16le = writePrimFixed P.word16LE +{-# INLINE writeWord16le #-} + +-- | Write a 'Word32' in big endian format. +writeWord32le :: Word32 -> Write +writeWord32le = writePrimFixed P.word32LE +{-# INLINE writeWord32le #-} + +-- | Write a 'Word64' in little endian format. +writeWord64le :: Word64 -> Write +writeWord64le = writePrimFixed P.word64LE +{-# INLINE writeWord64le #-} + +-- | Write a single native machine 'Word'. The 'Word' is written in host order, +-- host endian form, for the machine you're on. On a 64 bit machine the 'Word' +-- is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this way +-- are not portable to different endian or word sized machines, without +-- conversion. +-- +writeWordhost :: Word -> Write +writeWordhost = writePrimFixed P.wordHost +{-# INLINE writeWordhost #-} + +-- | Write a 'Word16' in native host order and host endianness. +writeWord16host :: Word16 -> Write +writeWord16host = writePrimFixed P.word16Host +{-# INLINE writeWord16host #-} + +-- | Write a 'Word32' in native host order and host endianness. +writeWord32host :: Word32 -> Write +writeWord32host = writePrimFixed P.word32Host +{-# INLINE writeWord32host #-} + +-- | Write a 'Word64' in native host order and host endianness. +writeWord64host :: Word64 -> Write +writeWord64host = writePrimFixed P.word64Host +{-# INLINE writeWord64host #-} + +-- | Serialize a single byte. +fromWord8 :: Word8 -> Builder +fromWord8 = B.word8 +{-# INLINE fromWord8 #-} + +-- | Serialize a list of bytes. +fromWord8s :: [Word8] -> Builder +fromWord8s = P.primMapListFixed P.word8 +{-# INLINE fromWord8s #-} + +-- | Serialize a 'Word16' in big endian format. +fromWord16be :: Word16 -> Builder +fromWord16be = B.word16BE +{-# INLINE fromWord16be #-} + +-- | Serialize a 'Word32' in big endian format. +fromWord32be :: Word32 -> Builder +fromWord32be = B.word32BE +{-# INLINE fromWord32be #-} + +-- | Serialize a 'Word64' in big endian format. +fromWord64be :: Word64 -> Builder +fromWord64be = B.word64BE +{-# INLINE fromWord64be #-} + +-- | Serialize a list of 'Word32's in big endian format. +fromWord32sbe :: [Word32] -> Builder +fromWord32sbe = P.primMapListFixed P.word32BE +{-# INLINE fromWord32sbe #-} + +-- | Serialize a list of 'Word16's in big endian format. +fromWord16sbe :: [Word16] -> Builder +fromWord16sbe = P.primMapListFixed P.word16BE +{-# INLINE fromWord16sbe #-} + +-- | Serialize a list of 'Word64's in big endian format. +fromWord64sbe :: [Word64] -> Builder +fromWord64sbe = P.primMapListFixed P.word64BE +{-# INLINE fromWord64sbe #-} + +-- | Serialize a 'Word16' in little endian format. +fromWord16le :: Word16 -> Builder +fromWord16le = B.word16LE +{-# INLINE fromWord16le #-} + +-- | Serialize a list of 'Word32's in little endian format. +fromWord32le :: Word32 -> Builder +fromWord32le = B.word32LE +{-# INLINE fromWord32le #-} + +-- | Serialize a 'Word64' in little endian format. +fromWord64le :: Word64 -> Builder +fromWord64le = B.word64LE +{-# INLINE fromWord64le #-} + +-- | Serialize a list of 'Word16's in little endian format. +fromWord16sle :: [Word16] -> Builder +fromWord16sle = P.primMapListFixed P.word16LE +{-# INLINE fromWord16sle #-} + +-- | Serialize a list of 'Word32's in little endian format. +fromWord32sle :: [Word32] -> Builder +fromWord32sle = P.primMapListFixed P.word32LE +{-# INLINE fromWord32sle #-} + +-- | Serialize a list of 'Word64's in little endian format. +fromWord64sle :: [Word64] -> Builder +fromWord64sle = P.primMapListFixed P.word64LE +{-# INLINE fromWord64sle #-} + +-- | Serialize a single native machine 'Word'. The 'Word' is serialized in host +-- order, host endian form, for the machine you're on. On a 64 bit machine the +-- 'Word' is an 8 byte value, on a 32 bit machine, 4 bytes. Values written this +-- way are not portable to different endian or word sized machines, without +-- conversion. +fromWordhost :: Word -> Builder +fromWordhost = B.wordHost +{-# INLINE fromWordhost #-} + +-- | Write a 'Word16' in native host order and host endianness. +fromWord16host :: Word16 -> Builder +fromWord16host = B.word16Host +{-# INLINE fromWord16host #-} + +-- | Write a 'Word32' in native host order and host endianness. +fromWord32host :: Word32 -> Builder +fromWord32host = B.word32Host +{-# INLINE fromWord32host #-} + +-- | Write a 'Word64' in native host order and host endianness. +fromWord64host :: Word64 -> Builder +fromWord64host = B.word64Host +{-# INLINE fromWord64host #-} + +-- | Serialize a list of 'Word's. +-- See 'fromWordhost' for usage considerations. +fromWordshost :: [Word] -> Builder +fromWordshost = P.primMapListFixed P.wordHost +{-# INLINE fromWordshost #-} + +-- | Write a list of 'Word16's in native host order and host endianness. +fromWord16shost :: [Word16] -> Builder +fromWord16shost = P.primMapListFixed P.word16Host +{-# INLINE fromWord16shost #-} + +-- | Write a list of 'Word32's in native host order and host endianness. +fromWord32shost :: [Word32] -> Builder +fromWord32shost = P.primMapListFixed P.word32Host +{-# INLINE fromWord32shost #-} + +-- | Write a 'Word64' in native host order and host endianness. +fromWord64shost :: [Word64] -> Builder +fromWord64shost = P.primMapListFixed P.word64Host +{-# INLINE fromWord64shost #-} diff --git a/Data/ByteString/Builder/HTTP/Chunked.hs b/Data/ByteString/Builder/HTTP/Chunked.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Builder/HTTP/Chunked.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings #-} +------------------------------------------------------------------------------ +-- | +-- Module: Blaze.ByteString.Builder.HTTP +-- Copyright: (c) 2013 Simon Meier +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Support for HTTP response encoding. +-- +------------------------------------------------------------------------------ + +module Data.ByteString.Builder.HTTP.Chunked ( + -- * Chunked HTTP transfer encoding + chunkedTransferEncoding + , chunkedTransferTerminator + ) where + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..)) +#else +import Data.Word +#endif + +import Foreign + +import qualified Data.ByteString as S +import Data.ByteString.Char8 () + +import Blaze.ByteString.Builder.Internal.Write +import Data.ByteString.Builder +import Data.ByteString.Builder.Internal +import Blaze.ByteString.Builder.ByteString (copyByteString) + +import qualified Blaze.ByteString.Builder.Char8 as Char8 + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + + +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) +#else +shiftr_w32 = shiftR +#endif + + +-- | Write a CRLF sequence. +writeCRLF :: Write +writeCRLF = Char8.writeChar '\r' `mappend` Char8.writeChar '\n' +{-# INLINE writeCRLF #-} + +-- | Execute a write +{-# INLINE execWrite #-} +execWrite :: Write -> Ptr Word8 -> IO () +execWrite w op = do + _ <- runPoke (getPoke w) op + return () + + +------------------------------------------------------------------------------ +-- Hex Encoding Infrastructure +------------------------------------------------------------------------------ + +pokeWord32HexN :: Int -> Word32 -> Ptr Word8 -> IO () +pokeWord32HexN n0 w0 op0 = + go w0 (op0 `plusPtr` (n0 - 1)) + where + go !w !op + | op < op0 = return () + | otherwise = do + let nibble :: Word8 + nibble = fromIntegral w .&. 0xF + hex | nibble < 10 = 48 + nibble + | otherwise = 55 + nibble + poke op hex + go (w `shiftr_w32` 4) (op `plusPtr` (-1)) +{-# INLINE pokeWord32HexN #-} + +iterationsUntilZero :: Integral a => (a -> a) -> a -> Int +iterationsUntilZero f = go 0 + where + go !count 0 = count + go !count !x = go (count+1) (f x) +{-# INLINE iterationsUntilZero #-} + +-- | Length of the hex-string required to encode the given 'Word32'. +word32HexLength :: Word32 -> Int +word32HexLength = max 1 . iterationsUntilZero (`shiftr_w32` 4) +{-# INLINE word32HexLength #-} + +writeWord32Hex :: Word32 -> Write +writeWord32Hex w = + boundedWrite (2 * sizeOf w) (pokeN len $ pokeWord32HexN len w) + where + len = word32HexLength w +{-# INLINE writeWord32Hex #-} + + +------------------------------------------------------------------------------ +-- Chunked transfer encoding +------------------------------------------------------------------------------ + +-- | Transform a builder such that it uses chunked HTTP transfer encoding. +chunkedTransferEncoding :: Builder -> Builder +chunkedTransferEncoding innerBuilder = + builder transferEncodingStep + where + transferEncodingStep k = + go (runBuilder innerBuilder) + where + go innerStep !(BufferRange op ope) + -- FIXME: Assert that outRemaining < maxBound :: Word32 + | outRemaining < minimalBufferSize = + return $ bufferFull minimalBufferSize op (go innerStep) + | otherwise = do + let !brInner@(BufferRange opInner _) = BufferRange + (op `plusPtr` (chunkSizeLength + 2)) -- leave space for chunk header + (ope `plusPtr` (-maxAfterBufferOverhead)) -- leave space at end of data + + -- wraps the chunk, if it is non-empty, and returns the + -- signal constructed with the correct end-of-data pointer + {-# INLINE wrapChunk #-} + wrapChunk :: Ptr Word8 -> (Ptr Word8 -> IO (BuildSignal a)) + -> IO (BuildSignal a) + wrapChunk !opInner' mkSignal + | opInner' == opInner = mkSignal op + | otherwise = do + pokeWord32HexN chunkSizeLength + (fromIntegral $ opInner' `minusPtr` opInner) + op + execWrite writeCRLF (opInner `plusPtr` (-2)) + execWrite writeCRLF opInner' + mkSignal (opInner' `plusPtr` 2) + + -- prepare handlers + doneH opInner' _ = wrapChunk opInner' $ \op' -> do + let !br' = BufferRange op' ope + k br' + + fullH opInner' minRequiredSize nextInnerStep = + wrapChunk opInner' $ \op' -> + return $! bufferFull + (minRequiredSize + maxEncodingOverhead) + op' + (go nextInnerStep) + + insertChunkH opInner' bs nextInnerStep + | S.null bs = -- flush + wrapChunk opInner' $ \op' -> + return $! insertChunk op' S.empty (go nextInnerStep) + + | otherwise = -- insert non-empty bytestring + wrapChunk opInner' $ \op' -> do + -- add header for inserted bytestring + -- FIXME: assert(S.length bs < maxBound :: Word32) + !op'' <- (`runPoke` op') $ getPoke $ + writeWord32Hex (fromIntegral $ S.length bs) + `mappend` writeCRLF + + -- insert bytestring and write CRLF in next buildstep + return $! insertChunk + op'' bs + (runBuilderWith (fromWrite writeCRLF) $ go nextInnerStep) + + -- execute inner builder with reduced boundaries + fillWithBuildStep innerStep doneH fullH insertChunkH brInner + where + -- minimal size guaranteed for actual data no need to require more + -- than 1 byte to guarantee progress the larger sizes will be + -- hopefully provided by the driver or requested by the wrapped + -- builders. + minimalChunkSize = 1 + + -- overhead computation + maxBeforeBufferOverhead = sizeOf (undefined :: Int) + 2 -- max chunk size and CRLF after header + maxAfterBufferOverhead = 2 + -- CRLF after data + sizeOf (undefined :: Int) + 2 -- max bytestring size, CRLF after header + + maxEncodingOverhead = maxBeforeBufferOverhead + maxAfterBufferOverhead + + minimalBufferSize = minimalChunkSize + maxEncodingOverhead + + -- remaining and required space computation + outRemaining :: Int + outRemaining = ope `minusPtr` op + chunkSizeLength = word32HexLength $ fromIntegral outRemaining + + +-- | The zero-length chunk '0\r\n\r\n' signaling the termination of the data transfer. +chunkedTransferTerminator :: Builder +chunkedTransferTerminator = copyByteString "0\r\n\r\n" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jasper Van der Jeugt nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bsb-http-chunked.cabal b/bsb-http-chunked.cabal new file mode 100644 --- /dev/null +++ b/bsb-http-chunked.cabal @@ -0,0 +1,74 @@ +Name: bsb-http-chunked +Version: 0 +Synopsis: Chunked HTTP transfer encoding for bytestring builders + +Description: This library is a new home for the + Blaze.ByteString.Builder.HTTP module from the blaze-builder + package. + +Author: Jasper Van der Jeugt, Simon Meier, Leon P Smith +Copyright: (c) 2010-2014 Simon Meier + (c) 2010 Jasper Van der Jeugt + (c) 2013-2015 Leon P Smith +Maintainer: Simon Jakobi + +License: BSD3 +License-file: LICENSE + +Homepage: http://github.com/sjakobi/bsb-http-chunked +Bug-Reports: http://github.com/sjakobi/bsb-http-chunked/issues +Stability: Provisional + +Category: Data, Network +Build-type: Simple +Cabal-version: >= 1.8 + +Extra-source-files: tests/*.hs + +Source-repository head + Type: git + Location: https://github.com/sjakobi/bsb-http-chunked.git + +Library + ghc-options: -Wall + + exposed-modules: Data.ByteString.Builder.HTTP.Chunked + + other-modules: Blaze.ByteString.Builder + Blaze.ByteString.Builder.ByteString + Blaze.ByteString.Builder.Char8 + Blaze.ByteString.Builder.Compat.Write + Blaze.ByteString.Builder.Int + Blaze.ByteString.Builder.Internal.Write + Blaze.ByteString.Builder.Word + + build-depends: base >= 4.3 && < 4.12, + deepseq, + text >= 0.10 && < 1.3 + + if impl(ghc < 7.8) + build-depends: bytestring >= 0.9 && < 0.11, + bytestring-builder + else + build-depends: bytestring >= 0.10.4 && < 0.11 + +test-suite test + -- Turn off until the package is cleaned up + buildable: False + type: exitcode-stdio-1.0 + + hs-source-dirs: tests + main-is: Tests.hs + + ghc-options: -Wall -fno-warn-orphans + + build-depends: base + , blaze-builder + , bytestring + , HUnit + , QuickCheck + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , text + , utf8-string diff --git a/tests/LlvmSegfault.hs b/tests/LlvmSegfault.hs new file mode 100644 --- /dev/null +++ b/tests/LlvmSegfault.hs @@ -0,0 +1,35 @@ +-- Author: Simon Meier , 10/06/2010 +-- +-- Attempt to find a small test-case for the segfaults that happen when +-- compiling the benchmarks with LLVM and GHC-7.0.1 +-- +module LlvmSegfault where + +import Data.Word +import Data.Monoid +import qualified Data.ByteString.Lazy as L + +import Foreign + +import Blaze.ByteString.Builder.Internal + + + +fromWord8 :: Word8 -> Builder +fromWord8 w = + Builder step + where + step k pf pe + | pf < pe = do + poke pf w + let pf' = pf `plusPtr` 1 + pf' `seq` k pf' pe + | otherwise = return $ BufferFull 1 pf (step k) + + +word8s :: Builder +word8s = map (fromWord8 . fromIntegral) $ [(1::Int)..1000] + +main :: IO () +main = + print $ toLazyByteStringWith 10 10 (mconcat word8s) L.empty diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# OPTIONS_GHC -fsimpl-tick-factor=40000 #-} +#endif +-- | Tests for the Blaze builder +-- +module Main where + +import Control.Applicative ((<$>)) +import Data.Monoid (mempty, mappend, mconcat) + +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as LB +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.Framework.Providers.HUnit +import Test.QuickCheck +import Test.HUnit hiding (Test) +import Codec.Binary.UTF8.String (decode) + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 +import Blaze.ByteString.Builder.Html.Utf8 + +main :: IO () +main = defaultMain $ return $ testGroup "Tests" tests + +tests :: [Test] +tests = + [ testProperty "left identity Monoid law" monoidLeftIdentity + , testProperty "right identity Monoid law" monoidRightIdentity + , testProperty "associativity Monoid law" monoidAssociativity + , testProperty "mconcat Monoid law" monoidConcat + , testProperty "string → builder → string" fromStringToString + , testProperty "string and text" stringAndText + , testProperty "lazy bytestring identity" identityLazyByteString + , testProperty "flushing identity" identityFlushing + , testProperty "writeToByteString" writeToByteStringProp + , testCase "escaping case 1" escaping1 + , testCase "escaping case 2" escaping2 + , testCase "escaping case 3" escaping3 + ] + +monoidLeftIdentity :: Builder -> Bool +monoidLeftIdentity b = mappend mempty b == b + +monoidRightIdentity :: Builder -> Bool +monoidRightIdentity b = mappend b mempty == b + +monoidAssociativity :: Builder -> Builder -> Builder -> Bool +monoidAssociativity x y z = mappend x (mappend y z) == mappend (mappend x y) z + +monoidConcat :: [Builder] -> Bool +monoidConcat xs = mconcat xs == foldr mappend mempty xs + +fromStringToString :: String -> Bool +fromStringToString string = string == convert string + where + convert = decode . LB.unpack . toLazyByteString . fromString + +stringAndText :: String -> Bool +stringAndText string = fromString string == fromText (T.pack string) + +identityLazyByteString :: LB.ByteString -> Bool +identityLazyByteString lbs = lbs == toLazyByteString (fromLazyByteString lbs) + +identityFlushing :: String -> String -> Bool +identityFlushing s1 s2 = + let b1 = fromString s1 + b2 = fromString s2 + in b1 `mappend` b2 == b1 `mappend` flush `mappend` b2 + +writeToByteStringProp :: Write -> Bool +writeToByteStringProp w = toByteString (fromWrite w) == writeToByteString w + +escaping1 :: Assertion +escaping1 = fromString "<hello>" @?= fromHtmlEscapedString "" + +escaping2 :: Assertion +escaping2 = fromString "f &&& g" @?= fromHtmlEscapedString "f &&& g" + +escaping3 :: Assertion +escaping3 = fromString ""'" @?= fromHtmlEscapedString "\"'" + +instance Show Builder where + show = show . toLazyByteString + +instance Show Write where + show = show . fromWrite + +instance Eq Builder where + b1 == b2 = + -- different and small buffer sizses for testing wrapping behaviour + toLazyByteStringWith 1024 1024 256 b1 mempty == + toLazyByteStringWith 2001 511 256 b2 mempty + +-- | Artificially scale up size to ensures that buffer wrapping behaviour is +-- also tested. +numRepetitions :: Int +numRepetitions = 250 + +instance Arbitrary Builder where + arbitrary = (mconcat . replicate numRepetitions . fromString) <$> arbitrary + +instance Arbitrary Write where + arbitrary = mconcat . map singleWrite <$> arbitrary + where + singleWrite (Left bs) = writeByteString (mconcat (LB.toChunks bs)) + singleWrite (Right w) = writeWord8 w + +instance Arbitrary LB.ByteString where + arbitrary = (LB.concat . replicate numRepetitions . LB.pack) <$> arbitrary