http-streams 0.4.0.1 → 0.5.0.0
raw patch · 7 files changed
+151/−108 lines, 7 filesdep +transformersdep ~base
Dependencies added: transformers
Dependency ranges changed: base
Files
- http-streams.cabal +2/−1
- src/Network/Http/Connection.hs +18/−16
- src/Network/Http/Inconvenience.hs +4/−3
- src/Network/Http/RequestBuilder.hs +4/−5
- src/Network/Http/ResponseParser.hs +82/−56
- src/Network/Http/Types.hs +20/−4
- tests/Check.hs +21/−23
http-streams.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: http-streams-version: 0.4.0.1+version: 0.5.0.0 synopsis: An HTTP client using io-streams description: /Overview/@@ -39,6 +39,7 @@ HsOpenSSL, openssl-streams >= 1.0 && <1.1, mtl,+ transformers, network, text, unordered-containers
src/Network/Http/Connection.hs view
@@ -41,6 +41,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S import Data.Monoid (mappend, mempty)+import Data.Word (Word16) import Network.Socket import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL.Session as SSL@@ -57,9 +58,9 @@ the conclusion that URLs are composed of characters, not octets. -} -type Hostname = String+type Hostname = ByteString -type Port = Int+type Port = Word16 -- | A connection to a web server. --@@ -169,8 +170,8 @@ -- connection for subsequent requests. -- openConnection :: Hostname -> Port -> IO Connection-openConnection h p = do- is <- getAddrInfo (Just hints) (Just h) (Just $ show p)+openConnection h1' p = do+ is <- getAddrInfo (Just hints) (Just h1) (Just $ show p) let addr = head is let a = addrAddress addr s <- socket (addrFamily addr) Stream defaultProtocol@@ -181,17 +182,17 @@ o2 <- Streams.builderStream o1 return Connection {- cHost = h',+ cHost = h2', cClose = close s, cOut = o2, cIn = i } where hints = defaultHints {addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV]}- h' :: ByteString- h' = if p == 80- then S.pack h- else S.concat [ S.pack h, ":", S.pack $ show p ]+ h2' = if p == 80+ then h1'+ else S.concat [ h1', ":", S.pack $ show p ]+ h1 = S.unpack h1' -- -- | Open a secure connection to a web server.@@ -224,10 +225,10 @@ -- by the @HsOpenSSL@ package and @openssl-streams@. -- openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection-openConnectionSSL ctx h p = do+openConnectionSSL ctx h1' p = do s <- socket AF_INET Stream defaultProtocol - is <- getAddrInfo Nothing (Just h) (Just $ show p)+ is <- getAddrInfo Nothing (Just h1) (Just $ show p) let a = addrAddress $ head is connect s a@@ -240,16 +241,17 @@ o2 <- Streams.builderStream o1 return Connection {- cHost = h',+ cHost = h2', cClose = closeSSL s ssl, cOut = o2, cIn = i } where- h' :: ByteString- h' = if p == 443- then S.pack h- else S.concat [ S.pack h, ":", S.pack $ show p ]+ h2' :: ByteString+ h2' = if p == 443+ then h1'+ else S.concat [ h1', ":", S.pack $ show p ]+ h1 = S.unpack h1' closeSSL :: Socket -> SSL -> IO () closeSSL s ssl = do
src/Network/Http/Inconvenience.hs view
@@ -50,6 +50,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable (Typeable)+import Data.Word (Word16) import GHC.Exts import GHC.Word (Word8 (..)) import Network.URI (URI (..), URIAuth (..), parseURI)@@ -182,13 +183,13 @@ Just x -> x Nothing -> URIAuth "" "localhost" "" - host = uriRegName auth+ host = S.pack (uriRegName auth) port = case uriPort auth of "" -> 80- _ -> read $ tail $ uriPort auth :: Int+ _ -> read $ tail $ uriPort auth :: Word16 ports = case uriPort auth of "" -> 443- _ -> read $ tail $ uriPort auth :: Int+ _ -> read $ tail $ uriPort auth :: Word16 --
src/Network/Http/RequestBuilder.hs view
@@ -31,8 +31,7 @@ import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as Builder (fromByteString, toByteString)-import qualified Blaze.ByteString.Builder.Char8 as Builder (fromShow,- fromString)+import qualified Blaze.ByteString.Builder.Char8 as Builder (fromShow) import Control.Monad.State import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as BS64@@ -121,7 +120,7 @@ -- you connected to when calling 'Network.Http.Connection.openConnection'. -- setHostname :: Hostname -> Port -> RequestBuilder ()-setHostname h p = do+setHostname h' p = do q <- get put q { qHost = Just v'@@ -129,9 +128,9 @@ where v' :: ByteString v' = if p == 80- then S.pack h+ then h' else Builder.toByteString $ mconcat- [Builder.fromString h,+ [Builder.fromByteString h', ":", Builder.fromShow p]
src/Network/Http/ResponseParser.hs view
@@ -24,15 +24,15 @@ readResponseBody, -- for testing- parseResponse, readDecimal ) where import Prelude hiding (take, takeWhile) import Control.Applicative-import Control.Exception (Exception, throw, throwIO)+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)@@ -41,28 +41,33 @@ import Data.Char (ord) import Data.Int (Int64) import Data.Typeable (Typeable)-import System.IO.Streams (InputStream)+import System.IO.Streams (Generator, InputStream) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec as Streams import Network.Http.Types+import Network.Http.Utilities {-+ The chunk size coming down from the server is somewhat arbitrary;+ it's really just an indication of how many bytes need to be read+ before the next size marker or end marker - neither of which has+ anything to do with streaming on our side. Instead, we'll feed+ bytes into our InputStream at an appropriate intermediate size.+-}+__BITE_SIZE__ :: Int+__BITE_SIZE__ = (32::Int) * (1024::Int)+++{- Process the reply from the server up to the end of the headers as deliniated by a blank line. -} readResponseHeader :: InputStream ByteString -> IO Response readResponseHeader i = do- p <- Streams.parseFromStream parseResponse i- return p--parseResponse :: Parser Response-parseResponse = do- (sc,sm) <- parseStatusLine-- hs <- many parseHeader+ (sc,sm) <- Streams.parseFromStream parseStatusLine i - _ <- crlf+ hs <- readHeaderFields i let h = buildHeaders hs let te = case lookupHeader h "Transfer-Encoding" of@@ -89,10 +94,8 @@ pContentLength = n, pHeaders = h }- where - parseStatusLine :: Parser (Int,ByteString) parseStatusLine = do sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' '@@ -101,25 +104,7 @@ where version c = c == '1' || c == '0' -{-- Needs to be expanded to accept multi-line headers.--}-parseHeader :: Parser (ByteString,ByteString)-parseHeader = do- k <- key <* char ':' <* skipSpace- v <- takeTill (== '\r') <* crlf- return (k,v) -{-- This is actually 'token' in the spec, but seriously?--}-key :: Parser ByteString-key = do- takeWhile token- where- token c = isAlpha_ascii c || isDigit c || (c == '_') || (c == '-')-- crlf :: Parser ByteString crlf = string "\r\n" @@ -173,40 +158,81 @@ -} readChunkedBody :: InputStream ByteString -> IO (InputStream ByteString) readChunkedBody i1 = do- i2 <- Streams.parserToInputStream parseTransferChunk i1+ i2 <- Streams.fromGenerator (consumeChunks i1) return i2 {-- Treat chunks larger than 256kB as a denial-of-service attack.+ For a response body in chunked transfer encoding, iterate over+ the individual chunks, reading the size parameter, then+ looping over that chunk in bites of at most __BYTE_SIZE__,+ yielding them to the receiveResponse InputStream accordingly. -}-mAX_CHUNK_SIZE :: Int-mAX_CHUNK_SIZE = (2::Int)^(18::Int)+consumeChunks :: InputStream ByteString -> Generator ByteString ()+consumeChunks i1 = do+ !n <- parseSize -parseTransferChunk :: Parser (Maybe ByteString)-parseTransferChunk = do- !n <- hexadecimal- void (takeTill (== '\r'))- void crlf- if n >= mAX_CHUNK_SIZE- then return $! throw $! HttpParseException $!- "parseTransferChunk: chunk of size " ++ show n ++ " too long."- else if n <= 0+ if n > 0 then do- -- skip trailers and consume final CRLF- _ <- many parseHeader- void crlf- return Nothing+ -- read one or more bites, then loop to next chunk+ go n+ skipCRLF+ consumeChunks i1 else do- -- now safe to take this many bytes.- !x' <- take n- void crlf- return $! Just x'+ -- skip "trailers" and consume final CRLF+ skipEnd -data HttpParseException = HttpParseException String- deriving (Typeable, Show)+ where+ go 0 = return ()+ go !n = do+ (!x',!r) <- liftIO $ readN n i1+ Streams.yield x'+ go r -instance Exception HttpParseException+ parseSize = do+ n <- liftIO $ Streams.parseFromStream transferChunkSize i1+ return n++ skipEnd = do+ liftIO $ do+ _ <- readHeaderFields i1+ return ()++ skipCRLF = do+ liftIO $ do+ _ <- Streams.parseFromStream crlf i1+ return ()++{-+ Read the specified number of bytes up to a maximum of __BITE_SIZE__,+ returning a resultant ByteString and the number of bytes remaining.+-}++readN :: Int -> InputStream ByteString -> IO (ByteString, Int)+readN n i1 = do+ !x' <- Streams.readExactly p i1+ return (x', r)+ where+ !d = n - size++ !p = if d > 0+ then size+ else n++ !r = if d > 0+ then d+ else 0++ size = __BITE_SIZE__+++transferChunkSize :: Parser (Int)+transferChunkSize = do+ !n <- hexadecimal+ void (takeTill (== '\r'))+ void crlf+ return n+ ---------------------------------------------------------------------
src/Network/Http/Types.hs view
@@ -9,8 +9,9 @@ -- the BSD licence. -- -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS -fno-warn-orphans #-} module Network.Http.Types (@@ -31,6 +32,7 @@ removeHeader, buildHeaders, lookupHeader,+ HttpParseException(..), -- for testing composeRequestBytes,@@ -46,14 +48,16 @@ fromByteString, toByteString) import qualified Blaze.ByteString.Builder.Char8 as Builder+import Control.Exception (Exception) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S import Data.CaseInsensitive (CI, mk, original) import Data.HashMap.Strict (HashMap, delete, empty, foldrWithKey, insert,- lookup)+ insertWith, lookup) import Data.List (foldl') import Data.Monoid (mconcat, mempty) import Data.String (IsString, fromString)+import Data.Typeable (Typeable) -- | HTTP Methods, as per RFC 2616 data Method@@ -345,12 +349,19 @@ where result = foldl' addHeader empty hs +{-+ insertWith is used here for the case where a header is repeated+ (for example, Set-Cookie) and the values need to be intercalated+ with ',' as per RFC 2616 §4.2.+-} addHeader :: HashMap (CI ByteString) ByteString -> (ByteString,ByteString) -> HashMap (CI ByteString) ByteString addHeader m (k,v) =- insert (mk k) v m+ insertWith f (mk k) v m+ where+ f new old = S.concat [old, ",", new] lookupHeader :: Headers -> ByteString -> Maybe ByteString lookupHeader x k =@@ -358,3 +369,8 @@ where !m = unWrap x ++data HttpParseException = HttpParseException String+ deriving (Typeable, Show)++instance Exception HttpParseException
tests/Check.hs view
@@ -11,6 +11,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS -fno-warn-unused-imports #-} +module Check where+ import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as Builder (toByteString) import qualified Blaze.ByteString.Builder.Char8 as Builder (fromChar)@@ -46,7 +48,7 @@ import Network.Http.Connection (Connection (..)) import Network.Http.Inconvenience (HttpClientError (..), TooManyRedirects (..))-import Network.Http.ResponseParser (parseResponse, readDecimal)+import Network.Http.ResponseParser (readDecimal, readResponseHeader) import Network.Http.Types (Request (..), composeRequestBytes, lookupHeader) import TestServer (localPort, runTestServer) @@ -75,6 +77,7 @@ testChunkedEncoding testContentLength testCompressedResponse+ testRepeatedResponseHeaders describe "Expectation handling" $ do testExpectationContinue@@ -92,7 +95,7 @@ testRequestTermination = it "terminates with a blank line" $ do- c <- openConnection "127.0.0.1" localPort+ c <- openConnection "localhost" localPort q <- buildRequest $ do http GET "/time" setAccept "text/plain"@@ -147,12 +150,6 @@ let (Just a) = lookupHeader h "Authorization" assertEqual "Failed to format header" "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" a -{-- FIXME this should indeed be a hostname and not an address; that's the- point of the test (to make sure the address lookup doesn't leak into the- Host: field). Works on an Ubuntu Quantal system with IPv6 enabled; is IPv6- still causing problems for you?--} testConnectionHost = do it "properly caches hostname and port" $ do@@ -195,22 +192,14 @@ testResponseParser1 = it "parses a simple 200 response" $ do- b' <- S.readFile "tests/example1.txt"- let re = parseOnly parseResponse b'- let p = case re of- Left str -> error str- Right x -> x+ p <- Streams.withFileAsInput "tests/example1.txt" (\i -> readResponseHeader i) assertEqual "Incorrect parse of response" 200 (getStatusCode p) return () testResponseParserMismatch = it "parses response when HTTP version doesn't match" $ do- b' <- S.readFile "tests/example3.txt"- let re = parseOnly parseResponse b'- let p = case re of- Left str -> error str- Right x -> x+ p <- Streams.withFileAsInput "tests/example3.txt" (\i -> readResponseHeader i) assertEqual "Incorrect parse of response" 200 (getStatusCode p) return ()@@ -219,7 +208,7 @@ testChunkedEncoding = it "recognizes chunked transfer encoding and decodes" $ do- c <- openConnection "127.0.0.1" localPort+ c <- openConnection "localhost" localPort q <- buildRequest $ do http GET "/time"@@ -238,7 +227,7 @@ testContentLength = it "recognzies fixed length message" $ do- c <- openConnection "127.0.0.1" localPort+ c <- openConnection "localhost" localPort q <- buildRequest $ do http GET "/static/statler.jpg"@@ -269,7 +258,7 @@ -} testCompressedResponse = it "recognizes gzip content encoding and decompresses" $ do- c <- openConnection "127.0.0.1" localPort+ c <- openConnection "localhost" localPort q <- buildRequest $ do http GET "/static/hello.html"@@ -301,7 +290,7 @@ testExpectationContinue = it "sends expectation and handles 100 response" $ do- c <- openConnection "127.0.0.1" localPort+ c <- openConnection "localhost" localPort q <- buildRequest $ do http PUT "/resource/x149"@@ -410,7 +399,7 @@ testGetFormatsRequest = it "GET includes a properly formatted request path" $ do let url = S.concat ["http://", localhost ]- x' <- get "http://localhost" concatHandler'+ x' <- get url concatHandler' assertBool "Incorrect context path" (S.length x' > 0) @@ -424,6 +413,15 @@ handler _ _ = do assertBool "Should have thrown exception before getting here" False +testRepeatedResponseHeaders =+ it "repeated response headers are properly concatonated" $ do+ let url = S.concat ["http://", localhost, "/cookies"]++ get url handler+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler r _ = do+ assertEqual "Invalid response headers" (Just "stone=diamond,metal=tungsten") (getHeader r "Set-Cookie") {- From http://stackoverflow.com/questions/6147435/is-there-an-assertexception-in-any-of-the-haskell-test-frameworks