--
-- 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