    --
    -- 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.
    --
    -- Significant portions of this file were written while studying
    -- 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, and various utility functions
    -- have been cloned from there.
    --
    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# OPTIONS_HADDOCK hide, not-home #-}

    module Network.Http.ResponseParser (
        readResponseHeader,
        readResponseBody,
        UnexpectedCompression (..),
        -- for testing
        readDecimal,
    ) where

    import Prelude hiding (take, takeWhile)

    import Control.Exception (Exception, throwIO)
    import Control.Monad (void)
    import Control.Monad.IO.Class (liftIO)
    import Data.Attoparsec.ByteString.Char8
    import Data.Bits (Bits (..))
    import Data.ByteString (ByteString)
    import qualified Data.ByteString.Char8 as S
    import Data.CaseInsensitive (mk)
    import Data.Char (ord)
    import Data.Int (Int64)
    import Data.Typeable (Typeable)
    import System.IO.Streams (Generator, InputStream)
    import qualified System.IO.Streams as Streams
    import qualified System.IO.Streams.Attoparsec as Streams

    #if !MIN_VERSION_base(4,8,0)
    import Control.Applicative
    #endif

    import Network.Http.Internal
    import Network.Http.Utilities

    {-
        The chunk size coming down from the server is somewhat arbitrary;
        it's really just an indication of how many bytes need to be read
        before the next size marker or end marker - neither of which has
        anything to do with streaming on our side. Instead, we'll feed
        bytes into our InputStream at an appropriate intermediate size.
    -}
    __BITE_SIZE__ :: Int
    __BITE_SIZE__ :: Int
    __BITE_SIZE__ = Int
    32 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    1024

    {-
        Process the reply from the server up to the end of the headers as
        deliniated by a blank line.
    -}
    readResponseHeader :: InputStream ByteString -> IO Response
    readResponseHeader :: InputStream ByteString -> IO Response
    readResponseHeader InputStream ByteString
    i = do
        (sc, sm) <- Parser (Int, ByteString)
    -> InputStream ByteString -> IO (Int, ByteString)
    forall r. Parser r -> InputStream ByteString -> IO r
    Streams.parseFromStream Parser (Int, ByteString)
    parseStatusLine InputStream ByteString
    i

        hs <- readHeaderFields i

        let h = [(ByteString, ByteString)] -> Headers
    buildHeaders [(ByteString, ByteString)]
    hs
        let te = case Headers -> ByteString -> Maybe ByteString
    lookupHeader Headers
    h ByteString
    "Transfer-Encoding" of
                Just ByteString
    x' ->
                    if ByteString -> CI ByteString
    forall s. FoldCase s => s -> CI s
    mk ByteString
    x' CI ByteString -> CI ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == CI ByteString
    "chunked"
                        then TransferEncoding
    Chunked
                        else TransferEncoding
    None
                Maybe ByteString
    Nothing -> TransferEncoding
    None

        let ce = case Headers -> ByteString -> Maybe ByteString
    lookupHeader Headers
    h ByteString
    "Content-Encoding" of
                Just ByteString
    x' ->
                    if ByteString -> CI ByteString
    forall s. FoldCase s => s -> CI s
    mk ByteString
    x' CI ByteString -> CI ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == CI ByteString
    "gzip"
                        then ContentEncoding
    Gzip
                        else ContentEncoding
    Identity
                Maybe ByteString
    Nothing -> ContentEncoding
    Identity

        let nm = case Headers -> ByteString -> Maybe ByteString
    lookupHeader Headers
    h ByteString
    "Content-Length" of
                Just ByteString
    x' -> Int64 -> Maybe Int64
    forall a. a -> Maybe a
    Just (ByteString -> Int64
    forall α. (Enum α, Num α, Bits α) => ByteString -> α
    readDecimal ByteString
    x' :: Int64)
                Maybe ByteString
    Nothing -> case Int
    sc of
                    Int
    204 -> Int64 -> Maybe Int64
    forall a. a -> Maybe a
    Just Int64
    0
                    Int
    304 -> Int64 -> Maybe Int64
    forall a. a -> Maybe a
    Just Int64
    0
                    Int
    100 -> Int64 -> Maybe Int64
    forall a. a -> Maybe a
    Just Int64
    0
                    Int
    _ -> Maybe Int64
    forall a. Maybe a
    Nothing

        return
            Response
                { pStatusCode = sc
                , pStatusMsg = sm
                , pTransferEncoding = te
                , pContentEncoding = ce
                , pContentLength = nm
                , pHeaders = h
                }

    parseStatusLine :: Parser (Int, ByteString)
    parseStatusLine :: Parser (Int, ByteString)
    parseStatusLine = do
        sc <- ByteString -> Parser ByteString
    string ByteString
    "HTTP/1." Parser ByteString
    -> Parser ByteString Char -> Parser ByteString Char
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> (Char -> Bool) -> Parser ByteString Char
    satisfy Char -> Bool
    version Parser ByteString Char
    -> Parser ByteString Char -> Parser ByteString Char
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Char -> Parser ByteString Char
    char Char
    ' ' Parser ByteString Char
    -> Parser ByteString Int -> Parser ByteString Int
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Parser ByteString Int
    forall a. Integral a => Parser a
    decimal Parser ByteString Int
    -> Parser ByteString Char -> Parser ByteString Int
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* Char -> Parser ByteString Char
    char Char
    ' '
        sm <- takeTill (== '\r') <* crlf
        return (sc, sm)
      where
        version :: Char -> Bool
    version Char
    c = Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '1' Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '0'

    crlf :: Parser ByteString
    crlf :: Parser ByteString
    crlf = ByteString -> Parser ByteString
    string ByteString
    "\r\n"

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

    {-
        Switch on the encoding and compression headers, wrapping the raw
        InputStream to present the entity body's actual bytes.
    -}
    readResponseBody :: Response -> InputStream ByteString -> IO (InputStream ByteString)
    readResponseBody :: Response -> InputStream ByteString -> IO (InputStream ByteString)
    readResponseBody Response
    p InputStream ByteString
    i1 = do
        i2 <- case TransferEncoding
    t of
            TransferEncoding
    None -> case Maybe Int64
    l of
                Just Int64
    n -> InputStream ByteString -> Int64 -> IO (InputStream ByteString)
    readFixedLengthBody InputStream ByteString
    i1 Int64
    n
                Maybe Int64
    Nothing -> InputStream ByteString -> IO (InputStream ByteString)
    readUnlimitedBody InputStream ByteString
    i1
            TransferEncoding
    Chunked -> InputStream ByteString -> IO (InputStream ByteString)
    readChunkedBody InputStream ByteString
    i1

        i3 <- case c of
            ContentEncoding
    Identity -> InputStream ByteString -> IO (InputStream ByteString)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return InputStream ByteString
    i2
            ContentEncoding
    Gzip -> InputStream ByteString -> IO (InputStream ByteString)
    readCompressedBody InputStream ByteString
    i2
            ContentEncoding
    Deflate -> UnexpectedCompression -> IO (InputStream ByteString)
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (String -> UnexpectedCompression
    UnexpectedCompression (String -> UnexpectedCompression)
    -> String -> UnexpectedCompression
    forall a b. (a -> b) -> a -> b
    $ ContentEncoding -> String
    forall a. Show a => a -> String
    show ContentEncoding
    c)

        return i3
      where
        t :: TransferEncoding
    t = Response -> TransferEncoding
    pTransferEncoding Response
    p
        c :: ContentEncoding
    c = Response -> ContentEncoding
    pContentEncoding Response
    p
        l :: Maybe Int64
    l = Response -> Maybe Int64
    pContentLength Response
    p

    readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α
    readDecimal :: forall α. (Enum α, Num α, Bits α) => ByteString -> α
    readDecimal ByteString
    str' =
        (α -> Char -> α) -> α -> ByteString -> α
    forall a. (a -> Char -> a) -> a -> ByteString -> a
    S.foldl' α -> Char -> α
    forall {a}. (Num a, Enum a, Bits a) => a -> Char -> a
    f α
    0 ByteString
    x'
      where
        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
    + Char -> a
    forall α. (Enum α, Num α, Bits α) => Char -> α
    digitToInt Char
    i

        x' :: ByteString
    x' = [ByteString] -> ByteString
    forall a. HasCallStack => [a] -> a
    head ([ByteString] -> ByteString) -> [ByteString] -> ByteString
    forall a b. (a -> b) -> a -> b
    $ ByteString -> [ByteString]
    S.words ByteString
    str'

        {-# INLINE digitToInt #-}
        digitToInt :: (Enum α, Num α, Bits α) => Char -> α
        digitToInt :: forall α. (Enum α, Num α, Bits α) => Char -> α
    digitToInt Char
    c
            | Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Char
    '0' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Char
    '9' = Int -> α
    forall a. Enum a => Int -> a
    toEnum (Int -> α) -> Int -> α
    forall a b. (a -> b) -> a -> b
    $! Char -> Int
    ord Char
    c Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Char -> Int
    ord Char
    '0'
            | Bool
    otherwise = String -> α
    forall a. HasCallStack => String -> a
    error (String -> α) -> String -> α
    forall a b. (a -> b) -> a -> b
    $ String
    "'" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [Char
    c] String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "' is not an ascii digit"
    {-# INLINE readDecimal #-}

    data UnexpectedCompression = UnexpectedCompression String
        deriving (Typeable, Int -> UnexpectedCompression -> String -> String
    [UnexpectedCompression] -> String -> String
    UnexpectedCompression -> String
    (Int -> UnexpectedCompression -> String -> String)
    -> (UnexpectedCompression -> String)
    -> ([UnexpectedCompression] -> String -> String)
    -> Show UnexpectedCompression
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> UnexpectedCompression -> String -> String
    showsPrec :: Int -> UnexpectedCompression -> String -> String
    $cshow :: UnexpectedCompression -> String
    show :: UnexpectedCompression -> String
    $cshowList :: [UnexpectedCompression] -> String -> String
    showList :: [UnexpectedCompression] -> String -> String
    Show)

    instance Exception UnexpectedCompression

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

    {-
        Process a response body in chunked transfer encoding, taking the
        resultant bytes and reproducing them as an InputStream
    -}
    readChunkedBody :: InputStream ByteString -> IO (InputStream ByteString)
    readChunkedBody :: InputStream ByteString -> IO (InputStream ByteString)
    readChunkedBody InputStream ByteString
    i1 = do
        i2 <- Generator ByteString () -> IO (InputStream ByteString)
    forall r a. Generator r a -> IO (InputStream r)
    Streams.fromGenerator (InputStream ByteString -> Generator ByteString ()
    consumeChunks InputStream ByteString
    i1)
        return i2

    {-
        For a response body in chunked transfer encoding, iterate over
        the individual chunks, reading the size parameter, then
        looping over that chunk in bites of at most __BYTE_SIZE__,
        yielding them to the receiveResponse InputStream accordingly.
    -}
    consumeChunks :: InputStream ByteString -> Generator ByteString ()
    consumeChunks :: InputStream ByteString -> Generator ByteString ()
    consumeChunks InputStream ByteString
    i1 = do
        !n <- Generator ByteString Int
    parseSize

        if n > 0
            then do
                -- read one or more bites, then loop to next chunk
                go n
                skipCRLF
                consumeChunks i1
            else do
                -- skip "trailers" and consume final CRLF
                skipEnd
      where
        go :: Int -> Generator ByteString ()
    go Int
    0 = () -> Generator ByteString ()
    forall a. a -> Generator ByteString a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        go !Int
    n = do
            (!x', !r) <- IO (ByteString, Int) -> Generator ByteString (ByteString, Int)
    forall a. IO a -> Generator ByteString a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (ByteString, Int) -> Generator ByteString (ByteString, Int))
    -> IO (ByteString, Int) -> Generator ByteString (ByteString, Int)
    forall a b. (a -> b) -> a -> b
    $ Int -> InputStream ByteString -> IO (ByteString, Int)
    readN Int
    n InputStream ByteString
    i1
            Streams.yield x'
            go r

        parseSize :: Generator ByteString Int
    parseSize = do
            n <- IO Int -> Generator ByteString Int
    forall a. IO a -> Generator ByteString a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Int -> Generator ByteString Int)
    -> IO Int -> Generator ByteString Int
    forall a b. (a -> b) -> a -> b
    $ Parser ByteString Int -> InputStream ByteString -> IO Int
    forall r. Parser r -> InputStream ByteString -> IO r
    Streams.parseFromStream Parser ByteString Int
    transferChunkSize InputStream ByteString
    i1
            return n

        skipEnd :: Generator ByteString ()
    skipEnd = do
            IO () -> Generator ByteString ()
    forall a. IO a -> Generator ByteString a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Generator ByteString ())
    -> IO () -> Generator ByteString ()
    forall a b. (a -> b) -> a -> b
    $ do
                _ <- InputStream ByteString -> IO [(ByteString, ByteString)]
    readHeaderFields InputStream ByteString
    i1
                return ()

        skipCRLF :: Generator ByteString ()
    skipCRLF = do
            IO () -> Generator ByteString ()
    forall a. IO a -> Generator ByteString a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Generator ByteString ())
    -> IO () -> Generator ByteString ()
    forall a b. (a -> b) -> a -> b
    $ do
                _ <- Parser ByteString -> InputStream ByteString -> IO ByteString
    forall r. Parser r -> InputStream ByteString -> IO r
    Streams.parseFromStream Parser ByteString
    crlf InputStream ByteString
    i1
                return ()

    {-
        Read the specified number of bytes up to a maximum of __BITE_SIZE__,
        returning a resultant ByteString and the number of bytes remaining.
    -}

    readN :: Int -> InputStream ByteString -> IO (ByteString, Int)
    readN :: Int -> InputStream ByteString -> IO (ByteString, Int)
    readN Int
    n InputStream ByteString
    i1 = do
        !x' <- Int -> InputStream ByteString -> IO ByteString
    Streams.readExactly Int
    p InputStream ByteString
    i1
        return (x', r)
      where
        !d :: Int
    d = Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    size

        !p :: Int
    p =
            if Int
    d Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0
                then Int
    size
                else Int
    n

        !r :: Int
    r =
            if Int
    d Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0
                then Int
    d
                else Int
    0

        size :: Int
    size = Int
    __BITE_SIZE__

    transferChunkSize :: Parser (Int)
    transferChunkSize :: Parser ByteString Int
    transferChunkSize = do
        !n <- Parser ByteString Int
    forall a. (Integral a, Bits a) => Parser a
    hexadecimal
        void (takeTill (== '\r'))
        void crlf
        return n

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

    {-
        This has the rather crucial side effect of terminating the stream
        after the requested number of bytes. Otherwise, code handling
        responses waits on more input until an HTTP timeout occurs.
    -}
    readFixedLengthBody :: InputStream ByteString -> Int64 -> IO (InputStream ByteString)
    readFixedLengthBody :: InputStream ByteString -> Int64 -> IO (InputStream ByteString)
    readFixedLengthBody InputStream ByteString
    i1 Int64
    n = do
        i2 <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
    Streams.takeBytes Int64
    n InputStream ByteString
    i1
        return i2

    {-
        On the other hand, there is the (predominently HTTP/1.0) case
        where there is no content length sent and no chunking, with the
        result that only the connection closing marks the end of the
        response body.
    -}
    readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString)
    readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString)
    readUnlimitedBody InputStream ByteString
    i1 = do
        InputStream ByteString -> IO (InputStream ByteString)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return InputStream ByteString
    i1

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

    readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString)
    readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString)
    readCompressedBody InputStream ByteString
    i1 = do
        i2 <- InputStream ByteString -> IO (InputStream ByteString)
    Streams.gunzip InputStream ByteString
    i1
        return i2