--
-- 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 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
    (Int
sc,ByteString
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

    [(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 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 :: ContentEncoding
ce = case Headers -> ByteString -> Maybe ByteString
lookupHeader Headers
h ByteString
"Content-Encoding" of
            Just ByteString
x' -> case ByteString -> CI ByteString
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' -> 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

    Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response :: Int
-> ByteString
-> TransferEncoding
-> ContentEncoding
-> Maybe Int64
-> Headers
-> Response
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." Parser ByteString
-> Parser ByteString Char -> Parser ByteString Char
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 (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 (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 (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char Char
' '
    ByteString
sm <- (Char -> Bool) -> Parser ByteString
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r') Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString
crlf
    (Int, ByteString) -> Parser (Int, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
sc,ByteString
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

    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    -> InputStream ByteString -> IO (InputStream ByteString)
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     -> UnexpectedCompression -> IO (InputStream ByteString)
forall e a. Exception e => e -> IO a
throwIO (String -> UnexpectedCompression
UnexpectedCompression String
"deflate")
        UnknownCE ByteString
x -> UnexpectedCompression -> IO (InputStream ByteString)
forall e a. Exception e => e -> IO a
throwIO (String -> UnexpectedCompression
UnexpectedCompression (ByteString -> String
S.unpack ByteString
x))

    InputStream ByteString -> IO (InputStream ByteString)
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 :: 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. [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 :: 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
showList :: [UnexpectedCompression] -> String -> String
$cshowList :: [UnexpectedCompression] -> String -> String
show :: UnexpectedCompression -> String
$cshow :: UnexpectedCompression -> String
showsPrec :: Int -> UnexpectedCompression -> String -> String
$cshowsPrec :: Int -> 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
    InputStream ByteString
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)
    InputStream ByteString -> IO (InputStream ByteString)
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 Int -> Int -> Bool
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 = () -> Generator ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go !Int
n = do
        (!ByteString
x',!Int
r) <- IO (ByteString, Int) -> Generator ByteString (ByteString, Int)
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
        ByteString -> Generator ByteString ()
forall r. r -> Generator r ()
Streams.yield ByteString
x'
        Int -> Generator ByteString ()
go Int
r

    parseSize :: Generator ByteString Int
parseSize = do
        Int
n <- IO Int -> Generator ByteString Int
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
        Int -> Generator ByteString Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

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

    skipCRLF :: Generator ByteString ()
skipCRLF = do
        IO () -> Generator ByteString ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Generator ByteString ())
-> IO () -> Generator ByteString ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString
_ <- Parser ByteString -> InputStream ByteString -> IO ByteString
forall r. Parser r -> InputStream ByteString -> IO r
Streams.parseFromStream Parser ByteString
crlf InputStream ByteString
i1
            () -> IO ()
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
    (ByteString, Int) -> IO (ByteString, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
x', Int
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
    !Int
n <- Parser ByteString Int
forall a. (Integral a, Bits a) => Parser a
hexadecimal
    Parser ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ((Char -> Bool) -> Parser ByteString
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'))
    Parser ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString
crlf
    Int -> Parser ByteString Int
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
    InputStream ByteString -> IO (InputStream ByteString)
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
    InputStream ByteString -> IO (InputStream ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
i1