--
-- HTTP client for use with io-streams
--
-- Copyright © 2012-2021 Athae Eredh Siniath and Others
--
-- 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.
--
-- This file is essentially a clone of Snap.Internal.Parsing,
-- 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, copied here to specialize
-- it to Response parsing. This code replaces the attoparsec
-- based implementation formerly in ResponseParser, but is
-- kept separate to aid syncing changes from snap-core as they
-- become available.
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# 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 System.IO.Streams (InputStream)
import qualified System.IO.Streams as Streams
import Prelude hiding (head, take, takeWhile)

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

import Network.Http.Types

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

{-
    This is vestigial; originally it was the Request parsing
    code in Snap. Keeping it here until we can use if for
    response parsing.
-}
parseRequest :: InputStream ByteString -> IO (Maybe Request)
parseRequest :: InputStream ByteString -> IO (Maybe Request)
parseRequest InputStream ByteString
input = do
    Bool
eof <- forall a. InputStream a -> IO Bool
Streams.atEOF InputStream ByteString
input
    if Bool
eof
        then forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall {a} {b}.
(Enum a, Enum b, Num a, Num b, Bits a, Bits b) =>
ByteString -> (a, b)
pVer ByteString
vStr :: (Int, Int)

            --      hdrs    <- readHeaderFields input
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Maybe a
Nothing
  where
    pVer :: ByteString -> (a, b)
pVer ByteString
s =
        if ByteString
"HTTP/" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
s
            then 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 = forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat ByteString
a
        !d :: b
d = forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat ByteString
b

{-
    Read a single line of an HTTP response.
-}
readResponseLine :: InputStream ByteString -> IO ByteString
readResponseLine :: InputStream ByteString -> IO ByteString
readResponseLine InputStream ByteString
input = [ByteString] -> IO ByteString
go []
  where
    throwNoCRLF :: IO a
throwNoCRLF =
        forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
            String -> HttpParseException
HttpParseException String
"parse error: expected line ending in crlf"

    throwBadCRLF :: IO a
throwBadCRLF =
        forall e a. Exception e => e -> IO a
throwIO 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 <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input
        !ByteString
s <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. IO a
throwNoCRLF 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
_ -> 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i2 forall a. Ord a => a -> a -> Bool
< ByteString -> Int
S.length ByteString
s) forall a b. (a -> b) -> a -> b
$ do
            let !b :: ByteString
b = Int -> ByteString -> ByteString
S.unsafeDrop Int
i2 ByteString
s
            forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
b InputStream ByteString
input

        -- Optimize for the common case: dl is almost always "id"
        let !out :: ByteString
out = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
l then ByteString
a else [ByteString] -> ByteString
S.concat (forall a. [a] -> [a]
reverse (ByteString
a forall a. a -> [a] -> [a]
: [ByteString]
l))
        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
s forall a. a -> [a] -> [a]
: [ByteString]
l)

    lastIsCR :: [ByteString] -> ByteString -> Int# -> IO ByteString
lastIsCR [ByteString]
l ByteString
s Int#
idx# = do
        !ByteString
t <- forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. IO a
throwNoCRLF 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 forall a. Eq a => a -> a -> Bool
/= Word8
10
                    then 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
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
S.null ByteString
b) forall a b. (a -> b) -> a -> b
$ forall a. a -> InputStream a -> IO ()
Streams.unRead ByteString
b InputStream ByteString
input
                        let !out :: ByteString
out = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
l then ByteString
a else [ByteString] -> ByteString
S.concat (forall a. [a] -> [a]
reverse (ByteString
a forall a. a -> [a] -> [a]
: [ByteString]
l))
                        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 forall a. Num a => a -> a -> a
+ Int
1
             in if Int
i' forall a. Ord a => a -> a -> Bool
< ByteString -> Int
S.length ByteString
b
                    then
                        if ByteString -> Int -> Word8
S.unsafeIndex ByteString
b Int
i' 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 = 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 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 = 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)
splitHeader :: ByteString -> (ByteString, ByteString)
splitHeader !ByteString
s = 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 forall a. Num a => a -> a -> a
+ Int
1))

    skipSp :: Int -> ByteString
skipSp !Int
i
        | Int
i 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 forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c Word8
c
                    then Int -> ByteString
skipSp forall a b. (a -> b) -> a -> b
$ Int
i 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 forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t'
{-# INLINE isLWS #-}

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

{-
    Read the remainder of the response message's header section,
    parsing into key/value pairs. Note that this function terminates
    when it hits the "blank" line (ie, CRLF CRLF pair), which it
    consumes.
-}
readHeaderFields :: InputStream ByteString -> IO [(ByteString, ByteString)]
readHeaderFields :: InputStream ByteString -> IO [(ByteString, ByteString)]
readHeaderFields InputStream ByteString
input = do
    [(ByteString, ByteString)] -> [(ByteString, ByteString)]
f <- forall {c}.
([(ByteString, ByteString)] -> c)
-> IO ([(ByteString, ByteString)] -> c)
go forall a. a -> a
id
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 <- forall {c}. ([ByteString] -> c) -> IO ([ByteString] -> c)
pCont forall a. a -> a
id
                let vs :: [ByteString]
vs = [ByteString] -> [ByteString]
vf []
                let !v' :: ByteString
v' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
vs then ByteString
v else [ByteString] -> ByteString
S.concat (ByteString
v 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString)
t 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 <- forall a. InputStream a -> IO (Maybe a)
Streams.peek InputStream ByteString
input
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString] -> c
dlist)
                ( \ByteString
s ->
                    if ByteString -> Bool
S.null ByteString
s
                        then forall a. InputStream a -> IO (Maybe a)
Streams.read InputStream ByteString
input 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 forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c forall a b. (a -> b) -> a -> b
$ ByteString -> Word8
S.unsafeHead ByteString
s
                                then ([ByteString] -> c) -> IO ([ByteString] -> c)
procCont [ByteString] -> c
dlist
                                else 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
" " forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
t forall a. a -> [a] -> [a]
:))

-----------------------
-- utility functions --
-----------------------

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

-- | Note: only works for nonnegative naturals
unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat :: forall a. (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat = forall a. (a -> Char -> a) -> a -> ByteString -> a
S.foldl' 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 forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a. Enum a => Int -> a
toEnum (Char -> Int
digitToInt Char
i)

    digitToInt :: Char -> Int
digitToInt Char
c =
        if Int
d forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
d forall a. Ord a => a -> a -> Bool
<= Int
9
            then Int
d
            else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"bad digit: '" forall a. [a] -> [a] -> [a]
++ [Char
c] forall a. [a] -> [a] -> [a]
++ String
"'"
      where
        !d :: Int
d = Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Int
zero
{-# INLINE unsafeFromNat #-}