{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide, not-home #-}
module Network.Http.ResponseParser (
readResponseHeader,
readResponseBody,
UnexpectedCompression(..),
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
__BITE_SIZE__ :: Int
__BITE_SIZE__ :: Int
__BITE_SIZE__ = Int
32 forall a. Num a => a -> a -> a
* Int
1024
readResponseHeader :: InputStream ByteString -> IO Response
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"
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
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
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
Int -> Generator ByteString ()
go Int
n
Generator ByteString ()
skipCRLF
InputStream ByteString -> Generator ByteString ()
consumeChunks InputStream ByteString
i1
else do
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 ()
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
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
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