{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_HADDOCK hide, not-home #-}
module Network.Http.Utilities (
readResponseLine,
readHeaderFields
) where
import Control.Exception (throwIO)
import Control.Monad (when)
import Data.Bits
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Internal (ByteString, w2c)
import qualified Data.ByteString.Unsafe as S
import Data.Char hiding (digitToInt, isDigit, isSpace)
import GHC.Exts (Int (..), Int#, (+#))
import Prelude hiding (head, take, takeWhile)
import System.IO.Streams (InputStream)
import qualified System.IO.Streams as Streams
import Network.Http.Types
parseRequest :: InputStream ByteString -> IO (Maybe Request)
parseRequest :: InputStream ByteString -> IO (Maybe Request)
parseRequest InputStream ByteString
input = do
Bool
eof <- InputStream ByteString -> IO Bool
forall a. InputStream a -> IO Bool
Streams.atEOF InputStream ByteString
input
if Bool
eof
then Maybe Request -> IO (Maybe Request)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Request
forall a. Maybe a
Nothing
else do
ByteString
line <- InputStream ByteString -> IO ByteString
readResponseLine InputStream ByteString
input
let (!ByteString
mStr,!ByteString
s) = ByteString -> (ByteString, ByteString)
bSp ByteString
line
let (!ByteString
uri, !ByteString
vStr) = ByteString -> (ByteString, ByteString)
bSp ByteString
s
let !version :: (Int, Int)
version = ByteString -> (Int, Int)
forall {a} {b}.
(Enum a, Enum b, Num a, Num b, Bits a, Bits b) =>
ByteString -> (a, b)
pVer ByteString
vStr :: (Int,Int)
Maybe Request -> IO (Maybe Request)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Request -> IO (Maybe Request))
-> Maybe Request -> IO (Maybe Request)
forall a b. (a -> b) -> a -> b
$! Maybe Request
forall a. Maybe a
Nothing
where
pVer :: ByteString -> (a, b)
pVer ByteString
s = if ByteString
"HTTP/" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
s
then ByteString -> (a, b)
forall {a} {b}.
(Enum a, Num a, Bits a, Enum b, Num b, Bits b) =>
ByteString -> (a, b)
pVers (Int -> ByteString -> ByteString
S.unsafeDrop Int
5 ByteString
s)
else (a
1, b
0)
bSp :: ByteString -> (ByteString, ByteString)
bSp = Char -> ByteString -> (ByteString, ByteString)
splitCh Char
' '
pVers :: ByteString -> (a, b)
pVers ByteString
s = (a
c, b
d)
where
(!ByteString
a, !ByteString
b) = Char -> ByteString -> (ByteString, ByteString)
splitCh Char
'.' ByteString
s
!c :: a
c = ByteString -> a
forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat ByteString
a
!d :: b
d = ByteString -> b
forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat ByteString
b
readResponseLine :: InputStream ByteString -> IO ByteString
readResponseLine :: InputStream ByteString -> IO ByteString
readResponseLine InputStream ByteString
input = [ByteString] -> IO ByteString
go []
where
throwNoCRLF :: IO a
throwNoCRLF =
HttpParseException -> IO a
forall e a. Exception e => e -> IO a
throwIO (HttpParseException -> IO a) -> HttpParseException -> IO a
forall a b. (a -> b) -> a -> b
$
String -> HttpParseException
HttpParseException String
"parse error: expected line ending in crlf"
throwBadCRLF :: IO a
throwBadCRLF =
HttpParseException -> IO a
forall e a. Exception e => e -> IO a
throwIO (HttpParseException -> IO a) -> HttpParseException -> IO a
forall a b. (a -> b) -> a -> b
$
String -> HttpParseException
HttpParseException String
"parse error: got cr without subsequent lf"
go :: [ByteString] -> IO ByteString
go ![ByteString]
l = do
!Maybe ByteString
mb <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input
!ByteString
s <- IO ByteString
-> (ByteString -> IO ByteString)
-> Maybe ByteString
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ByteString
forall {a}. IO a
throwNoCRLF ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
mb
case ByteString -> CS
findCRLF ByteString
s of
FoundCRLF Int#
idx# -> [ByteString] -> ByteString -> Int# -> IO ByteString
foundCRLF [ByteString]
l ByteString
s Int#
idx#
CS
NoCR -> [ByteString] -> ByteString -> IO ByteString
noCRLF [ByteString]
l ByteString
s
LastIsCR Int#
idx# -> [ByteString] -> ByteString -> Int# -> IO ByteString
lastIsCR [ByteString]
l ByteString
s Int#
idx#
CS
_ -> IO ByteString
forall {a}. IO a
throwBadCRLF
foundCRLF :: [ByteString] -> ByteString -> Int# -> IO ByteString
foundCRLF [ByteString]
l ByteString
s Int#
idx# = do
let !i1 :: Int
i1 = (Int# -> Int
I# Int#
idx#)
let !i2 :: Int
i2 = (Int# -> Int
I# (Int#
idx# Int# -> Int# -> Int#
+# Int#
2#))
let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
i1 ByteString
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int
S.length ByteString
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let !b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop Int
i2 ByteString
s
ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
b InputStream ByteString
input
let !out :: ByteString
out = if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
l then ByteString
a else [ByteString] -> ByteString
S.concat ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString
aByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
l))
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out
noCRLF :: [ByteString] -> ByteString -> IO ByteString
noCRLF [ByteString]
l ByteString
s = [ByteString] -> IO ByteString
go (ByteString
sByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
l)
lastIsCR :: [ByteString] -> ByteString -> Int# -> IO ByteString
lastIsCR [ByteString]
l ByteString
s Int#
idx# = do
!ByteString
t <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input IO (Maybe ByteString)
-> (Maybe ByteString -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ByteString
-> (ByteString -> IO ByteString)
-> Maybe ByteString
-> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ByteString
forall {a}. IO a
throwNoCRLF ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
if ByteString -> Bool
S.null ByteString
t
then [ByteString] -> ByteString -> Int# -> IO ByteString
lastIsCR [ByteString]
l ByteString
s Int#
idx#
else do
let !c :: Word8
c = ByteString -> Word8
S.unsafeHead ByteString
t
if Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
10
then IO ByteString
forall {a}. IO a
throwBadCRLF
else do
let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake (Int# -> Int
I# Int#
idx#) ByteString
s
let !b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop Int
1 ByteString
t
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
S.null ByteString
b) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> InputStream ByteString -> IO ()
forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
b InputStream ByteString
input
let !out :: ByteString
out = if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
l then ByteString
a else [ByteString] -> ByteString
S.concat ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse (ByteString
aByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
l))
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out
data CS = FoundCRLF !Int#
| NoCR
| LastIsCR !Int#
| BadCR
findCRLF :: ByteString -> CS
findCRLF :: ByteString -> CS
findCRLF ByteString
b =
case Char -> ByteString -> Maybe Int
S.elemIndex Char
'\r' ByteString
b of
Maybe Int
Nothing -> CS
NoCR
Just !i :: Int
i@(I# Int#
i#) ->
let !i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
in if Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int
S.length ByteString
b
then if ByteString -> Int -> Word8
S.unsafeIndex ByteString
b Int
i' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
10
then Int# -> CS
FoundCRLF Int#
i#
else CS
BadCR
else Int# -> CS
LastIsCR Int#
i#
{-# INLINE findCRLF #-}
splitCh :: Char -> ByteString -> (ByteString, ByteString)
splitCh :: Char -> ByteString -> (ByteString, ByteString)
splitCh !Char
c !ByteString
s = (ByteString, ByteString)
-> (Int -> (ByteString, ByteString))
-> Maybe Int
-> (ByteString, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString
s, ByteString
S.empty) Int -> (ByteString, ByteString)
f (Char -> ByteString -> Maybe Int
S.elemIndex Char
c ByteString
s)
where
f :: Int -> (ByteString, ByteString)
f !Int
i = let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
i ByteString
s
!b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
s
in (ByteString
a, ByteString
b)
{-# INLINE splitCh #-}
breakCh :: Char -> ByteString -> (ByteString, ByteString)
breakCh :: Char -> ByteString -> (ByteString, ByteString)
breakCh !Char
c !ByteString
s = (ByteString, ByteString)
-> (Int -> (ByteString, ByteString))
-> Maybe Int
-> (ByteString, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString
s, ByteString
S.empty) Int -> (ByteString, ByteString)
f (Char -> ByteString -> Maybe Int
S.elemIndex Char
c ByteString
s)
where
f :: Int -> (ByteString, ByteString)
f !Int
i = let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
i ByteString
s
!b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop Int
i ByteString
s
in (ByteString
a, ByteString
b)
{-# INLINE breakCh #-}
splitHeader :: ByteString -> (ByteString, ByteString)
!ByteString
s = (ByteString, ByteString)
-> (Int -> (ByteString, ByteString))
-> Maybe Int
-> (ByteString, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString
s, ByteString
S.empty) Int -> (ByteString, ByteString)
f (Char -> ByteString -> Maybe Int
S.elemIndex Char
':' ByteString
s)
where
l :: Int
l = ByteString -> Int
S.length ByteString
s
f :: Int -> (ByteString, ByteString)
f Int
i = let !a :: ByteString
a = Int -> ByteString -> ByteString
S.unsafeTake Int
i ByteString
s
in (ByteString
a, Int -> ByteString
skipSp (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
skipSp :: Int -> ByteString
skipSp !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l = ByteString
S.empty
| Bool
otherwise = let c :: Word8
c = ByteString -> Int -> Word8
S.unsafeIndex ByteString
s Int
i
in if Char -> Bool
isLWS (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c Word8
c
then Int -> ByteString
skipSp (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
else Int -> ByteString -> ByteString
S.unsafeDrop Int
i ByteString
s
{-# INLINE splitHeader #-}
isLWS :: Char -> Bool
isLWS :: Char -> Bool
isLWS Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'
{-# INLINE isLWS #-}
readHeaderFields :: InputStream ByteString -> IO [(ByteString,ByteString)]
InputStream ByteString
input = do
[(ByteString, ByteString)] -> [(ByteString, ByteString)]
f <- ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> IO ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
forall {c}.
([(ByteString, ByteString)] -> c)
-> IO ([(ByteString, ByteString)] -> c)
go [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> a
id
[(ByteString, ByteString)] -> IO [(ByteString, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ByteString, ByteString)] -> IO [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> IO [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$! [(ByteString, ByteString)] -> [(ByteString, ByteString)]
f []
where
go :: ([(ByteString, ByteString)] -> c)
-> IO ([(ByteString, ByteString)] -> c)
go ![(ByteString, ByteString)] -> c
dlistSoFar = do
ByteString
line <- InputStream ByteString -> IO ByteString
readResponseLine InputStream ByteString
input
if ByteString -> Bool
S.null ByteString
line
then ([(ByteString, ByteString)] -> c)
-> IO ([(ByteString, ByteString)] -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return [(ByteString, ByteString)] -> c
dlistSoFar
else do
let (!ByteString
k,!ByteString
v) = ByteString -> (ByteString, ByteString)
splitHeader ByteString
line
[ByteString] -> [ByteString]
vf <- ([ByteString] -> [ByteString]) -> IO ([ByteString] -> [ByteString])
forall {c}. ([ByteString] -> c) -> IO ([ByteString] -> c)
pCont [ByteString] -> [ByteString]
forall a. a -> a
id
let vs :: [ByteString]
vs = [ByteString] -> [ByteString]
vf []
let !v' :: ByteString
v' = if [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
vs then ByteString
v else [ByteString] -> ByteString
S.concat (ByteString
vByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
vs)
let !t :: (ByteString, ByteString)
t = (ByteString
k,ByteString
v')
([(ByteString, ByteString)] -> c)
-> IO ([(ByteString, ByteString)] -> c)
go ([(ByteString, ByteString)] -> c
dlistSoFar ([(ByteString, ByteString)] -> c)
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)]
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString)
t(ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
:))
where
trimBegin :: ByteString -> ByteString
trimBegin = (Char -> Bool) -> ByteString -> ByteString
S.dropWhile Char -> Bool
isLWS
pCont :: ([ByteString] -> c) -> IO ([ByteString] -> c)
pCont ![ByteString] -> c
dlist = do
Maybe ByteString
mbS <- InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.peek InputStream ByteString
input
IO ([ByteString] -> c)
-> (ByteString -> IO ([ByteString] -> c))
-> Maybe ByteString
-> IO ([ByteString] -> c)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (([ByteString] -> c) -> IO ([ByteString] -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString] -> c
dlist)
(\ByteString
s -> if ByteString -> Bool
S.null ByteString
s
then InputStream ByteString -> IO (Maybe ByteString)
forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input IO (Maybe ByteString)
-> IO ([ByteString] -> c) -> IO ([ByteString] -> c)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([ByteString] -> c) -> IO ([ByteString] -> c)
pCont [ByteString] -> c
dlist
else if Char -> Bool
isLWS (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$ ByteString -> Word8
S.unsafeHead ByteString
s
then ([ByteString] -> c) -> IO ([ByteString] -> c)
procCont [ByteString] -> c
dlist
else ([ByteString] -> c) -> IO ([ByteString] -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString] -> c
dlist)
Maybe ByteString
mbS
procCont :: ([ByteString] -> c) -> IO ([ByteString] -> c)
procCont ![ByteString] -> c
dlist = do
ByteString
line <- InputStream ByteString -> IO ByteString
readResponseLine InputStream ByteString
input
let !t :: ByteString
t = ByteString -> ByteString
trimBegin ByteString
line
([ByteString] -> c) -> IO ([ByteString] -> c)
pCont ([ByteString] -> c
dlist ([ByteString] -> c)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
" "ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
tByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:))
unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat :: forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat = (a -> Char -> a) -> a -> ByteString -> a
forall a. (a -> Char -> a) -> a -> ByteString -> a
S.foldl' a -> Char -> a
forall {a}. (Num a, Enum a) => a -> Char -> a
f a
0
where
zero :: Int
zero = Char -> Int
ord Char
'0'
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
+ Int -> a
forall a. Enum a => Int -> a
toEnum (Char -> Int
digitToInt Char
i)
digitToInt :: Char -> Int
digitToInt Char
c = if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
9
then Int
d
else String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"bad digit: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
where
!d :: Int
d = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
zero
{-# INLINE unsafeFromNat #-}