    --
    -- HTTP client for use with io-streams
    --
    -- Copyright © 2012-2021 Athae Eredh Siniath and Others
    --
    -- The code in this file, and the program it is a part of, is
    -- made available to you by its authors as open source software:
    -- you can redistribute it and/or modify it under the terms of
    -- the BSD licence.
    --
    -- This file is essentially a clone of Snap.Internal.Parsing,
    -- the HTTP request parser implementation in the Snap Framework;
    -- snap-core's src/Snap/Internal/Parsing.hs and snap-server's
    -- src/Snap/Internal/Http/Parser.hs, copied here to specialize
    -- it to Response parsing. This code replaces the attoparsec
    -- based implementation formerly in ResponseParser, but is
    -- kept separate to aid syncing changes from snap-core as they
    -- become available.
    --
    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE Rank2Types #-}
    {-# LANGUAGE UnboxedTuples #-}
    {-# OPTIONS_HADDOCK hide, not-home #-}

    module Network.Http.Utilities (
        readResponseLine,
        readHeaderFields,
    ) where

    ------------------------------------------------------------------------------
    import Control.Exception (throwIO)
    import Control.Monad (when)
    import Data.Bits
    import qualified Data.ByteString.Char8 as S
    import Data.ByteString.Internal (ByteString, w2c)
    import qualified Data.ByteString.Unsafe as S
    import Data.Char hiding (digitToInt, isDigit, isSpace)
    import GHC.Exts (Int (..), Int#, (+#))
    import System.IO.Streams (InputStream)
    import qualified System.IO.Streams as Streams
    import Prelude hiding (head, take, takeWhile)

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

    import Network.Http.Types

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

    {-
        This is vestigial; originally it was the Request parsing
        code in Snap. Keeping it here until we can use if for
        response parsing.
    -}
    parseRequest :: InputStream ByteString -> IO (Maybe Request)
    parseRequest :: InputStream ByteString -> IO (Maybe Request)
    parseRequest InputStream ByteString
    input = do
        eof <- InputStream ByteString -> IO Bool
    forall a. InputStream a -> IO Bool
    Streams.atEOF InputStream ByteString
    input
        if eof
            then return Nothing
            else do
                line <- readResponseLine input
                let (!mStr, !s) = bSp line
                let (!uri, !vStr) = bSp s
                let !version = ByteString -> (Int, Int)
    forall {a} {b}.
    (Enum a, Enum b, Num a, Num b, Bits a, Bits b) =>
    ByteString -> (a, b)
    pVer ByteString
    vStr :: (Int, Int)

                --      hdrs    <- readHeaderFields input
                return $! Nothing
      where
        pVer :: ByteString -> (a, b)
    pVer ByteString
    s =
            if ByteString
    "HTTP/" ByteString -> ByteString -> Bool
    `S.isPrefixOf` ByteString
    s
                then ByteString -> (a, b)
    forall {a} {b}.
    (Enum a, Enum b, Num a, Num b, Bits a, Bits b) =>
    ByteString -> (a, b)
    pVers (Int -> ByteString -> ByteString
    S.unsafeDrop Int
    5 ByteString
    s)
                else (a
    1, b
    0)

        bSp :: ByteString -> (ByteString, ByteString)
    bSp = Char -> ByteString -> (ByteString, ByteString)
    splitCh Char
    ' '

        pVers :: ByteString -> (a, b)
    pVers ByteString
    s = (a
    c, b
    d)
          where
            (!ByteString
    a, !ByteString
    b) = Char -> ByteString -> (ByteString, ByteString)
    splitCh Char
    '.' ByteString
    s
            !c :: a
    c = ByteString -> a
    forall a. (Enum a, Num a, Bits a) => ByteString -> a
    unsafeFromNat ByteString
    a
            !d :: b
    d = ByteString -> b
    forall a. (Enum a, Num a, Bits a) => ByteString -> a
    unsafeFromNat ByteString
    b

    {-
        Read a single line of an HTTP response.
    -}
    readResponseLine :: InputStream ByteString -> IO ByteString
    readResponseLine :: InputStream ByteString -> IO ByteString
    readResponseLine InputStream ByteString
    input = [ByteString] -> IO ByteString
    go []
      where
        throwNoCRLF :: IO a
    throwNoCRLF =
            HttpParseException -> IO a
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (HttpParseException -> IO a) -> HttpParseException -> IO a
    forall a b. (a -> b) -> a -> b
    $
                String -> HttpParseException
    HttpParseException String
    "parse error: expected line ending in crlf"

        throwBadCRLF :: IO a
    throwBadCRLF =
            HttpParseException -> IO a
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (HttpParseException -> IO a) -> HttpParseException -> IO a
    forall a b. (a -> b) -> a -> b
    $
                String -> HttpParseException
    HttpParseException String
    "parse error: got cr without subsequent lf"

        go :: [ByteString] -> IO ByteString
    go ![ByteString]
    l = do
            !mb <- InputStream ByteString -> IO (Maybe ByteString)
    forall a. InputStream a -> IO (Maybe a)
    Streams.read InputStream ByteString
    input
            !s <- maybe throwNoCRLF return mb

            case findCRLF s of
                FoundCRLF Int#
    idx# -> [ByteString] -> ByteString -> Int# -> IO ByteString
    foundCRLF [ByteString]
    l ByteString
    s Int#
    idx#
                CS
    NoCR -> [ByteString] -> ByteString -> IO ByteString
    noCRLF [ByteString]
    l ByteString
    s
                LastIsCR Int#
    idx# -> [ByteString] -> ByteString -> Int# -> IO ByteString
    lastIsCR [ByteString]
    l ByteString
    s Int#
    idx#
                CS
    _ -> IO ByteString
    forall {a}. IO a
    throwBadCRLF

        foundCRLF :: [ByteString] -> ByteString -> Int# -> IO ByteString
    foundCRLF [ByteString]
    l ByteString
    s Int#
    idx# = do
            let !i1 :: Int
    i1 = (Int# -> Int
    I# Int#
    idx#)
            let !i2 :: Int
    i2 = (Int# -> Int
    I# (Int#
    idx# Int# -> Int# -> Int#
    +# Int#
    2#))
            let !a :: ByteString
    a = Int -> ByteString -> ByteString
    S.unsafeTake Int
    i1 ByteString
    s
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    i2 Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < ByteString -> Int
    S.length ByteString
    s) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                let !b :: ByteString
    b = Int -> ByteString -> ByteString
    S.unsafeDrop Int
    i2 ByteString
    s
                ByteString -> InputStream ByteString -> IO ()
    forall a. a -> InputStream a -> IO ()
    Streams.unRead ByteString
    b InputStream ByteString
    input

            -- Optimize for the common case: dl is almost always "id"
            let !out :: ByteString
    out = if [ByteString] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ByteString]
    l then ByteString
    a else [ByteString] -> ByteString
    S.concat ([ByteString] -> [ByteString]
    forall a. [a] -> [a]
    reverse (ByteString
    a ByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    : [ByteString]
    l))
            ByteString -> IO ByteString
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ByteString
    out

        noCRLF :: [ByteString] -> ByteString -> IO ByteString
    noCRLF [ByteString]
    l ByteString
    s = [ByteString] -> IO ByteString
    go (ByteString
    s ByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    : [ByteString]
    l)

        lastIsCR :: [ByteString] -> ByteString -> Int# -> IO ByteString
    lastIsCR [ByteString]
    l ByteString
    s Int#
    idx# = do
            !t <- InputStream ByteString -> IO (Maybe ByteString)
    forall a. InputStream a -> IO (Maybe a)
    Streams.read InputStream ByteString
    input IO (Maybe ByteString)
    -> (Maybe ByteString -> IO ByteString) -> IO ByteString
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= IO ByteString
    -> (ByteString -> IO ByteString)
    -> Maybe ByteString
    -> IO ByteString
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe IO ByteString
    forall {a}. IO a
    throwNoCRLF ByteString -> IO ByteString
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
            if S.null t
                then lastIsCR l s idx#
                else do
                    let !c = ByteString -> Word8
    S.unsafeHead ByteString
    t
                    if c /= 10
                        then throwBadCRLF
                        else do
                            let !a = Int -> ByteString -> ByteString
    S.unsafeTake (Int# -> Int
    I# Int#
    idx#) ByteString
    s
                            let !b = Int -> ByteString -> ByteString
    S.unsafeDrop Int
    1 ByteString
    t
                            when (not $ S.null b) $ Streams.unRead b input
                            let !out = if [ByteString] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ByteString]
    l then ByteString
    a else [ByteString] -> ByteString
    S.concat ([ByteString] -> [ByteString]
    forall a. [a] -> [a]
    reverse (ByteString
    a ByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    : [ByteString]
    l))
                            return out

    ------------------------------------------------------------------------------
    data CS
        = FoundCRLF !Int#
        | NoCR
        | LastIsCR !Int#
        | BadCR

    ------------------------------------------------------------------------------
    findCRLF :: ByteString -> CS
    findCRLF :: ByteString -> CS
    findCRLF ByteString
    b =
        case Char -> ByteString -> Maybe Int
    S.elemIndex Char
    '\r' ByteString
    b of
            Maybe Int
    Nothing -> CS
    NoCR
            Just !i :: Int
    i@(I# Int#
    i#) ->
                let !i' :: Int
    i' = Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
                 in if Int
    i' Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < ByteString -> Int
    S.length ByteString
    b
                        then
                            if ByteString -> Int -> Word8
    S.unsafeIndex ByteString
    b Int
    i' Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    10
                                then Int# -> CS
    FoundCRLF Int#
    i#
                                else CS
    BadCR
                        else Int# -> CS
    LastIsCR Int#
    i#
    {-# INLINE findCRLF #-}

    ------------------------------------------------------------------------------
    splitCh :: Char -> ByteString -> (ByteString, ByteString)
    splitCh :: Char -> ByteString -> (ByteString, ByteString)
    splitCh !Char
    c !ByteString
    s = (ByteString, ByteString)
    -> (Int -> (ByteString, ByteString))
    -> Maybe Int
    -> (ByteString, ByteString)
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (ByteString
    s, ByteString
    S.empty) Int -> (ByteString, ByteString)
    f (Char -> ByteString -> Maybe Int
    S.elemIndex Char
    c ByteString
    s)
      where
        f :: Int -> (ByteString, ByteString)
    f !Int
    i =
            let !a :: ByteString
    a = Int -> ByteString -> ByteString
    S.unsafeTake Int
    i ByteString
    s
                !b :: ByteString
    b = Int -> ByteString -> ByteString
    S.unsafeDrop (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) ByteString
    s
             in (ByteString
    a, ByteString
    b)
    {-# INLINE splitCh #-}

    ------------------------------------------------------------------------------
    breakCh :: Char -> ByteString -> (ByteString, ByteString)
    breakCh :: Char -> ByteString -> (ByteString, ByteString)
    breakCh !Char
    c !ByteString
    s = (ByteString, ByteString)
    -> (Int -> (ByteString, ByteString))
    -> Maybe Int
    -> (ByteString, ByteString)
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (ByteString
    s, ByteString
    S.empty) Int -> (ByteString, ByteString)
    f (Char -> ByteString -> Maybe Int
    S.elemIndex Char
    c ByteString
    s)
      where
        f :: Int -> (ByteString, ByteString)
    f !Int
    i =
            let !a :: ByteString
    a = Int -> ByteString -> ByteString
    S.unsafeTake Int
    i ByteString
    s
                !b :: ByteString
    b = Int -> ByteString -> ByteString
    S.unsafeDrop Int
    i ByteString
    s
             in (ByteString
    a, ByteString
    b)
    {-# INLINE breakCh #-}

    ------------------------------------------------------------------------------
    splitHeader :: ByteString -> (ByteString, ByteString)
    splitHeader :: ByteString -> (ByteString, ByteString)
    splitHeader !ByteString
    s = (ByteString, ByteString)
    -> (Int -> (ByteString, ByteString))
    -> Maybe Int
    -> (ByteString, ByteString)
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (ByteString
    s, ByteString
    S.empty) Int -> (ByteString, ByteString)
    f (Char -> ByteString -> Maybe Int
    S.elemIndex Char
    ':' ByteString
    s)
      where
        l :: Int
    l = ByteString -> Int
    S.length ByteString
    s

        f :: Int -> (ByteString, ByteString)
    f Int
    i =
            let !a :: ByteString
    a = Int -> ByteString -> ByteString
    S.unsafeTake Int
    i ByteString
    s
             in (ByteString
    a, Int -> ByteString
    skipSp (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1))

        skipSp :: Int -> ByteString
    skipSp !Int
    i
            | Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    l = ByteString
    S.empty
            | Bool
    otherwise =
                let c :: Word8
    c = ByteString -> Int -> Word8
    S.unsafeIndex ByteString
    s Int
    i
                 in if Char -> Bool
    isLWS (Char -> Bool) -> Char -> Bool
    forall a b. (a -> b) -> a -> b
    $ Word8 -> Char
    w2c Word8
    c
                        then Int -> ByteString
    skipSp (Int -> ByteString) -> Int -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
                        else Int -> ByteString -> ByteString
    S.unsafeDrop Int
    i ByteString
    s
    {-# INLINE splitHeader #-}

    ------------------------------------------------------------------------------
    isLWS :: Char -> Bool
    isLWS :: Char -> Bool
    isLWS Char
    c = Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ' ' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\t'
    {-# INLINE isLWS #-}

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

    {-
        Read the remainder of the response message's header section,
        parsing into key/value pairs. Note that this function terminates
        when it hits the "blank" line (ie, CRLF CRLF pair), which it
        consumes.
    -}
    readHeaderFields :: InputStream ByteString -> IO [(ByteString, ByteString)]
    readHeaderFields :: InputStream ByteString -> IO [(ByteString, ByteString)]
    readHeaderFields InputStream ByteString
    input = do
        f <- ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
    -> IO ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
    forall {c}.
    ([(ByteString, ByteString)] -> c)
    -> IO ([(ByteString, ByteString)] -> c)
    go [(ByteString, ByteString)] -> [(ByteString, ByteString)]
    forall a. a -> a
    id
        return $! f []
      where
        go :: ([(ByteString, ByteString)] -> c)
    -> IO ([(ByteString, ByteString)] -> c)
    go ![(ByteString, ByteString)] -> c
    dlistSoFar = do
            line <- InputStream ByteString -> IO ByteString
    readResponseLine InputStream ByteString
    input
            if S.null line
                then return dlistSoFar
                else do
                    let (!k, !v) = splitHeader line
                    vf <- pCont id
                    let vs = [ByteString] -> [ByteString]
    vf []
                    let !v' = if [ByteString] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ByteString]
    vs then ByteString
    v else [ByteString] -> ByteString
    S.concat (ByteString
    v ByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    : [ByteString]
    vs)
                    let !t = (ByteString
    k, ByteString
    v')
                    go (dlistSoFar . (t :))
          where
            trimBegin :: ByteString -> ByteString
    trimBegin = (Char -> Bool) -> ByteString -> ByteString
    S.dropWhile Char -> Bool
    isLWS

            pCont :: ([ByteString] -> c) -> IO ([ByteString] -> c)
    pCont ![ByteString] -> c
    dlist = do
                mbS <- InputStream ByteString -> IO (Maybe ByteString)
    forall a. InputStream a -> IO (Maybe a)
    Streams.peek InputStream ByteString
    input
                maybe
                    (return dlist)
                    ( \ByteString
    s ->
                        if ByteString -> Bool
    S.null ByteString
    s
                            then InputStream ByteString -> IO (Maybe ByteString)
    forall a. InputStream a -> IO (Maybe a)
    Streams.read InputStream ByteString
    input IO (Maybe ByteString)
    -> IO ([ByteString] -> c) -> IO ([ByteString] -> c)
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> ([ByteString] -> c) -> IO ([ByteString] -> c)
    pCont [ByteString] -> c
    dlist
                            else
                                if Char -> Bool
    isLWS (Char -> Bool) -> Char -> Bool
    forall a b. (a -> b) -> a -> b
    $ Word8 -> Char
    w2c (Word8 -> Char) -> Word8 -> Char
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Word8
    S.unsafeHead ByteString
    s
                                    then ([ByteString] -> c) -> IO ([ByteString] -> c)
    procCont [ByteString] -> c
    dlist
                                    else ([ByteString] -> c) -> IO ([ByteString] -> c)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ByteString] -> c
    dlist
                    )
                    mbS

            procCont :: ([ByteString] -> c) -> IO ([ByteString] -> c)
    procCont ![ByteString] -> c
    dlist = do
                line <- InputStream ByteString -> IO ByteString
    readResponseLine InputStream ByteString
    input
                let !t = ByteString -> ByteString
    trimBegin ByteString
    line
                pCont (dlist . (" " :) . (t :))

    -----------------------
    -- utility functions --
    -----------------------

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

    -- | Note: only works for nonnegative naturals
    unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a
    unsafeFromNat :: forall a. (Enum a, Num a, Bits a) => ByteString -> a
    unsafeFromNat = (a -> Char -> a) -> a -> ByteString -> a
    forall a. (a -> Char -> a) -> a -> ByteString -> a
    S.foldl' a -> Char -> a
    forall {a}. (Num a, Enum a) => a -> Char -> a
    f a
    0
      where
        zero :: Int
    zero = Char -> Int
    ord Char
    '0'
        f :: a -> Char -> a
    f !a
    cnt !Char
    i = a
    cnt a -> a -> a
    forall a. Num a => a -> a -> a
    * a
    10 a -> a -> a
    forall a. Num a => a -> a -> a
    + Int -> a
    forall a. Enum a => Int -> a
    toEnum (Char -> Int
    digitToInt Char
    i)

        digitToInt :: Char -> Int
    digitToInt Char
    c =
            if Int
    d Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    0 Bool -> Bool -> Bool
    && Int
    d Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    9
                then Int
    d
                else String -> Int
    forall a. HasCallStack => String -> a
    error (String -> Int) -> String -> Int
    forall a b. (a -> b) -> a -> b
    $ String
    "bad digit: '" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [Char
    c] String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "'"
          where
            !d :: Int
    d = Char -> Int
    ord Char
    c Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    zero
    {-# INLINE unsafeFromNat #-}