Utilities.hs

--
-- 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 input = do
    eof <- Streams.atEOF input
    if eof
        then return Nothing
        else do
            line <- readResponseLine input
            let (!mStr, !s) = bSp line
            let (!uri, !vStr) = bSp s
            let !version = pVer vStr :: (Int, Int)

            --      hdrs    <- readHeaderFields input
            return $! Nothing
  where
    pVer s =
        if "HTTP/" `S.isPrefixOf` s
            then pVers (S.unsafeDrop 5 s)
            else (1, 0)

    bSp = splitCh ' '

    pVers s = (c, d)
      where
        (!a, !b) = splitCh '.' s
        !c = unsafeFromNat a
        !d = unsafeFromNat b

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

    throwBadCRLF =
        throwIO $
            HttpParseException "parse error: got cr without subsequent lf"

    go !l = do
        !mb <- Streams.read input
        !s <- maybe throwNoCRLF return mb

        case findCRLF s of
            FoundCRLF idx# -> foundCRLF l s idx#
            NoCR -> noCRLF l s
            LastIsCR idx# -> lastIsCR l s idx#
            _ -> throwBadCRLF

    foundCRLF l s idx# = do
        let !i1 = (I# idx#)
        let !i2 = (I# (idx# +# 2#))
        let !a = S.unsafeTake i1 s
        when (i2 < S.length s) $ do
            let !b = S.unsafeDrop i2 s
            Streams.unRead b input

        -- Optimize for the common case: dl is almost always "id"
        let !out = if null l then a else S.concat (reverse (a : l))
        return out

    noCRLF l s = go (s : l)

    lastIsCR l s idx# = do
        !t <- Streams.read input >>= maybe throwNoCRLF return
        if S.null t
            then lastIsCR l s idx#
            else do
                let !c = S.unsafeHead t
                if c /= 10
                    then throwBadCRLF
                    else do
                        let !a = S.unsafeTake (I# idx#) s
                        let !b = S.unsafeDrop 1 t
                        when (not $ S.null b) $ Streams.unRead b input
                        let !out = if null l then a else S.concat (reverse (a : l))
                        return out

------------------------------------------------------------------------------
data CS
    = FoundCRLF !Int#
    | NoCR
    | LastIsCR !Int#
    | BadCR

------------------------------------------------------------------------------
findCRLF :: ByteString -> CS
findCRLF b =
    case S.elemIndex '\r' b of
        Nothing -> NoCR
        Just !i@(I# i#) ->
            let !i' = i + 1
             in if i' < S.length b
                    then
                        if S.unsafeIndex b i' == 10
                            then FoundCRLF i#
                            else BadCR
                    else LastIsCR i#
{-# INLINE findCRLF #-}

------------------------------------------------------------------------------
splitCh :: Char -> ByteString -> (ByteString, ByteString)
splitCh !c !s = maybe (s, S.empty) f (S.elemIndex c s)
  where
    f !i =
        let !a = S.unsafeTake i s
            !b = S.unsafeDrop (i + 1) s
         in (a, b)
{-# INLINE splitCh #-}

------------------------------------------------------------------------------
breakCh :: Char -> ByteString -> (ByteString, ByteString)
breakCh !c !s = maybe (s, S.empty) f (S.elemIndex c s)
  where
    f !i =
        let !a = S.unsafeTake i s
            !b = S.unsafeDrop i s
         in (a, b)
{-# INLINE breakCh #-}

------------------------------------------------------------------------------
splitHeader :: ByteString -> (ByteString, ByteString)
splitHeader !s = maybe (s, S.empty) f (S.elemIndex ':' s)
  where
    l = S.length s

    f i =
        let !a = S.unsafeTake i s
         in (a, skipSp (i + 1))

    skipSp !i
        | i >= l = S.empty
        | otherwise =
            let c = S.unsafeIndex s i
             in if isLWS $ w2c c
                    then skipSp $ i + 1
                    else S.unsafeDrop i s
{-# INLINE splitHeader #-}

------------------------------------------------------------------------------
isLWS :: Char -> Bool
isLWS c = c == ' ' || c == '\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 input = do
    f <- go id
    return $! f []
  where
    go !dlistSoFar = do
        line <- readResponseLine input
        if S.null line
            then return dlistSoFar
            else do
                let (!k, !v) = splitHeader line
                vf <- pCont id
                let vs = vf []
                let !v' = if null vs then v else S.concat (v : vs)
                let !t = (k, v')
                go (dlistSoFar . (t :))
      where
        trimBegin = S.dropWhile isLWS

        pCont !dlist = do
            mbS <- Streams.peek input
            maybe
                (return dlist)
                ( \s ->
                    if S.null s
                        then Streams.read input >> pCont dlist
                        else
                            if isLWS $ w2c $ S.unsafeHead s
                                then procCont dlist
                                else return dlist
                )
                mbS

        procCont !dlist = do
            line <- readResponseLine input
            let !t = trimBegin line
            pCont (dlist . (" " :) . (t :))

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

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

-- | Note: only works for nonnegative naturals
unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a
unsafeFromNat = S.foldl' f 0
  where
    zero = ord '0'
    f !cnt !i = cnt * 10 + toEnum (digitToInt i)

    digitToInt c =
        if d >= 0 && d <= 9
            then d
            else error $ "bad digit: '" ++ [c] ++ "'"
      where
        !d = ord c - zero
{-# INLINE unsafeFromNat #-}