-- -- HTTP client for use with io-streams -- -- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd -- -- 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 Trustworthy #-} {-# LANGUAGE UnboxedTuples #-} 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 ------------------------------------------------------------------------------ {- 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 #-}