{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MagicHash #-}

module Http.Request
  ( Request (..)
  , RequestLine (..)

    -- * Encode Request
  , builder
  , toChunks
  , toChunksOnto

    -- * Encode Request with Body
  , bodiedToChunks
  ) where

import Data.Bytes.Builder (Builder)
import Data.Bytes.Chunks (Chunks)
import Data.Text (Text)
import GHC.Exts (Ptr (Ptr))
import Http.Bodied (Bodied (..))
import Http.Headers (Headers)

import Data.Bytes.Builder qualified as Builder
import Data.Bytes.Chunks qualified as Chunks
import Data.Bytes.Text.Utf8 qualified as Utf8
import Http.Header qualified as Header
import Http.Headers qualified as Headers

-- | The request line and the request headers.
data Request = Request
  { Request -> RequestLine
requestLine :: !RequestLine
  , Request -> Headers
headers :: !Headers
  }
  deriving (Request -> Request -> Bool
(Request -> Request -> Bool)
-> (Request -> Request -> Bool) -> Eq Request
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Request -> Request -> Bool
== :: Request -> Request -> Bool
$c/= :: Request -> Request -> Bool
/= :: Request -> Request -> Bool
Eq, Int -> Request -> ShowS
[Request] -> ShowS
Request -> String
(Int -> Request -> ShowS)
-> (Request -> String) -> ([Request] -> ShowS) -> Show Request
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Request -> ShowS
showsPrec :: Int -> Request -> ShowS
$cshow :: Request -> String
show :: Request -> String
$cshowList :: [Request] -> ShowS
showList :: [Request] -> ShowS
Show)

-- | An HTTP request line
data RequestLine = RequestLine
  { RequestLine -> Text
method :: {-# UNPACK #-} !Text
  , RequestLine -> Text
path :: {-# UNPACK #-} !Text
  }
  deriving (RequestLine -> RequestLine -> Bool
(RequestLine -> RequestLine -> Bool)
-> (RequestLine -> RequestLine -> Bool) -> Eq RequestLine
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequestLine -> RequestLine -> Bool
== :: RequestLine -> RequestLine -> Bool
$c/= :: RequestLine -> RequestLine -> Bool
/= :: RequestLine -> RequestLine -> Bool
Eq, Int -> RequestLine -> ShowS
[RequestLine] -> ShowS
RequestLine -> String
(Int -> RequestLine -> ShowS)
-> (RequestLine -> String)
-> ([RequestLine] -> ShowS)
-> Show RequestLine
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequestLine -> ShowS
showsPrec :: Int -> RequestLine -> ShowS
$cshow :: RequestLine -> String
show :: RequestLine -> String
$cshowList :: [RequestLine] -> ShowS
showList :: [RequestLine] -> ShowS
Show)

builderRequestLine :: RequestLine -> Builder
builderRequestLine :: RequestLine -> Builder
builderRequestLine RequestLine {Text
$sel:method:RequestLine :: RequestLine -> Text
method :: Text
method, Text
$sel:path:RequestLine :: RequestLine -> Text
path :: Text
path} =
  Bytes -> Builder
Builder.copy (Text -> Bytes
Utf8.fromText Text
method)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.ascii Char
' '
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bytes -> Builder
Builder.copy (Text -> Bytes
Utf8.fromText Text
path)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Char -> Char -> Char -> Char -> Char -> Builder
Builder.ascii6 Char
' ' Char
'H' Char
'T' Char
'T' Char
'P' Char
'/'
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Char -> Char -> Char -> Char -> Builder
Builder.ascii5 Char
'1' Char
'.' Char
'1' Char
'\r' Char
'\n'

toChunks :: Request -> Chunks
toChunks :: Request -> Chunks
toChunks = Int -> Builder -> Chunks
Builder.run Int
256 (Builder -> Chunks) -> (Request -> Builder) -> Request -> Chunks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Builder
builder

toChunksOnto :: Request -> Chunks -> Chunks
toChunksOnto :: Request -> Chunks -> Chunks
toChunksOnto Request
r = Int -> Builder -> Chunks -> Chunks
Builder.runOnto Int
256 (Request -> Builder
builder Request
r)

builder :: Request -> Builder
builder :: Request -> Builder
builder Request {RequestLine
$sel:requestLine:Request :: Request -> RequestLine
requestLine :: RequestLine
requestLine, Headers
$sel:headers:Request :: Request -> Headers
headers :: Headers
headers} =
  RequestLine -> Builder
builderRequestLine RequestLine
requestLine
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SmallArray Header -> Builder
Header.builderSmallArray SmallArray Header
headersArray
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Char -> Builder
Builder.ascii2 Char
'\r' Char
'\n'
 where
  headersArray :: SmallArray Header
headersArray = Headers -> SmallArray Header
Headers.toArray Headers
headers

{- | This adds the Content-Length header. It must not already
be present.
-}
bodiedToChunks :: Bodied Request -> Chunks
bodiedToChunks :: Bodied Request -> Chunks
bodiedToChunks Bodied {metadata :: forall a. Bodied a -> a
metadata = Request {RequestLine
$sel:requestLine:Request :: Request -> RequestLine
requestLine :: RequestLine
requestLine, Headers
$sel:headers:Request :: Request -> Headers
headers :: Headers
headers}, Chunks
body :: Chunks
body :: forall a. Bodied a -> Chunks
body} =
  Int -> Builder -> Chunks -> Chunks
Builder.runOnto
    Int
256
    ( RequestLine -> Builder
builderRequestLine RequestLine
requestLine
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> SmallArray Header -> Builder
Header.builderSmallArray SmallArray Header
headersArray
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> CString -> Builder
Builder.cstring (Addr# -> CString
forall a. Addr# -> Ptr a
Ptr Addr#
"Content-Length: "#)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
Builder.word64Dec (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Chunks -> Int
Chunks.length Chunks
body))
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Char -> Char -> Char -> Builder
Builder.ascii4 Char
'\r' Char
'\n' Char
'\r' Char
'\n'
    )
    Chunks
body
 where
  headersArray :: SmallArray Header
headersArray = Headers -> SmallArray Header
Headers.toArray Headers
headers