--
-- HTTP client for use with io-streams
--
-- Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd
--
-- 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
import Control.Applicative as App

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

#if defined(MIN_VERSION_brotli_streams)
import qualified System.IO.Streams.Brotli as Brotli

brotliDecompress :: InputStream ByteString -> IO (InputStream ByteString)
brotliDecompress :: InputStream ByteString -> IO (InputStream ByteString)
brotliDecompress = InputStream ByteString -> IO (InputStream ByteString)
Brotli.decompress
#else
brotliDecompress :: InputStream ByteString -> IO (InputStream ByteString)
brotliDecompress _ = throwIO (UnexpectedCompression "br")
#endif


{-
    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' -> case forall s. FoldCase s => s -> CI s
mk ByteString
x' of
                         CI ByteString
"gzip"     -> ContentEncoding
Gzip
                         CI ByteString
"br"       -> ContentEncoding
Br
                         CI ByteString
"deflate"  -> ContentEncoding
Deflate
                         CI ByteString
"identity" -> ContentEncoding
Identity
                         CI ByteString
_          -> ByteString -> ContentEncoding
UnknownCE ByteString
x'
            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 (StatusCode,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 (f :: * -> *) a. Applicative f => a -> f a
App.pure InputStream ByteString
i2
        ContentEncoding
Gzip        -> InputStream ByteString -> IO (InputStream ByteString)
Streams.gunzip InputStream ByteString
i2
        ContentEncoding
Br          -> InputStream ByteString -> IO (InputStream ByteString)
brotliDecompress InputStream ByteString
i2
        ContentEncoding
Deflate     -> forall e a. Exception e => e -> IO a
throwIO (String -> UnexpectedCompression
UnexpectedCompression String
"deflate")
        UnknownCE ByteString
x -> forall e a. Exception e => e -> IO a
throwIO (String -> UnexpectedCompression
UnexpectedCompression (ByteString -> String
S.unpack ByteString
x))

    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