--
-- 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 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
    (Int
sc, ByteString
sm) <- forall r. Parser r -> InputStream ByteString -> IO r
Streams.parseFromStream Parser (Int, ByteString)
parseStatusLine InputStream ByteString
i

    [(ByteString, ByteString)]
hs <- InputStream ByteString -> IO [(ByteString, ByteString)]
readHeaderFields InputStream ByteString
i

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

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

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

    forall (m :: * -> *) a. Monad m => a -> m a
return
        Response
            { pStatusCode :: Int
pStatusCode = Int
sc
            , pStatusMsg :: ByteString
pStatusMsg = ByteString
sm
            , pTransferEncoding :: TransferEncoding
pTransferEncoding = TransferEncoding
te
            , pContentEncoding :: ContentEncoding
pContentEncoding = ContentEncoding
ce
            , pContentLength :: Maybe Int64
pContentLength = Maybe Int64
nm
            , pHeaders :: Headers
pHeaders = Headers
h
            }

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

    InputStream ByteString
i3 <- case ContentEncoding
c of
        ContentEncoding
Identity -> 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 -> forall e a. Exception e => e -> IO a
throwIO (String -> UnexpectedCompression
UnexpectedCompression forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ContentEncoding
c)

    forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
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' =
    forall a. (a -> Char -> a) -> a -> ByteString -> a
S.foldl' 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 forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall α. (Enum α, Num α, Bits α) => Char -> α
digitToInt Char
i

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

data UnexpectedCompression = UnexpectedCompression String
    deriving (Typeable, Int -> UnexpectedCompression -> ShowS
[UnexpectedCompression] -> ShowS
UnexpectedCompression -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnexpectedCompression] -> ShowS
$cshowList :: [UnexpectedCompression] -> ShowS
show :: UnexpectedCompression -> String
$cshow :: UnexpectedCompression -> String
showsPrec :: Int -> UnexpectedCompression -> ShowS
$cshowsPrec :: Int -> UnexpectedCompression -> ShowS
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
    InputStream ByteString
i2 <- forall r a. Generator r a -> IO (InputStream r)
Streams.fromGenerator (InputStream ByteString -> Generator ByteString ()
consumeChunks InputStream ByteString
i1)
    forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
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
    !Int
n <- Generator ByteString Int
parseSize

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

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

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

    skipCRLF :: Generator ByteString ()
skipCRLF = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            ByteString
_ <- forall r. Parser r -> InputStream ByteString -> IO r
Streams.parseFromStream Parser ByteString
crlf InputStream ByteString
i1
            forall (m :: * -> *) a. Monad m => a -> m a
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
    !ByteString
x' <- Int -> InputStream ByteString -> IO ByteString
Streams.readExactly Int
p InputStream ByteString
i1
    forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
x', Int
r)
  where
    !d :: Int
d = Int
n forall a. Num a => a -> a -> a
- Int
size

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

    !r :: Int
r =
        if Int
d 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
    !Int
n <- forall a. (Integral a, Bits a) => Parser a
hexadecimal
    forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Char -> Bool) -> Parser ByteString
takeTill (forall a. Eq a => a -> a -> Bool
== Char
'\r'))
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString
crlf
    forall (m :: * -> *) a. Monad m => a -> m a
return Int
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
    InputStream ByteString
i2 <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.takeBytes Int64
n InputStream ByteString
i1
    forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
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
    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
    InputStream ByteString
i2 <- InputStream ByteString -> IO (InputStream ByteString)
Streams.gunzip InputStream ByteString
i1
    forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
i2