{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Internal (ByteString(..), create, memcpy) import qualified Data.CaseInsensitive as CI import Data.List (foldl') import Data.Word (Word8) import Foreign.ForeignPtr import Foreign.Ptr import GHC.Storable import qualified Network.HTTP.Types as H ---------------------------------------------------------------- composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do ptr1 <- copyStatus ptr httpversion status ptr2 <- copyHeaders ptr1 responseHeaders void $ copyCRLF ptr2 where !len = 17 + slen + foldl' fieldLength 0 responseHeaders fieldLength !l !(k,v) = l + S.length (CI.original k) + S.length v + 4 !slen = S.length $ H.statusMessage status {-# INLINE copy #-} copy :: Ptr Word8 -> ByteString -> IO (Ptr Word8) copy !ptr (PS fp o l) = withForeignPtr fp $ \p -> do memcpy ptr (p `plusPtr` o) (fromIntegral l) return $! ptr `plusPtr` l httpVer11 :: ByteString httpVer11 = "HTTP/1.1 " httpVer10 :: ByteString httpVer10 = "HTTP/1.0 " {-# INLINE copyStatus #-} copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8) copyStatus !ptr !httpversion !status = do ptr1 <- copy ptr httpVer writeWord8OffPtr ptr1 0 (zero + fromIntegral r2) writeWord8OffPtr ptr1 1 (zero + fromIntegral r1) writeWord8OffPtr ptr1 2 (zero + fromIntegral r0) writeWord8OffPtr ptr1 3 spc ptr2 <- copy (ptr1 `plusPtr` 4) (H.statusMessage status) copyCRLF ptr2 where httpVer | httpversion == H.HttpVersion 1 1 = httpVer11 | otherwise = httpVer10 (q0,r0) = H.statusCode status `divMod` 10 (q1,r1) = q0 `divMod` 10 r2 = q1 `mod` 10 {-# INLINE copyHeaders #-} copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8) copyHeaders !ptr [] = return ptr copyHeaders !ptr (h:hs) = do ptr1 <- copyHeader ptr h copyHeaders ptr1 hs {-# INLINE copyHeader #-} copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8) copyHeader !ptr (k,v) = do ptr1 <- copy ptr (CI.original k) writeWord8OffPtr ptr1 0 colon writeWord8OffPtr ptr1 1 spc ptr2 <- copy (ptr1 `plusPtr` 2) v copyCRLF ptr2 {-# INLINE copyCRLF #-} copyCRLF :: Ptr Word8 -> IO (Ptr Word8) copyCRLF !ptr = do writeWord8OffPtr ptr 0 cr writeWord8OffPtr ptr 1 lf return $! ptr `plusPtr` 2 zero :: Word8 zero = 48 spc :: Word8 spc = 32 colon :: Word8 colon = 58 cr :: Word8 cr = 13 lf :: Word8 lf = 10