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

#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__ = 32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 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 i :: InputStream ByteString
i = do
    (sc :: Int
sc,sm :: 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 "Transfer-Encoding" of
            Just x' :: 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
== "chunked"
                        then TransferEncoding
Chunked
                        else TransferEncoding
None
            Nothing -> TransferEncoding
None

    let ce :: ContentEncoding
ce = case Headers -> ByteString -> Maybe ByteString
lookupHeader Headers
h "Content-Encoding" of
            Just x' :: 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
== "gzip"
                        then ContentEncoding
Gzip
                        else ContentEncoding
Identity
            Nothing -> ContentEncoding
Identity

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

    Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return $WResponse :: 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 (Int,ByteString)
parseStatusLine :: Parser (Int, ByteString)
parseStatusLine = do
    Int
sc <- ByteString -> Parser ByteString
string "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 ' ' 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 ' '
    ByteString
sm <- (Char -> Bool) -> Parser ByteString
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\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 c :: Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '1' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '0'


crlf :: Parser ByteString
crlf :: Parser ByteString
crlf = ByteString -> Parser ByteString
string "\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 p :: Response
p i1 :: InputStream ByteString
i1 = do

    InputStream ByteString
i2 <- case TransferEncoding
t of
        None        -> case Maybe Int64
l of
                        Just n :: Int64
n  -> InputStream ByteString -> Int64 -> IO (InputStream ByteString)
readFixedLengthBody InputStream ByteString
i1 Int64
n
                        Nothing -> InputStream ByteString -> IO (InputStream ByteString)
readUnlimitedBody InputStream ByteString
i1
        Chunked     -> InputStream ByteString -> IO (InputStream ByteString)
readChunkedBody InputStream ByteString
i1

    InputStream ByteString
i3 <- case ContentEncoding
c of
        Identity    -> InputStream ByteString -> IO (InputStream ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
i2
        Gzip        -> InputStream ByteString -> IO (InputStream ByteString)
readCompressedBody InputStream ByteString
i2
        Deflate     -> UnexpectedCompression -> IO (InputStream ByteString)
forall e a. 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)

    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 str' :: 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
* 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 c :: Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '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 '0'
                 | Bool
otherwise = String -> α
forall a. HasCallStack => String -> a
error (String -> α) -> String -> α
forall a b. (a -> b) -> a -> b
$ "'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c] String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' 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 i1 :: 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 i1 :: InputStream ByteString
i1 = do
    !Int
n <- Generator ByteString Int
parseSize

    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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 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 n :: Int
n i1 :: 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
> 0
        then Int
size
        else Int
n

    !r :: Int
r = if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
        then Int
d
        else 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
== '\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 i1 :: InputStream ByteString
i1 n :: 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 i1 :: InputStream ByteString
i1 = do
    InputStream ByteString -> IO (InputStream ByteString)
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 i1 :: InputStream ByteString
i1 = do
    InputStream ByteString
i2 <- InputStream ByteString -> IO (InputStream ByteString)
Streams.gunzip InputStream ByteString
i1
    InputStream ByteString -> IO (InputStream ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
i2