--
-- 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__ = 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' -> 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 :: 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 (Int,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 (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. 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 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


---------------------------------------------------------------------

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
    InputStream ByteString -> IO (InputStream ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
i2