    {-# LANGUAGE BangPatterns #-}

    module Network.Wai.Handler.Warp.RequestHeader (
        parseHeaderLines,
    ) where

    import qualified Data.ByteString as S
    import qualified Data.ByteString.Char8 as C8 (unpack)
    import Data.ByteString.Internal (memchr)
    import qualified Data.CaseInsensitive as CI
    import Data.Word8
    import Foreign.ForeignPtr (withForeignPtr)
    import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)
    import Foreign.Storable (peek)
    import qualified Network.HTTP.Types as H
    import Control.Exception (throwIO)

    import Network.Wai.Handler.Warp.Imports
    import Network.Wai.Handler.Warp.Types

    -- $setup
    -- >>> :set -XOverloadedStrings

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

    parseHeaderLines
        :: [ByteString]
        -> IO
            ( H.Method
            , ByteString --  Path
            , ByteString --  Path, parsed
            , ByteString --  Query
            , H.HttpVersion
            , H.RequestHeaders
            )
    parseHeaderLines :: [ByteString]
    -> IO
         (ByteString, ByteString, ByteString, ByteString, HttpVersion,
          RequestHeaders)
    parseHeaderLines [] = InvalidRequest
    -> IO
         (ByteString, ByteString, ByteString, ByteString, HttpVersion,
          RequestHeaders)
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (InvalidRequest
     -> IO
          (ByteString, ByteString, ByteString, ByteString, HttpVersion,
           RequestHeaders))
    -> InvalidRequest
    -> IO
         (ByteString, ByteString, ByteString, ByteString, HttpVersion,
          RequestHeaders)
    forall a b. (a -> b) -> a -> b
    $ [String] -> InvalidRequest
    NotEnoughLines []
    parseHeaderLines (ByteString
    firstLine : [ByteString]
    otherLines) = do
        (method, path', query, httpversion) <- ByteString -> IO (ByteString, ByteString, ByteString, HttpVersion)
    parseRequestLine ByteString
    firstLine
        let path = ByteString -> ByteString
    H.extractPath ByteString
    path'
            hdr = (ByteString -> Header) -> [ByteString] -> RequestHeaders
    forall a b. (a -> b) -> [a] -> [b]
    map ByteString -> Header
    parseHeader [ByteString]
    otherLines
        return (method, path', path, query, httpversion, hdr)

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

    -- |
    --
    -- >>> parseRequestLine "GET / HTTP/1.1"
    -- ("GET","/","",HTTP/1.1)
    -- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"
    -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)
    -- >>> parseRequestLine "GET "
    -- *** Exception: Warp: Invalid first line of request: "GET "
    -- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"
    -- *** Exception: Warp: Request line specified a non-HTTP request
    -- >>> parseRequestLine "PRI * HTTP/2.0"
    -- ("PRI","*","",HTTP/2.0)
    parseRequestLine
        :: ByteString
        -> IO
            ( H.Method
            , ByteString -- Path
            , ByteString -- Query
            , H.HttpVersion
            )
    parseRequestLine :: ByteString -> IO (ByteString, ByteString, ByteString, HttpVersion)
    parseRequestLine requestLine :: ByteString
    requestLine@(PS ForeignPtr Word8
    fptr Int
    off Int
    len) = ForeignPtr Word8
    -> (Ptr Word8
        -> IO (ByteString, ByteString, ByteString, HttpVersion))
    -> IO (ByteString, ByteString, ByteString, HttpVersion)
    forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
    withForeignPtr ForeignPtr Word8
    fptr ((Ptr Word8
      -> IO (ByteString, ByteString, ByteString, HttpVersion))
     -> IO (ByteString, ByteString, ByteString, HttpVersion))
    -> (Ptr Word8
        -> IO (ByteString, ByteString, ByteString, HttpVersion))
    -> IO (ByteString, ByteString, ByteString, HttpVersion)
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word8
    ptr -> do
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    len Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    14) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ InvalidRequest -> IO ()
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO InvalidRequest
    baderr
        let methodptr :: Ptr b
    methodptr = Ptr Word8
    ptr Ptr Word8 -> Int -> Ptr b
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    off
            limptr :: Ptr b
    limptr = Ptr (ZonkAny 0)
    forall {b}. Ptr b
    methodptr Ptr (ZonkAny 0) -> Int -> Ptr b
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    len
            lim0 :: CSize
    lim0 = Int -> CSize
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    len

        pathptr0 <- Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
    memchr Ptr Word8
    forall {b}. Ptr b
    methodptr Word8
    _space CSize
    lim0
        when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $
            throwIO baderr
        let pathptr = Ptr Word8
    pathptr0 Ptr Word8 -> Int -> Ptr b
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    1
            lim1 = Int -> CSize
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Ptr (ZonkAny 2)
    forall {b}. Ptr b
    limptr Ptr (ZonkAny 2) -> Ptr Word8 -> Int
    forall a b. Ptr a -> Ptr b -> Int
    `minusPtr` Ptr Word8
    pathptr0)

        httpptr0 <- memchr pathptr _space lim1
        when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $
            throwIO baderr
        let httpptr = Ptr Word8
    httpptr0 Ptr Word8 -> Int -> Ptr b
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    1
            lim2 = Int -> CSize
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Ptr Word8
    httpptr0 Ptr Word8 -> Ptr (ZonkAny 4) -> Int
    forall a b. Ptr a -> Ptr b -> Int
    `minusPtr` Ptr (ZonkAny 4)
    forall {b}. Ptr b
    pathptr)

        checkHTTP httpptr
        !hv <- httpVersion httpptr
        queryptr <- memchr pathptr _question lim2

        let !method = Ptr Word8 -> Ptr (ZonkAny 8) -> Ptr Word8 -> ByteString
    forall {b} {b} {a}. Ptr b -> Ptr b -> Ptr a -> ByteString
    bs Ptr Word8
    ptr Ptr (ZonkAny 8)
    forall {b}. Ptr b
    methodptr Ptr Word8
    pathptr0
            !path
                | Ptr Word8
    queryptr Ptr Word8 -> Ptr Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ptr Word8
    forall {b}. Ptr b
    nullPtr = Ptr Word8 -> Ptr (ZonkAny 6) -> Ptr Word8 -> ByteString
    forall {b} {b} {a}. Ptr b -> Ptr b -> Ptr a -> ByteString
    bs Ptr Word8
    ptr Ptr (ZonkAny 6)
    forall {b}. Ptr b
    pathptr Ptr Word8
    httpptr0
                | Bool
    otherwise = Ptr Word8 -> Ptr (ZonkAny 7) -> Ptr Word8 -> ByteString
    forall {b} {b} {a}. Ptr b -> Ptr b -> Ptr a -> ByteString
    bs Ptr Word8
    ptr Ptr (ZonkAny 7)
    forall {b}. Ptr b
    pathptr Ptr Word8
    queryptr
            !query
                | Ptr Word8
    queryptr Ptr Word8 -> Ptr Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ptr Word8
    forall {b}. Ptr b
    nullPtr = ByteString
    S.empty
                | Bool
    otherwise = Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> ByteString
    forall {b} {b} {a}. Ptr b -> Ptr b -> Ptr a -> ByteString
    bs Ptr Word8
    ptr Ptr Word8
    queryptr Ptr Word8
    httpptr0

        return (method, path, query, hv)
      where
        baderr :: InvalidRequest
    baderr = String -> InvalidRequest
    BadFirstLine (String -> InvalidRequest) -> String -> InvalidRequest
    forall a b. (a -> b) -> a -> b
    $ ByteString -> String
    C8.unpack ByteString
    requestLine
        check :: Ptr Word8 -> Int -> Word8 -> IO ()
        check :: Ptr Word8 -> Int -> Word8 -> IO ()
    check Ptr Word8
    p Int
    n Word8
    w = do
            w0 <- Ptr Word8 -> IO Word8
    forall a. Storable a => Ptr a -> IO a
    peek (Ptr Word8 -> IO Word8) -> Ptr Word8 -> IO Word8
    forall a b. (a -> b) -> a -> b
    $ Ptr Word8
    p Ptr Word8 -> Int -> Ptr Word8
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    n
            when (w0 /= w) $ throwIO NonHttp
        checkHTTP :: Ptr Word8 -> IO ()
    checkHTTP Ptr Word8
    httpptr = do
            Ptr Word8 -> Int -> Word8 -> IO ()
    check Ptr Word8
    httpptr Int
    0 Word8
    _H
            Ptr Word8 -> Int -> Word8 -> IO ()
    check Ptr Word8
    httpptr Int
    1 Word8
    _T
            Ptr Word8 -> Int -> Word8 -> IO ()
    check Ptr Word8
    httpptr Int
    2 Word8
    _T
            Ptr Word8 -> Int -> Word8 -> IO ()
    check Ptr Word8
    httpptr Int
    3 Word8
    _P
            Ptr Word8 -> Int -> Word8 -> IO ()
    check Ptr Word8
    httpptr Int
    4 Word8
    _slash
            Ptr Word8 -> Int -> Word8 -> IO ()
    check Ptr Word8
    httpptr Int
    6 Word8
    _period
        httpVersion :: Ptr a -> IO HttpVersion
    httpVersion Ptr a
    httpptr = do
            major <- Ptr Word8 -> IO Word8
    forall a. Storable a => Ptr a -> IO a
    peek (Ptr a
    httpptr Ptr a -> Int -> Ptr Word8
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    5) :: IO Word8
            minor <- peek (httpptr `plusPtr` 7) :: IO Word8
            let version
                    | Word8
    major Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    _1 = if Word8
    minor Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    _1 then HttpVersion
    H.http11 else HttpVersion
    H.http10
                    | Word8
    major Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    _2 Bool -> Bool -> Bool
    && Word8
    minor Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    _0 = HttpVersion
    H.http20
                    | Bool
    otherwise = HttpVersion
    H.http10
            return version
        bs :: Ptr b -> Ptr b -> Ptr a -> ByteString
    bs Ptr b
    ptr Ptr b
    p0 Ptr a
    p1 = ForeignPtr Word8 -> Int -> Int -> ByteString
    PS ForeignPtr Word8
    fptr Int
    o Int
    l
          where
            o :: Int
    o = Ptr b
    p0 Ptr b -> Ptr b -> Int
    forall a b. Ptr a -> Ptr b -> Int
    `minusPtr` Ptr b
    ptr
            l :: Int
    l = Ptr a
    p1 Ptr a -> Ptr b -> Int
    forall a b. Ptr a -> Ptr b -> Int
    `minusPtr` Ptr b
    p0

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

    -- |
    --
    -- >>> parseHeader "Content-Length:47"
    -- ("Content-Length","47")
    -- >>> parseHeader "Accept-Ranges: bytes"
    -- ("Accept-Ranges","bytes")
    -- >>> parseHeader "Host:  example.com:8080"
    -- ("Host","example.com:8080")
    -- >>> parseHeader "NoSemiColon"
    -- ("NoSemiColon","")
    parseHeader :: ByteString -> H.Header
    parseHeader :: ByteString -> Header
    parseHeader ByteString
    s =
        let (ByteString
    k, ByteString
    rest) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
    S.break (Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    _colon) ByteString
    s
            rest' :: ByteString
    rest' = (Word8 -> Bool) -> ByteString -> ByteString
    S.dropWhile (\Word8
    c -> Word8
    c Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    _space Bool -> Bool -> Bool
    || Word8
    c Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    _tab) (ByteString -> ByteString) -> ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Int -> ByteString -> ByteString
    S.drop Int
    1 ByteString
    rest
         in (ByteString -> CI ByteString
    forall s. FoldCase s => s -> CI s
    CI.mk ByteString
    k, ByteString
    rest')