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

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 Data.Word8
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 ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
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
    IO (Ptr Word8) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Ptr Word8) -> IO ()) -> IO (Ptr Word8) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> IO (Ptr Word8)
copyCRLF Ptr Word8
ptr2
  where
    !len :: Int
len = Int
17 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
slen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> (CI ByteString, ByteString) -> Int)
-> Int -> ResponseHeaders -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
k) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
S.length ByteString
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
    !slen :: Int
slen = ByteString -> Int
S.length (ByteString -> Int) -> ByteString -> Int
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
_0 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r2)
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
1 (Word8
_0 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r1)
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
2 (Word8
_0 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r0)
    Ptr Word8 -> Int -> Word8 -> IO ()
writeWord8OffPtr Ptr Word8
ptr1 Int
3 Word8
_space
    Ptr Word8
ptr2 <- Ptr Word8 -> ByteString -> IO (Ptr Word8)
copy (Ptr Word8
ptr1 Ptr Word8 -> Int -> Ptr Word8
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 HttpVersion -> HttpVersion -> Bool
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 Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
10
    (Int
q1, Int
r1) = Int
q0 Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
10
    r2 :: Int
r2 = Int
q1 Int -> Int -> Int
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 [] = Ptr Word8 -> IO (Ptr Word8)
forall a. a -> IO a
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 (CI ByteString -> ByteString
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
_space
    Ptr Word8
ptr2 <- Ptr Word8 -> ByteString -> IO (Ptr Word8)
copy (Ptr Word8
ptr1 Ptr Word8 -> Int -> Ptr Word8
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
    Ptr Word8 -> IO (Ptr Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$! Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2