diff --git a/http-streams.cabal b/http-streams.cabal --- a/http-streams.cabal +++ b/http-streams.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: http-streams -version: 0.5.0.0 +version: 0.5.0.1 synopsis: An HTTP client using io-streams description: /Overview/ @@ -50,6 +50,7 @@ Network.Http.Connection, Network.Http.RequestBuilder, Network.Http.ResponseParser, + Network.Http.Utilities, Network.Http.Inconvenience ghc-options: -O2 @@ -85,6 +86,7 @@ hspec-expectations, io-streams, mtl, + transformers, network, openssl-streams >= 1.0 && <1.1, snap-core >= 0.9 && < 1.0, diff --git a/src/Network/Http/Utilities.hs b/src/Network/Http/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Network/Http/Utilities.hs @@ -0,0 +1,272 @@ +-- +-- 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 #-} diff --git a/tests/Check.hs b/tests/Check.hs --- a/tests/Check.hs +++ b/tests/Check.hs @@ -11,460 +11,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS -fno-warn-unused-imports #-} -module Check where +module Main where -import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder as Builder (toByteString) -import qualified Blaze.ByteString.Builder.Char8 as Builder (fromChar) -import Control.Exception (Exception, bracket, handleJust) -import Control.Monad (guard) -import Data.Bits -import Data.Maybe (fromJust) -import Data.Monoid -import Data.String -import Network.Socket (SockAddr (..)) -import Network.URI (parseURI) import OpenSSL (withOpenSSL) -import Test.Hspec (Spec, describe, hspec, it) -import Test.Hspec.Expectations (Selector, anyException, shouldThrow) -import Test.HUnit - --- --- Otherwise redundent imports, but useful for testing in GHCi. --- - -import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly, parseTest) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as S -import Debug.Trace -import System.IO.Streams (InputStream, OutputStream) -import qualified System.IO.Streams as Streams - --- --- what we're actually testing --- +import Test.Hspec (hspec) -import Network.Http.Client -import Network.Http.Connection (Connection (..)) -import Network.Http.Inconvenience (HttpClientError (..), - TooManyRedirects (..)) -import Network.Http.ResponseParser (readDecimal, readResponseHeader) -import Network.Http.Types (Request (..), composeRequestBytes, lookupHeader) -import TestServer (localPort, runTestServer) +import TestServer (runTestServer) +import TestSuite (suite) main :: IO () main = withOpenSSL $ do runTestServer hspec suite - -localhost = S.pack ("localhost:" ++ show localPort) - -suite :: Spec -suite = do - describe "Opening a connection" $ do - testConnectionHost - - describe "Request, when serialized" $ do - testRequestLineFormat - testRequestTermination - testEnsureHostField - testAcceptHeaderFormat - testBasicAuthorizatonHeader - - describe "Parsing responses" $ do - testResponseParser1 - testResponseParserMismatch - testChunkedEncoding - testContentLength - testCompressedResponse - testRepeatedResponseHeaders - - describe "Expectation handling" $ do - testExpectationContinue - - describe "Convenience API" $ do - testPutChunks - testPostChunks - testPostWithForm - testGetRedirects - testGetFormatsRequest - testExcessiveRedirects - testGeneralHandler - testEstablishConnection - - -testRequestTermination = - it "terminates with a blank line" $ do - c <- openConnection "localhost" localPort - q <- buildRequest $ do - http GET "/time" - setAccept "text/plain" - - let e' = Builder.toByteString $ composeRequestBytes q "booga" - let n = S.length e' - 4 - let (a',b') = S.splitAt n e' - - assertEqual "Termination not CRLF CRLF" "\r\n\r\n" b' - assertBool "Must be only one blank line at end of headers" - ('\n' /= S.last a') - - closeConnection c - -testRequestLineFormat = - it "has a properly formatted request line" $ bracket - (fakeConnection) - (return) - (\c -> do - q <- buildRequest $ do - http GET "/time" - - let e' = Builder.toByteString $ composeRequestBytes q (cHost c) - let l' = S.takeWhile (/= '\r') e' - - assertEqual "Invalid HTTP request line" "GET /time HTTP/1.1" l') - - -fakeConnection :: IO Connection -fakeConnection = do - i <- Streams.nullInput - o <- Streams.nullOutput - c <- makeConnection "www.example.com" (return ()) o i - return c - - -testAcceptHeaderFormat = - it "properly formats Accept header" $ do - q <- buildRequest $ do - setAccept' [("text/html", 1),("*/*", 0.0)] - - let h = qHeaders q - let (Just a) = lookupHeader h "Accept" - assertEqual "Failed to format header" "text/html; q=1.0, */*; q=0.0" a - -testBasicAuthorizatonHeader = - it "properly formats Authorization header" $ do - q <- buildRequest $ do - setAuthorizationBasic "Aladdin" "open sesame" - - let h = qHeaders q - let (Just a) = lookupHeader h "Authorization" - assertEqual "Failed to format header" "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" a - - -testConnectionHost = do - it "properly caches hostname and port" $ do - bracket (openConnection "localhost" localPort) - closeConnection - (\c -> do - let h' = cHost c - assertEqual "Host value needs to be name, not IP address" - expected h') - where - expected = S.pack $ "localhost:" ++ show localPort - - -{- - Incidentally, Host is *not* stored in the Headers map, but is a field - of the Request object. --} -testEnsureHostField = - it "has a properly formatted Host header" $ do - q1 <- buildRequest $ do - http GET "/hello.txt" - - let h1 = qHost q1 - assertEqual "Incorrect Host header" Nothing h1 - - q2 <- buildRequest $ do - http GET "/hello.txt" - setHostname "other.example.com" 80 - - let h2 = qHost q2 - assertEqual "Incorrect Host header" (Just "other.example.com") h2 - - q3 <- buildRequest $ do - http GET "/hello.txt" - setHostname "other.example.com" 54321 - - let h3 = qHost q3 - assertEqual "Incorrect Host header" (Just "other.example.com:54321") h3 - - -testResponseParser1 = - it "parses a simple 200 response" $ do - 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 - p <- Streams.withFileAsInput "tests/example3.txt" (\i -> readResponseHeader i) - - assertEqual "Incorrect parse of response" 200 (getStatusCode p) - return () - - - -testChunkedEncoding = - it "recognizes chunked transfer encoding and decodes" $ do - c <- openConnection "localhost" localPort - - q <- buildRequest $ do - http GET "/time" - - sendRequest c q emptyBody - receiveResponse c (\p i1 -> do - let cm = getHeader p "Transfer-Encoding" - assertEqual "Should be chunked encoding!" (Just "chunked") cm - - (i2, getCount) <- Streams.countInput i1 - Streams.skipToEof i2 - - len <- getCount - assertEqual "Incorrect number of bytes read" 29 len) - - -testContentLength = - it "recognzies fixed length message" $ do - c <- openConnection "localhost" localPort - - q <- buildRequest $ do - http GET "/static/statler.jpg" - - sendRequest c q emptyBody - - receiveResponse c (\p i1 -> do - let nm = getHeader p "Content-Length" - assertMaybe "Should be a Content-Length header!" nm - - let n = read $ S.unpack $ fromJust nm :: Int - assertEqual "Should be a fixed length message!" 4611 n - - (i2, getCount) <- Streams.countInput i1 - x' <- Streams.readExactly 4611 i2 - - len <- getCount - assertEqual "Incorrect number of bytes read" 4611 len - assertBool "Incorrect length" (4611 == S.length x') - - end <- Streams.atEOF i2 - assertBool "Expected end of stream" end) - -{- - This had to change when we moved to an internal test server; seems - Snap is doing something funny when gzipping and switching to chunked - encoding no matter what I do. --} -testCompressedResponse = - it "recognizes gzip content encoding and decompresses" $ do - c <- openConnection "localhost" localPort - - q <- buildRequest $ do - http GET "/static/hello.html" - setHeader "Accept-Encoding" "gzip" - - sendRequest c q emptyBody - - receiveResponse c (\p i -> do - let nm = getHeader p "Content-Encoding" - assertMaybe "Should be a Content-Encoding header!" nm - assertEqual "Content-Encoding header should be 'gzip'!" (Just "gzip") nm - - (i2, getCount) <- Streams.countInput i - x' <- Streams.readExactly 102 i2 - - len <- getCount - assertEqual "Incorrect number of bytes read" 102 len - assertBool "Incorrect length" (102 == S.length x') - - end <- Streams.atEOF i - assertBool "Expected end of stream" end) - -{- - This isn't much of a test yet; we really need to test - a) that 100 Continue was received b) that it was absorbed - c) that body is correct size, and then d) 4xx and 5xx - responses are propegated through. --} - -testExpectationContinue = - it "sends expectation and handles 100 response" $ do - c <- openConnection "localhost" localPort - - q <- buildRequest $ do - http PUT "/resource/x149" - setExpectContinue - - sendRequest c q (\o -> do - Streams.write (Just "Hello world\n") o) - - receiveResponse c (\p i -> do - assertEqual "Incorrect status code" 201 (getStatusCode p) - x' <- Streams.readExactly 12 i - - end <- Streams.atEOF i - assertBool "Expected end of stream" end - - assertEqual "Incorrect body" "Hello world\n" x') - - closeConnection c - - -assertMaybe :: String -> Maybe a -> Assertion -assertMaybe prefix m0 = - case m0 of - Nothing -> assertFailure prefix - Just _ -> assertBool "" True - - -testPutChunks = - it "PUT correctly chunks known size entity body" $ do - let url = S.concat ["http://", localhost, "/size"] - - put url "text/plain" body handler - where - body :: OutputStream Builder -> IO () - body o = do - let x = mconcat $ replicate 33000 (Builder.fromChar 'x') - Streams.write (Just x) o - - handler :: Response -> InputStream ByteString -> IO () - handler _ i = do - (Just b') <- Streams.read i - - end <- Streams.atEOF i - assertBool "Expected end of stream" end - - let size = readDecimal b' :: Int - assertEqual "Should have replied with correct file size" 33000 size - - -testPostChunks = - it "POST correctly chunks a fileBody" $ do - let url = S.concat ["http://", localhost, "/size"] - - post url "image/jpeg" (fileBody "tests/statler.jpg") handler - where - handler :: Response -> InputStream ByteString -> IO () - handler p i = do - let code = getStatusCode p - assertEqual "Expected 200 OK" 200 code - - (Just b') <- Streams.read i - - end <- Streams.atEOF i - assertBool "Expected end of stream" end - - let size = readDecimal b' :: Int - assertEqual "Should have replied with correct file size" 4611 size - - -testPostWithForm = - it "POST with form data correctly encodes parameters" $ do - let url = S.concat ["http://", localhost, "/postbox"] - - postForm url [("name","Kermit"),("role","St&gehand")] handler - where - handler :: Response -> InputStream ByteString -> IO () - handler p i = do - let code = getStatusCode p - assertEqual "Expected 201" 201 code - - b' <- Streams.readExactly 28 i - - end <- Streams.atEOF i - assertBool "Expected end of stream" end - - assertEqual "Incorrect URL encoding" "name=Kermit&role=St%26gehand" b' - - -testGetRedirects = - it "GET internal handler follows redirect on 307" $ do - let url = S.concat ["http://", localhost, "/bounce"] - - get url handler - where - handler :: Response -> InputStream ByteString -> IO () - handler p i1 = do - let code = getStatusCode p - assertEqual "Should have been final code" 200 code - - (i2, getCount) <- Streams.countInput i1 - Streams.skipToEof i2 - - len <- getCount - assertEqual "Incorrect number of bytes read" 29 len - -testGetFormatsRequest = - it "GET includes a properly formatted request path" $ do - let url = S.concat ["http://", localhost ] - x' <- get url concatHandler' - - assertBool "Incorrect context path" (S.length x' > 0) - -testExcessiveRedirects = - it "too many redirects result in an exception" $ do - let url = S.concat ["http://", localhost, "/loop"] - - get url handler `shouldThrow` tooManyRedirects - where - handler :: Response -> InputStream ByteString -> IO () - 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 - because "although HUnit doesn't have this, it's easy to write your - own". Uh huh. Surely there's an easier way to do this. --} - -assertException :: (Exception e, Eq e) => e -> IO a -> IO () -assertException ex action = - handleJust isWanted (const $ return ()) $ do - _ <- action - assertFailure $ "Expected exception: " ++ show ex - where isWanted = guard . (== ex) - - -testGeneralHandler = - it "GET with general purpose handler throws exception on 404" $ do - let url = S.concat ["http://", localhost, "/booga"] - - get url concatHandler' `shouldThrow` httpClientError 404 - - -tooManyRedirects :: Selector TooManyRedirects -tooManyRedirects = const True - --- :: Int -> Selector HttpClientError -httpClientError :: Int -> HttpClientError -> Bool -httpClientError expected (HttpClientError actual _) = expected == actual - - - -testEstablishConnection = - it "public establish function behaves correctly" $ do - let url = S.concat ["http://", localhost, "/static/statler.jpg"] - - x' <- withConnection (establishConnection url) $ (\c -> do - q <- buildRequest $ do - http GET "/static/statler.jpg" - -- TODO be nice if we could replace that with 'url'; - -- fix the routeRequests function in TestServer maybe? - sendRequest c q emptyBody - receiveResponse c concatHandler') - - let len = S.length x' - assertEqual "Incorrect number of bytes read" 4611 len -