{-# language LambdaCase #-}

module Http.Header
  ( Header(..)
  , decodeMany
  , parser
  , parserSmallArray
  , builder
  , builderSmallArray
  ) where

import Control.Monad (when)
import Data.Bytes (Bytes)
import Data.Bytes.Parser (Parser)
import Data.Bytes.Types (Bytes(Bytes))
import Data.Primitive (SmallArray,SmallMutableArray,ByteArray(ByteArray))
import Data.Word (Word8,Word16)
import Data.Text (Text)
import Data.Bytes.Builder (Builder)

import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Text.Utf8 as Utf8
import qualified Data.Bytes.Builder as Builder
import qualified Data.Text.Internal as Text
import qualified Data.Text.Array
import qualified Data.Bytes.Parser as Parser
import qualified Data.Bytes.Parser.Latin as Latin
import qualified Data.Primitive as PM

-- | An HTTP header. This type does not enforce a restricted character
-- set. If, for example, the user creates a header whose key has a colon
-- character, the resulting request will be malformed.
data Header = Header
  { Header -> Text
name :: {-# UNPACK #-} !Text
  , Header -> Text
value :: {-# UNPACK #-} !Text
  } deriving (Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Header] -> ShowS
$cshowList :: [Header] -> ShowS
show :: Header -> String
$cshow :: Header -> String
showsPrec :: Int -> Header -> ShowS
$cshowsPrec :: Int -> Header -> ShowS
Show)

uninitializedHeader :: Header
{-# noinline uninitializedHeader #-}
uninitializedHeader :: Header
uninitializedHeader = forall a. String -> a
errorWithoutStackTrace String
"parserHeaders: uninitialized header"

-- | Parse headers. Expects two CRLF sequences in a row at the end.
-- Fails if leftovers are encountered.
decodeMany :: Int -> Bytes -> Maybe (SmallArray Header)
decodeMany :: Int -> Bytes -> Maybe (SmallArray Header)
decodeMany !Int
n !Bytes
b = forall e a. (forall s. Parser e s a) -> Bytes -> Maybe a
Parser.parseBytesMaybe (forall s. Int -> Parser () s (SmallArray Header)
parserSmallArray Int
n forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s. e -> Parser e s ()
Parser.endOfInput ()) Bytes
b
  
-- Parse headers. Stops after encountering two CRLF sequences in
-- a row.
parserSmallArray ::
     Int -- maximum number of headers allowed, recommended 128
  -> Parser () s (SmallArray Header)
parserSmallArray :: forall s. Int -> Parser () s (SmallArray Header)
parserSmallArray !Int
n = do
  SmallMutableArray s Header
dst <- forall s a e. ST s a -> Parser e s a
Parser.effect (forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
n Header
uninitializedHeader)
  forall s.
Int
-> Int
-> SmallMutableArray s Header
-> Parser () s (SmallArray Header)
parserHeaderStep Int
0 Int
n SmallMutableArray s Header
dst

parserHeaderStep ::
     Int -- index
  -> Int -- remaining length
  -> SmallMutableArray s Header
  -> Parser () s (SmallArray Header)
parserHeaderStep :: forall s.
Int
-> Int
-> SmallMutableArray s Header
-> Parser () s (SmallArray Header)
parserHeaderStep !Int
ix !Int
n !SmallMutableArray s Header
dst = forall e s. (Char -> Bool) -> Parser e s Bool
Latin.trySatisfy (forall a. Eq a => a -> a -> Bool
== Char
'\r') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True -> do
    forall e s. e -> Char -> Parser e s ()
Latin.char () Char
'\n'
    forall s a e. ST s a -> Parser e s a
Parser.effect forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> m ()
PM.shrinkSmallMutableArray SmallMutableArray s Header
dst Int
ix
      forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s Header
dst
  Bool
False -> if Int
n forall a. Ord a => a -> a -> Bool
> Int
0
    then do
      Header
header <- forall s. Parser () s Header
parser
      forall s a e. ST s a -> Parser e s a
Parser.effect (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s Header
dst Int
ix Header
header)
      forall s.
Int
-> Int
-> SmallMutableArray s Header
-> Parser () s (SmallArray Header)
parserHeaderStep (Int
ix forall a. Num a => a -> a -> a
+ Int
1) (Int
n forall a. Num a => a -> a -> a
- Int
1) SmallMutableArray s Header
dst
    else forall e s a. e -> Parser e s a
Parser.fail ()

-- | Parse a single HTTP header including the trailing CRLF sequence.
-- From RFC 7230:
--
-- > header-field   = field-name ":" OWS field-value OWS
-- > field-name     = token
-- > field-value    = *( field-content / obs-fold )
-- > field-content  = field-vchar [ 1*( SP / HTAB ) field-vchar ]
-- > field-vchar    = VCHAR / obs-text
parser :: Parser () s Header
parser :: forall s. Parser () s Header
parser = do
  -- Header name may contain: a-z, A-Z, 0-9, underscore, hyphen
  !Bytes
name <- forall e s. (Word8 -> Bool) -> Parser e s Bytes
Parser.takeWhile forall a b. (a -> b) -> a -> b
$ \Word8
c ->
    (Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
0x41 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
0x5A)
    Bool -> Bool -> Bool
||
    (Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
0x61 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
0x7A)
    Bool -> Bool -> Bool
||
    (Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
0x30 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
0x39)
    Bool -> Bool -> Bool
||
    Word8
c forall a. Eq a => a -> a -> Bool
== Word8
0x2D
    Bool -> Bool -> Bool
||
    Word8
c forall a. Eq a => a -> a -> Bool
== Word8
0x5F
  forall e s. e -> Char -> Parser e s ()
Latin.char () Char
':'
  forall e s. (Char -> Bool) -> Parser e s ()
Latin.skipWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t')
  -- Header name allows vchar, space, and tab.
  Bytes
value0 <- forall e s. (Word8 -> Bool) -> Parser e s Bytes
Parser.takeWhile forall a b. (a -> b) -> a -> b
$ \Word8
c ->
    (Word8
c forall a. Ord a => a -> a -> Bool
>= Word8
0x20 Bool -> Bool -> Bool
&& Word8
c forall a. Ord a => a -> a -> Bool
<= Word8
0x7e)
    Bool -> Bool -> Bool
||
    (Word8
c forall a. Eq a => a -> a -> Bool
== Word8
0x09)
  forall e s. e -> Char -> Char -> Parser e s ()
Latin.char2 () Char
'\r' Char
'\n'
  -- We only need to trim the end because the leading spaces and tab
  -- were already skipped.
  let !value :: Bytes
value = (Word8 -> Bool) -> Bytes -> Bytes
Bytes.dropWhileEnd (\Word8
c -> Word8
c forall a. Eq a => a -> a -> Bool
== Word8
0x20 Bool -> Bool -> Bool
|| Word8
c forall a. Eq a => a -> a -> Bool
== Word8
0x09) Bytes
value0
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Header{name :: Text
name=Bytes -> Text
unsafeBytesToText Bytes
name,value :: Text
value=Bytes -> Text
unsafeBytesToText Bytes
value}

unsafeBytesToText :: Bytes -> Text
{-# inline unsafeBytesToText #-}
unsafeBytesToText :: Bytes -> Text
unsafeBytesToText (Bytes (ByteArray ByteArray#
arr) Int
off Int
len) =
  Array -> Int -> Int -> Text
Text.Text (ByteArray# -> Array
Data.Text.Array.ByteArray ByteArray#
arr) Int
off Int
len

-- | Encode a header. Includes the trailing CRLF sequence.
builder :: Header -> Builder
builder :: Header -> Builder
builder Header{Text
name :: Text
name :: Header -> Text
name,Text
value :: Text
value :: Header -> Text
value} =
  Bytes -> Builder
Builder.copy (Text -> Bytes
Utf8.fromText Text
name)
  forall a. Semigroup a => a -> a -> a
<>
  Char -> Char -> Builder
Builder.ascii2 Char
':' Char
' '
  forall a. Semigroup a => a -> a -> a
<>
  Bytes -> Builder
Builder.copy (Text -> Bytes
Utf8.fromText Text
value)
  forall a. Semigroup a => a -> a -> a
<>
  Char -> Char -> Builder
Builder.ascii2 Char
'\r' Char
'\n'

builderSmallArray :: SmallArray Header -> Builder
builderSmallArray :: SmallArray Header -> Builder
builderSmallArray = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Header -> Builder
builder