{-# 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
  { name :: {-# UNPACK #-} !Text
  , value :: {-# UNPACK #-} !Text
  } deriving (Show)

uninitializedHeader :: Header
{-# noinline uninitializedHeader #-}
uninitializedHeader = errorWithoutStackTrace "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 !n !b = Parser.parseBytesMaybe (parserSmallArray n <* Parser.endOfInput ()) 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 !n = do
  dst <- Parser.effect (PM.newSmallArray n uninitializedHeader)
  parserHeaderStep 0 n dst

parserHeaderStep ::
     Int -- index
  -> Int -- remaining length
  -> SmallMutableArray s Header
  -> Parser () s (SmallArray Header)
parserHeaderStep !ix !n !dst = Latin.trySatisfy (== '\r') >>= \case
  True -> do
    Latin.char () '\n'
    Parser.effect $ do
      PM.shrinkSmallMutableArray dst ix
      PM.unsafeFreezeSmallArray dst
  False -> if n > 0
    then do
      header <- parser
      Parser.effect (PM.writeSmallArray dst ix header)
      parserHeaderStep (ix + 1) (n - 1) dst
    else 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 = do
  -- Header name may contain: a-z, A-Z, 0-9, underscore, hyphen
  !name <- Parser.takeWhile $ \c ->
    (c >= 0x41 && c <= 0x5A)
    ||
    (c >= 0x61 && c <= 0x7A)
    ||
    (c >= 0x30 && c <= 0x39)
    ||
    c == 0x2D
    ||
    c == 0x5F
  Latin.char () ':'
  Latin.skipWhile (\c -> c == ' ' || c == '\t')
  -- Header name allows vchar, space, and tab.
  value0 <- Parser.takeWhile $ \c ->
    (c >= 0x20 && c <= 0x7e)
    ||
    (c == 0x09)
  Latin.char2 () '\r' '\n'
  -- We only need to trim the end because the leading spaces and tab
  -- were already skipped.
  let !value = Bytes.dropWhileEnd (\c -> c == 0x20 || c == 0x09) value0
  pure Header{name=unsafeBytesToText name,value=unsafeBytesToText value}

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

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

builderSmallArray :: SmallArray Header -> Builder
builderSmallArray = foldMap builder