{-# 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
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Network.Http.Internal
import Network.Http.Utilities
__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' ->
if forall s. FoldCase s => s -> CI s
mk ByteString
x' 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' -> 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 (Int, 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 (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
i2
ContentEncoding
Gzip -> InputStream ByteString -> IO (InputStream ByteString)
readCompressedBody InputStream ByteString
i2
ContentEncoding
Deflate -> forall e a. Exception e => e -> IO a
throwIO (String -> UnexpectedCompression
UnexpectedCompression forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ContentEncoding
c)
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
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
forall (m :: * -> *) a. Monad m => a -> m a
return InputStream ByteString
i2