    {-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings #-}

    #ifdef USE_MONO_PAT_BINDS
    {-# LANGUAGE MonoPatBinds #-}
    #endif

    -- | Support for HTTP response encoding.
    --
    -- TODO: Improve documentation.
    module Blaze.ByteString.Builder.HTTP (
      -- * Chunked HTTP transfer encoding
        chunkedTransferEncoding
      , chunkedTransferTerminator
      ) where

    import Data.Monoid
    import qualified Data.ByteString       as S
    import Data.ByteString.Char8 ()

    import Foreign

    import Blaze.ByteString.Builder.Internal
    import Blaze.ByteString.Builder.Internal.Types
    import Blaze.ByteString.Builder.Internal.UncheckedShifts
    import Blaze.ByteString.Builder.ByteString (copyByteString)

    import qualified Blaze.ByteString.Builder.Char8 as Char8

    -- only required by test-code
    -- import qualified Data.ByteString.Lazy as L
    -- import qualified Blaze.ByteString.Builder.ByteString  as B
    -- import Data.ByteString.Char8 ()

    -- | 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
    ------------------------------------------------------------------------------

    {-
    pokeWord16Hex :: Word16 -> Ptr Word8 -> IO ()
    pokeWord16Hex x op = do
        pokeNibble 0 12
        pokeNibble 1  8
        pokeNibble 2  4
        pokeNibble 3  0
      where
        pokeNibble off s
            | n <  10   = pokeWord8 off (fromIntegral $ 48 + n)
            | otherwise = pokeWord8 off (fromIntegral $ 55 + n)
            where
              n = shiftr_w16 x s .&. 0xF

        pokeWord8 :: Int -> Word8 -> IO ()
        pokeWord8 off = poke (op `plusPtr` off)

    writeWord16Hex :: Word16 -> Write
    writeWord16Hex = exactWrite 4 . pokeWord16Hex

    -}

    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 #-}

    {-
    test = flip (toLazyByteStringWith 32 32 32) L.empty
        $ chunkedTransferEncoding
        $ mconcat $ map oneLine [0..16] ++
                    [B.insertByteString "hello"] ++
                    map oneLine [0,1] ++
                    [B.insertByteString ""] ++
                    map oneLine [0..16]

      where
        oneLine x = fromWriteSingleton writeWord32Hex x `mappend` Char8.fromChar ' '

    test = print $ toLazyByteString
        $ chunkedTransferEncoding  body `mappend` chunkedTransferTerminator

    body = copyByteString "maa" `mappend` copyByteString "foo" `mappend` copyByteString "bar"
    -}

    ------------------------------------------------------------------------------
    -- Chunked transfer encoding
    ------------------------------------------------------------------------------

    -- | Transform a builder such that it uses chunked HTTP transfer encoding.
    chunkedTransferEncoding :: Builder -> Builder
    chunkedTransferEncoding (Builder b) =
        fromBuildStepCont transferEncodingStep
      where
        finalStep !(BufRange op _) = return $ Done op ()

        transferEncodingStep k = go (b (buildStep finalStep))
          where
            go innerStep !(BufRange op ope)
              -- FIXME: Assert that outRemaining < maxBound :: Word32
              | outRemaining < minimalBufferSize =
                  return $ bufferFull minimalBufferSize op (go innerStep)
              | otherwise = do
                  let !brInner@(BufRange opInner _) = BufRange
                         (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)

                  -- execute inner builder with reduced boundaries
                  signal <- runBuildStep innerStep brInner
                  case signal of
                    Done opInner' _ ->
                        wrapChunk opInner' $ \op' -> do
                          let !br' = BufRange op' ope
                          k br'

                    BufferFull minRequiredSize opInner' nextInnerStep ->
                        wrapChunk opInner' $ \op' ->
                          return $! bufferFull
                            (minRequiredSize + maxEncodingOverhead)
                            op'
                            (go nextInnerStep)

                    InsertByteString opInner' bs nextInnerStep
                      | S.null bs ->                        -- flush
                          wrapChunk opInner' $ \op' ->
                            return $! insertByteString
                              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 $! InsertByteString
                              op'' bs
                              (unBuilder (fromWrite writeCRLF) $
                                buildStep $ go nextInnerStep)

              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"