{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where

import qualified Data.ByteString as S
import Data.ByteString.Internal (create)
import qualified Data.CaseInsensitive as CI
import Data.List (foldl')
import Foreign.Ptr
import GHC.Storable
import qualified Network.HTTP.Types as H
import Network.Socket.BufferPool (copy)

import Network.Wai.Handler.Warp.Imports

----------------------------------------------------------------

composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString
composeHeader :: HttpVersion -> Status -> ResponseHeaders -> IO ByteString
composeHeader !HttpVersion
httpversion !Status
status !ResponseHeaders
responseHeaders = Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
len forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
    Ptr Word8
ptr1 <- Ptr Word8 -> HttpVersion -> Status -> IO (Ptr Word8)
copyStatus Ptr Word8
ptr HttpVersion
httpversion Status
status
    Ptr Word8
ptr2 <- Ptr Word8 -> ResponseHeaders -> IO (Ptr Word8)
copyHeaders Ptr Word8
ptr1 ResponseHeaders
responseHeaders
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO (Ptr Word8)
copyCRLF Ptr Word8
ptr2
  where
    !len :: Int
len = Int
17 forall a. Num a => a -> a -> a
+ Int
slen forall a. Num a => a -> a -> a
+ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> (CI ByteString, ByteString) -> Int
fieldLength Int
0 ResponseHeaders
responseHeaders
    fieldLength :: Int -> (CI ByteString, ByteString) -> Int
fieldLength !Int
l (!CI ByteString
k,!ByteString
v) = Int
l forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length (forall s. CI s -> s
CI.original CI ByteString
k) forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
v forall a. Num a => a -> a -> a
+ Int
4
    !slen :: Int
slen = ByteString -> Int
S.length forall a b. (a -> b) -> a -> b
$ Status -> ByteString
H.statusMessage Status
status

httpVer11 :: ByteString
httpVer11 :: ByteString
httpVer11 = ByteString
"HTTP/1.1 "

httpVer10 :: ByteString
httpVer10 :: ByteString
httpVer10 = ByteString
"HTTP/1.0 "

{-# INLINE copyStatus #-}
copyStatus :: Ptr Word8 -> H.HttpVersion -> H.Status -> IO (Ptr Word8)
copyStatus :: Ptr Word8 -> HttpVersion -> Status -> IO (Ptr Word8)
copyStatus !Ptr Word8
ptr !HttpVersion
httpversion !Status
status = do
    Ptr Word8
ptr1 <- Ptr Word8 -> ByteString -> IO (Ptr Word8)
copy Ptr Word8
ptr ByteString
httpVer
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
0 (Word8
zero forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r2)
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
1 (Word8
zero forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r1)
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
2 (Word8
zero forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r0)
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
3 Word8
spc
    Ptr Word8
ptr2 <- Ptr Word8 -> ByteString -> IO (Ptr Word8)
copy (Ptr Word8
ptr1 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4) (Status -> ByteString
H.statusMessage Status
status)
    Ptr Word8 -> IO (Ptr Word8)
copyCRLF Ptr Word8
ptr2
  where
    httpVer :: ByteString
httpVer
      | HttpVersion
httpversion forall a. Eq a => a -> a -> Bool
== Int -> Int -> HttpVersion
H.HttpVersion Int
1 Int
1 = ByteString
httpVer11
      | Bool
otherwise = ByteString
httpVer10
    (Int
q0,Int
r0) = Status -> Int
H.statusCode Status
status forall a. Integral a => a -> a -> (a, a)
`divMod` Int
10
    (Int
q1,Int
r1) = Int
q0 forall a. Integral a => a -> a -> (a, a)
`divMod` Int
10
    r2 :: Int
r2 = Int
q1 forall a. Integral a => a -> a -> a
`mod` Int
10

{-# INLINE copyHeaders #-}
copyHeaders :: Ptr Word8 -> [H.Header] -> IO (Ptr Word8)
copyHeaders :: Ptr Word8 -> ResponseHeaders -> IO (Ptr Word8)
copyHeaders !Ptr Word8
ptr [] = forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Word8
ptr
copyHeaders !Ptr Word8
ptr ((CI ByteString, ByteString)
h:ResponseHeaders
hs) = do
    Ptr Word8
ptr1 <- Ptr Word8 -> (CI ByteString, ByteString) -> IO (Ptr Word8)
copyHeader Ptr Word8
ptr (CI ByteString, ByteString)
h
    Ptr Word8 -> ResponseHeaders -> IO (Ptr Word8)
copyHeaders Ptr Word8
ptr1 ResponseHeaders
hs

{-# INLINE copyHeader #-}
copyHeader :: Ptr Word8 -> H.Header -> IO (Ptr Word8)
copyHeader :: Ptr Word8 -> (CI ByteString, ByteString) -> IO (Ptr Word8)
copyHeader !Ptr Word8
ptr (CI ByteString
k,ByteString
v) = do
    Ptr Word8
ptr1 <- Ptr Word8 -> ByteString -> IO (Ptr Word8)
copy Ptr Word8
ptr (forall s. CI s -> s
CI.original CI ByteString
k)
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
0 Word8
colon
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
1 Word8
spc
    Ptr Word8
ptr2 <- Ptr Word8 -> ByteString -> IO (Ptr Word8)
copy (Ptr Word8
ptr1 forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) ByteString
v
    Ptr Word8 -> IO (Ptr Word8)
copyCRLF Ptr Word8
ptr2

{-# INLINE copyCRLF #-}
copyCRLF :: Ptr Word8 -> IO (Ptr Word8)
copyCRLF :: Ptr Word8 -> IO (Ptr Word8)
copyCRLF !Ptr Word8
ptr = do
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr Int
0 Word8
cr
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr Int
1 Word8
lf
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Ptr Word8
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2

zero :: Word8
zero :: Word8
zero = Word8
48
spc :: Word8
spc :: Word8
spc = Word8
32
colon :: Word8
colon :: Word8
colon = Word8
58
cr :: Word8
cr :: Word8
cr = Word8
13
lf :: Word8
lf :: Word8
lf = Word8
10