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