1{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings #-} 2------------------------------------------------------------------------------ 3-- | 4-- Module: Blaze.ByteString.Builder.HTTP 5-- Copyright: (c) 2013 Simon Meier 6-- License: BSD3 7-- Maintainer: Leon P Smith <leon@melding-monads.com> 8-- Stability: experimental 9-- 10-- Support for HTTP response encoding. 11-- 12------------------------------------------------------------------------------ 13 14module Blaze.ByteString.Builder.HTTP ( 15 -- * Chunked HTTP transfer encoding 16 chunkedTransferEncoding 17 , chunkedTransferTerminator 18 ) where 19 20#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) 21#include "MachDeps.h" 22#endif 23 24#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) 25import GHC.Base 26import GHC.Word (Word32(..)) 27#else 28import Data.Word 29#endif 30 31import Foreign 32 33import qualified Data.ByteString as S 34import Data.ByteString.Char8 () 35 36import Blaze.ByteString.Builder.Internal.Write 37import Data.ByteString.Builder 38import Data.ByteString.Builder.Internal 39import Blaze.ByteString.Builder.ByteString (copyByteString) 40 41import qualified Blaze.ByteString.Builder.Char8 as Char8 42 43#if !MIN_VERSION_base(4,8,0) 44import Data.Monoid 45#endif 46 47 48{-# INLINE shiftr_w32 #-} 49shiftr_w32 :: Word32 -> Int -> Word32 50 51#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) 52shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) 53#else 54shiftr_w32 = shiftR 55#endif 56 57 58-- | Write a CRLF sequence. 59writeCRLF :: Write 60writeCRLF = Char8.writeChar '\r' `mappend` Char8.writeChar '\n' 61{-# INLINE writeCRLF #-} 62 63-- | Execute a write 64{-# INLINE execWrite #-} 65execWrite :: Write -> Ptr Word8 -> IO () 66execWrite w op = do 67 _ <- runPoke (getPoke w) op 68 return () 69 70 71------------------------------------------------------------------------------ 72-- Hex Encoding Infrastructure 73------------------------------------------------------------------------------ 74 75pokeWord32HexN :: Int -> Word32 -> Ptr Word8 -> IO () 76pokeWord32HexN n0 w0 op0 = 77 go w0 (op0 `plusPtr` (n0 - 1)) 78 where 79 go !w !op 80 | op < op0 = return () 81 | otherwise = do 82 let nibble :: Word8 83 nibble = fromIntegral w .&. 0xF 84 hex | nibble < 10 = 48 + nibble 85 | otherwise = 55 + nibble 86 poke op hex 87 go (w `shiftr_w32` 4) (op `plusPtr` (-1)) 88{-# INLINE pokeWord32HexN #-} 89 90iterationsUntilZero :: Integral a => (a -> a) -> a -> Int 91iterationsUntilZero f = go 0 92 where 93 go !count 0 = count 94 go !count !x = go (count+1) (f x) 95{-# INLINE iterationsUntilZero #-} 96 97-- | Length of the hex-string required to encode the given 'Word32'. 98word32HexLength :: Word32 -> Int 99word32HexLength = max 1 . iterationsUntilZero (`shiftr_w32` 4) 100{-# INLINE word32HexLength #-} 101 102writeWord32Hex :: Word32 -> Write 103writeWord32Hex w = 104 boundedWrite (2 * sizeOf w) (pokeN len $ pokeWord32HexN len w) 105 where 106 len = word32HexLength w 107{-# INLINE writeWord32Hex #-} 108 109 110------------------------------------------------------------------------------ 111-- Chunked transfer encoding 112------------------------------------------------------------------------------ 113 114-- | Transform a builder such that it uses chunked HTTP transfer encoding. 115chunkedTransferEncoding :: Builder -> Builder 116chunkedTransferEncoding innerBuilder = 117 builder transferEncodingStep 118 where 119 transferEncodingStep k = 120 go (runBuilder innerBuilder) 121 where 122 go innerStep !(BufferRange op ope) 123 -- FIXME: Assert that outRemaining < maxBound :: Word32 124 | outRemaining < minimalBufferSize = 125 return $ bufferFull minimalBufferSize op (go innerStep) 126 | otherwise = do 127 let !brInner@(BufferRange opInner _) = BufferRange 128 (op `plusPtr` (chunkSizeLength + 2)) -- leave space for chunk header 129 (ope `plusPtr` (-maxAfterBufferOverhead)) -- leave space at end of data 130 131 -- wraps the chunk, if it is non-empty, and returns the 132 -- signal constructed with the correct end-of-data pointer 133 {-# INLINE wrapChunk #-} 134 wrapChunk :: Ptr Word8 -> (Ptr Word8 -> IO (BuildSignal a)) 135 -> IO (BuildSignal a) 136 wrapChunk !opInner' mkSignal 137 | opInner' == opInner = mkSignal op 138 | otherwise = do 139 pokeWord32HexN chunkSizeLength 140 (fromIntegral $ opInner' `minusPtr` opInner) 141 op 142 execWrite writeCRLF (opInner `plusPtr` (-2)) 143 execWrite writeCRLF opInner' 144 mkSignal (opInner' `plusPtr` 2) 145 146 -- prepare handlers 147 doneH opInner' _ = wrapChunk opInner' $ \op' -> do 148 let !br' = BufferRange op' ope 149 k br' 150 151 fullH opInner' minRequiredSize nextInnerStep = 152 wrapChunk opInner' $ \op' -> 153 return $! bufferFull 154 (minRequiredSize + maxEncodingOverhead) 155 op' 156 (go nextInnerStep) 157 158 insertChunkH opInner' bs nextInnerStep 159 | S.null bs = -- flush 160 wrapChunk opInner' $ \op' -> 161 return $! insertChunk op' S.empty (go nextInnerStep) 162 163 | otherwise = -- insert non-empty bytestring 164 wrapChunk opInner' $ \op' -> do 165 -- add header for inserted bytestring 166 -- FIXME: assert(S.length bs < maxBound :: Word32) 167 !op'' <- (`runPoke` op') $ getPoke $ 168 writeWord32Hex (fromIntegral $ S.length bs) 169 `mappend` writeCRLF 170 171 -- insert bytestring and write CRLF in next buildstep 172 return $! insertChunk 173 op'' bs 174 (runBuilderWith (fromWrite writeCRLF) $ go nextInnerStep) 175 176 -- execute inner builder with reduced boundaries 177 fillWithBuildStep innerStep doneH fullH insertChunkH brInner 178 where 179 -- minimal size guaranteed for actual data no need to require more 180 -- than 1 byte to guarantee progress the larger sizes will be 181 -- hopefully provided by the driver or requested by the wrapped 182 -- builders. 183 minimalChunkSize = 1 184 185 -- overhead computation 186 maxBeforeBufferOverhead = sizeOf (undefined :: Int) + 2 -- max chunk size and CRLF after header 187 maxAfterBufferOverhead = 2 + -- CRLF after data 188 sizeOf (undefined :: Int) + 2 -- max bytestring size, CRLF after header 189 190 maxEncodingOverhead = maxBeforeBufferOverhead + maxAfterBufferOverhead 191 192 minimalBufferSize = minimalChunkSize + maxEncodingOverhead 193 194 -- remaining and required space computation 195 outRemaining :: Int 196 outRemaining = ope `minusPtr` op 197 chunkSizeLength = word32HexLength $ fromIntegral outRemaining 198 199 200-- | The zero-length chunk '0\r\n\r\n' signaling the termination of the data transfer. 201chunkedTransferTerminator :: Builder 202chunkedTransferTerminator = copyByteString "0\r\n\r\n" 203