http-io-streams 0.1.6.1 → 0.1.6.2
raw patch · 12 files changed
+1201/−30 lines, 12 filesdep +HUnitdep +aesondep +aeson-prettydep ~basedep ~bytestringdep ~containersbinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, aeson, aeson-pretty, hspec, hspec-expectations, lifted-base, snap, snap-core, snap-server, system-fileio, system-filepath, unordered-containers
Dependency ranges changed: base, bytestring, containers, mtl, text
API changes (from Hackage documentation)
Files
- CHANGELOG.md +20/−9
- http-io-streams.cabal +67/−21
- tests/MockServer.hs +325/−0
- tests/TestSuite.hs +723/−0
- tests/check.hs +25/−0
- tests/example1.txt +6/−0
- tests/example2.txt +17/−0
- tests/example3.txt binary
- tests/example4.txt +6/−0
- tests/example5.txt +3/−0
- tests/hello.html +9/−0
- tests/statler.jpg binary
CHANGELOG.md view
@@ -1,13 +1,24 @@ See also http://pvp.haskell.org/faq -### 0.1.6.1+#### 0.1.6.2 +* Allow `mtl-2.3` (no code change).+* Run test-suite via `cabal test`.++Tested with GHC 7.4 - 9.6.++#### 0.1.6.1 revision 1++* Allow `text-2.0` (no code change).++#### 0.1.6.1+ * Build with GHC 9.2 and `ghc-prim-0.8` (via `base-4.16`). ### 0.1.6.0 * New function `openConnectionAddress''` supporting supplying local `SSLContext`s as well as modifying the `SSL` connection before initiating the client SSL handshake.-* New function `openConnectionSSL'` which allows to customize the 'SSL' connection /before/ a client SSL handshake is attempted.+* New function `openConnectionSSL'` which allows to customize the SSL connection _before_ a client SSL handshake is attempted. * New convenience function `getContextSSL` function allowing to retrieve global `SSLContext`. ### 0.1.5.0@@ -21,21 +32,21 @@ ### 0.1.3.0 -* New functions `receiveUpgradeResponse`, 'receiveConnectResponse', and `unsafeWithRawStreams` for accessing full-duplex low-level streams (e.g. for upgrading to Websockets protocol+* New functions `receiveUpgradeResponse`, `receiveConnectResponse`, and `unsafeWithRawStreams` for accessing full-duplex low-level streams (e.g. for upgrading to Websockets protocol). * New function `makeConnection` for constructing a `Connection` object over custom streams. ### 0.1.2.0 -* New functions `unsafeReceiveResponse` and `unsafeReceiveResponseRaw` that do not automatically skip to end-of-stream+* New functions `unsafeReceiveResponse` and `unsafeReceiveResponseRaw` that do not automatically skip to end-of-stream. ### 0.1.1.0 -* New alternative connection-setup API (`ConnectionAddress` et al.)-* New function `getHeaderMap` for exporting all response headers at once-* Add convenience functions `bytestringBody`, `lazyBytestringBody`, `utf8TextBody`, `utf8LazyTextBody`-* Add support for Brotli HTTP compression+* New alternative connection-setup API (`ConnectionAddress` et al.).+* New function `getHeaderMap` for exporting all response headers at once.+* Add convenience functions `bytestringBody`, `lazyBytestringBody`, `utf8TextBody`, `utf8LazyTextBody`.+* Add support for Brotli HTTP compression. ## 0.1.0.0 * First version. Released on an unsuspecting world.-* Derived from `http-streams-core-0.8.6.1` & `http-common-0.8.2.0`+* Derived from `http-streams-core-0.8.6.1` & `http-common-0.8.2.0`.
http-io-streams.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: http-io-streams-version: 0.1.6.1+version: 0.1.6.2 synopsis: HTTP and WebSocket client based on io-streams description:@@ -15,14 +15,25 @@ license-files: LICENSE LICENSE.GPLv2 author: Andrew Cowie <andrew@operationaldynamics.com>, Herbert Valerio Riedel <hvr@gnu.org>-maintainer: Herbert Valerio Riedel <hvr@gnu.org>+maintainer: https://github.com/haskell-hvr/http-io-streams copyright: © 2012-2018 Operational Dynamics Consulting, Pty Ltd and Others category: Web, IO-Streams-bug-reports: https://github.com/hvr/http-io-streams/issues-extra-source-files: CHANGELOG.md+bug-reports: https://github.com/haskell-hvr/http-io-streams/issues +extra-source-files:+ CHANGELOG.md+ tests/example1.txt+ tests/example2.txt+ tests/example3.txt+ tests/example4.txt+ tests/example5.txt+ tests/hello.html+ tests/statler.jpg+ tested-with:- GHC == 9.2.2+ GHC == 9.6.0+ GHC == 9.4.4+ GHC == 9.2.5 GHC == 9.0.2 GHC == 8.10.7 GHC == 8.8.4@@ -37,7 +48,7 @@ source-repository head type: git- location: https://github.com/hvr/http-io-streams.git+ location: https://github.com/haskell-hvr/http-io-streams.git flag brotli manual: True@@ -51,11 +62,22 @@ common settings build-depends:- , base >= 4.5 && < 4.17+ , base >= 4.5 && < 4.19+ , attoparsec ^>= 0.13.2.2 || ^>= 0.14.4+ , base64-bytestring ^>= 1.2.1.0 , blaze-builder ^>= 0.4.1.0 , bytestring >= 0.10.0.0 && < 0.12 , case-insensitive ^>= 1.2.0.11 , containers ^>= 0.5.0.0 || ^>= 0.6.0.1+ , directory ^>= 1.2.0.1 || ^>= 1.3.0.0+ , HsOpenSSL ^>= 0.11.2+ , io-streams ^>= 1.5.0.1+ , mtl ^>= 2.2.2 || ^>= 2.3.1+ , network ^>= 2.6.0.0 || ^>= 2.7.0.0 || ^>= 2.8.0.0 || ^>= 3.0.0.0 || ^>= 3.1.0.0+ , network-uri ^>= 2.6.0.0+ , openssl-streams ^>= 1.2.1.3+ , text ^>= 1.2.3.0 || ^>= 2.0+ , transformers ^>= 0.3.0.0 || ^>= 0.4.2.0 || ^>= 0.5.2.0 || ^>= 0.6.0.4 default-language: Haskell2010 other-extensions:@@ -93,17 +115,8 @@ brotli-streams ^>= 0.0.0.0 build-depends:- , HsOpenSSL ^>= 0.11.2- , attoparsec ^>= 0.13.2.2 || ^>= 0.14.4 , binary ^>= 0.7.1 || ^>= 0.8.3 , cryptohash-sha1 ^>= 0.11.100- , directory ^>= 1.2.0.1 || ^>= 1.3.0.0- , io-streams ^>= 1.5.0.1- , network ^>= 2.6.0.0 || ^>= 2.7.0.0 || ^>= 2.8.0.0 || ^>= 3.0.0.0 || ^>= 3.1.0.0- , network-uri ^>= 2.6.0.0- , openssl-streams ^>= 1.2.1.3- , text ^>= 1.2.3.0- , transformers ^>= 0.3.0.0 || ^>= 0.4.2.0 || ^>= 0.5.2.0 hs-source-dirs: http-streams/lib exposed-modules:@@ -115,13 +128,46 @@ Network.Http.Utilities Network.Http.Inconvenience - -- http-common- build-depends:- , base64-bytestring ^>= 1.2.1.0- , mtl ^>= 2.2.2- hs-source-dirs: http-common/lib other-modules: Network.Http.Types Network.Http.RequestBuilder, Network.Http.Internal+++test-suite test+ import: settings+ type: exitcode-stdio-1.0++ hs-source-dirs:+ http-common/lib+ http-streams/lib+ tests+ main-is:+ check.hs+ other-modules:+ MockServer+ TestSuite+ Network.Http.Client+ Network.Http.Connection+ Network.Http.Inconvenience+ Network.Http.Internal+ Network.Http.RequestBuilder+ Network.Http.ResponseParser+ Network.Http.Types+ Network.Http.Utilities++ build-depends:+ -- http-io-streams+ , aeson+ , aeson-pretty+ , hspec+ , hspec-expectations+ , HUnit+ , lifted-base+ , snap+ , snap-core+ , snap-server+ , system-filepath+ , system-fileio+ , unordered-containers
+ tests/MockServer.hs view
@@ -0,0 +1,325 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2014 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 a BSD licence.+--++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# OPTIONS -fno-warn-dodgy-imports #-}++module MockServer (runMockServer, localPort) where++{-+ Per http://hackage.haskell.org/trac/ghc/ticket/7167, we suppress+ the warning resulting from this line, necessary on <7.6+-}+import Prelude hiding (catch)++import Control.Applicative+import Control.Concurrent (forkIO, threadDelay)+import Control.Exception (SomeException)+import Control.Exception.Lifted (catch)+import "mtl" Control.Monad.Trans (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe (fromMaybe)+import Filesystem (getSize)+import Filesystem.Path.CurrentOS (decodeString)+import Snap.Core+import Snap.Http.Server+import Snap.Util.FileServe+import System.IO (hFlush, hPutStrLn, stderr)++import Network.Http.Client (Hostname, Port)++localHost = "localhost" :: Hostname+localPort = 56981 :: Port++main :: IO ()+main = go++{-+ Binding the port to the IPv4 localhost appears to settle the problem+ of localhost resolving ambigiously. If that doesn't work, we can+ comment out the setBind and the resultant 0.0.0.0 does seem to work.+-}+go :: IO ()+go = httpServe c site+ where+ c = setAccessLog ConfigNoLog $+ setErrorLog ConfigNoLog $+ setHostname localHost $+ setBind localHost $+ setPort (fromIntegral localPort) $+ setVerbose False emptyConfig+++runMockServer :: IO ()+runMockServer = do+ _ <- forkIO go+ threadDelay 2000000+ return ()++--+-- Top level URL routing logic.+--++site :: Snap ()+site = catch+ (routeRequests)+ (\e -> serveError "Splat\n" e)++routeRequests :: Snap ()+routeRequests =+ route+ [("resource/:id", serveResource),+ ("static/:id", method GET serveStatic),+ ("time", serveTime),+ ("", ifTop handleAsText),+ ("bounce", serveRedirect),+ ("local", serveLocalRedirect),+ ("loop", serveRedirectEndlessly),+ ("empty", serveWithoutContent),+ ("postbox", method POST handlePostMethod),+ ("size", handleSizeRequest),+ ("api", handleRestfulRequest),+ ("cookies", serveRepeatedResponseHeaders)]+ <|> serveNotFound+++serveResource :: Snap ()+serveResource = do+ r <- getRequest++ let m = rqMethod r+ case m of+ GET -> handleGetMethod+ PUT -> handlePutWithExpectation+ _ -> serveMethodNotAllowed+++serveStatic :: Snap ()+serveStatic = do+ im' <- getParam "id"++ let i' = fromMaybe "" im'+ let f' = S.concat ["tests/", i']+ let f = S.unpack f'++ l <- liftIO $ getSize $ decodeString f++ let t = fileType defaultMimeTypes f+ modifyResponse $ setContentType t+ modifyResponse $ setContentLength $ fromIntegral l+ b' <- liftIO $ S.readFile f+ writeBS b'+++serveTime :: Snap ()+serveTime = do+ writeBS "Sun 30 Dec 12, 05:39:56.746Z\n"+++--+-- Dispatch normal GET requests based on MIME type.+--++handleGetMethod :: Snap ()+handleGetMethod = do+ r <- getRequest+ let mime0 = getHeader "Accept" r++ case mime0 of+ Just "text/html" -> handleAsBrowser+ _ -> handleAsText+++handleAsBrowser :: Snap ()+handleAsBrowser = do+ modifyResponse $ setResponseStatus 200 "OK"+ modifyResponse $ setContentType "text/html; charset=UTF-8"+ modifyResponse $ setHeader "Cache-Control" "max-age=1"+ sendFile "tests/hello.html"+++handleAsText :: Snap ()+handleAsText = do+ modifyResponse $ setContentType "text/plain"+ writeBS "Sounds good to me\n"+++handleRestfulRequest :: Snap ()+handleRestfulRequest = do+ modifyResponse $ setResponseStatus 200 "OK"+ modifyResponse $ setContentType "application/json"++ sendFile "tests/data-eu-gdp.json"+++serveRedirect :: Snap ()+serveRedirect = do+ modifyResponse $ setResponseStatus 307 "Temporary Redirect"+ modifyResponse $ setHeader "Cache-Control" "no-cache"+ modifyResponse $ setHeader "Location" r'+ where+ r' = S.concat ["http://", localHost, ":", S.pack $ show $ localPort, "/time"]++serveLocalRedirect :: Snap ()+serveLocalRedirect = do+ modifyResponse $ setResponseStatus 307 "Temporary Redirect"+ modifyResponse $ setHeader "Cache-Control" "no-cache"+ modifyResponse $ setHeader "Location" r'+ where+ r' = S.pack "/time"++serveRedirectEndlessly :: Snap ()+serveRedirectEndlessly = do+ modifyResponse $ setResponseStatus 307 "Temporary Redirect"+ modifyResponse $ setHeader "Cache-Control" "no-cache"+ modifyResponse $ setHeader "Location" r'+ where+ r' = S.concat ["http://", localHost, ":", S.pack $ show $ localPort, "/loop"]++{-+ Attempt to test the bug with 204 No Content not closing in absence of a+ Content-Length header, however Snap automatically adds one, it seems. So,+ after the fact, this is unused and the case is tested in+ TestServer.testDevoidOfContent.+-}++serveWithoutContent :: Snap ()+serveWithoutContent = do+ modifyResponse $ setResponseStatus 204 "No Content"+ modifyResponse $ setHeader "Cache-Control" "no-cache"+++serveRepeatedResponseHeaders :: Snap ()+serveRepeatedResponseHeaders = do+ modifyResponse $ addHeader "Set-Cookie" "stone=diamond"+ modifyResponse $ addHeader "Set-Cookie" "metal=tungsten"++handlePostMethod :: Snap ()+handlePostMethod = do+ setTimeout 5+ modifyResponse $ setResponseStatus 201 "Created"+ modifyResponse $ setHeader "Cache-Control" "no-cache"+ modifyResponse $ setHeader "Location" "http://server.example.com/something/788"+ modifyResponse $ setContentType "text/plain"++ b' <- readRequestBody 1024+ writeLBS b'+++handlePutWithExpectation :: Snap ()+handlePutWithExpectation = do+ setTimeout 5+ modifyResponse $ setResponseStatus 201 "Created"+ modifyResponse $ setHeader "Cache-Control" "no-cache"+ modifyResponse $ setContentType "text/plain"++ b' <- readRequestBody 1024+ writeLBS b'+++handleSizeRequest :: Snap ()+handleSizeRequest = do+ r <- getRequest+ let mm = getHeader "Content-Type" r++ t <- case mm of+ Just m -> return m+ _ -> do+ serveUnsupported+ return ""++ modifyResponse $ setResponseStatus 200 "OK"+ modifyResponse $ setContentType t++ b' <- readRequestBody 65536+ writeBS $ S.pack $ show $ L.length b'+++updateResource :: Snap ()+updateResource = do+ bs' <- readRequestBody 4096+ let b' = fromLazy bs'++ im' <- getParam "id"+ let i' = fromMaybe "0" im'++ -- TODO something++ modifyResponse $ setResponseStatus 204 "Updated" -- "No Content"+ modifyResponse $ setHeader "Cache-Control" "no-cache"+ modifyResponse $ setContentLength 0+ return ()+ where+ fromLazy ls' = S.concat $ L.toChunks ls'+++serveNotFound :: Snap a+serveNotFound = do+ modifyResponse $ setResponseStatus 404 "Not Found"+ modifyResponse $ setHeader "Content-Type" "text/html"++ writeBS "404 Not Found"++ r <- getResponse+ finishWith r+++serveBadRequest :: Snap ()+serveBadRequest = do+ modifyResponse $ setResponseStatus 400 "Bad Request"+ writeBS "400 Bad Request\n"+++serveMethodNotAllowed :: Snap ()+serveMethodNotAllowed = do+ modifyResponse $ setResponseStatus 405 "Method Not Allowed"+ modifyResponse $ setHeader "Allow" "GET, POST, PUT"++ writeBS "405 Method Not Allowed\n"+ r <- getResponse+ finishWith r+++serveUnsupported :: Snap ()+serveUnsupported = do+ modifyResponse $ setResponseStatus 415 "Unsupported Media Type"+ writeBS "415 Unsupported Media Type\n"+ r <- getResponse+ finishWith r+++--+-- The exception will be dumped to the server's stdout, while the supplied+-- message will be sent out with the response (ideally only for debugging+-- purposes, but easier than looking in log/error.log for details).+--++serveError :: ByteString -> SomeException -> Snap ()+serveError x' e = do+ debug msg+ modifyResponse $ setResponseStatus 500 "Internal Server Error"+ writeBS x'+ r <- getResponse+ finishWith r+ where+ msg = show (e :: SomeException)+++debug :: String -> Snap ()+debug cs = do+ liftIO $ do+ hPutStrLn stderr ""+ hPutStrLn stderr cs+ hFlush stderr++
+ tests/TestSuite.hs view
@@ -0,0 +1,723 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2014 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 a BSD licence.+--++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-unused-imports #-}++module TestSuite where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (fromByteString,+ toByteString)+import qualified Blaze.ByteString.Builder.Char8 as Builder (fromChar,+ fromString)+import Control.Applicative+import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (Exception, bracket, handleJust)+import Control.Monad (forM_, guard)+import Data.Aeson (FromJSON, ToJSON, Value (..), json, object, parseJSON,+ toJSON, (.:), (.=))+import Data.Aeson.Encode.Pretty+import Data.Bits+import qualified Data.HashMap.Strict as Map+import Data.Maybe (fromJust)+import Data.Monoid+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.Generics hiding (Selector)+import Network.Socket (SockAddr (..))+import Network.URI (parseURI)+import System.Timeout (timeout)+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Expectations (Selector, anyException, shouldThrow)+import Test.HUnit++import Debug.Trace++--+-- 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 qualified Data.ByteString.Lazy as L+import Debug.Trace+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Streams+import qualified System.IO.Streams.Debug as Streams++--+-- what we're actually testing+--++import MockServer (localPort)+import Network.Http.Client+import Network.Http.Connection (Connection (..))+import Network.Http.Inconvenience (HttpClientError (..),+ TooManyRedirects (..), splitURI)+import Network.Http.Internal (Request (..), Response (..),+ composeRequestBytes, lookupHeader)+import Network.Http.ResponseParser (readDecimal, readResponseHeader)+++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+ testPaddedContentLength+-- testTrailingWhitespace+ testChunkedEncoding+ testContentLength+ testDevoidOfContent+ testCompressedResponse+ testRepeatedResponseHeaders++ describe "Expectation handling" $ do+ testExpectationContinue++ describe "Convenience API" $ do+ testPutChunks+ testPostChunks+ testPostWithForm+ testGetRedirects+ testSplitURI+ testGetLocalRedirects+ testGetFormatsRequest+ testExcessiveRedirects+ testGeneralHandler+ testEstablishConnection+ -- Andreas Abel, 2022-03-30: These test do not build:+ -- testParsingJson1+ -- testParsingJson2++ describe "Corner cases in protocol compliance" $ do+ testSendBodyFor PUT+ testSendBodyFor DELETE+ testSendBodyFor PATCH++testRequestTermination =+ it "terminates with a blank line" $ do+ c <- openConnection "localhost" localPort+ let q = buildRequest1 $ 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 = do+ it "has a properly formatted request line" $ bracket+ (fakeConnection)+ (return)+ (\c -> do+ let q = buildRequest1 $ 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')++ it "handles empty request path" $ bracket+ (fakeConnection)+ (return)+ (\c -> do+ let q = buildRequest1 $ do+ http GET ""++ let e' = Builder.toByteString $ composeRequestBytes q (cHost c)+ let l' = S.takeWhile (/= '\r') e'++ assertEqual "Invalid HTTP request line" "GET / HTTP/1.1" l')+++fakeConnection :: IO Connection+fakeConnection = do+ i <- Streams.nullInput+ o <- Streams.nullOutput+ let c = makeConnection "www.example.com" (return ()) o i+ return c+++testAcceptHeaderFormat =+ it "properly formats Accept header" $ do+ let q = buildRequest1 $ 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+ let q = buildRequest1 $ 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+ let q1 = buildRequest1 $ do+ http GET "/hello.txt"++ let h1 = qHost q1+ assertEqual "Incorrect Host header" Nothing h1++ let q2 = buildRequest1 $ do+ http GET "/hello.txt"+ setHostname "other.example.com" 80++ let h2 = qHost q2+ assertEqual "Incorrect Host header" (Just "other.example.com") h2++ let q3 = buildRequest1 $ 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 ()++testPaddedContentLength =+ it "handles padded Content-Length" $ do+ p <- Streams.withFileAsInput "tests/example4.txt" (\i -> readResponseHeader i)++ let (Just len) = pContentLength p+ assertEqual "Should have trimmed in decimal conversion" 86 len++{-+ Presently inactive+-}+testTrailingWhitespace =+ it "where headers have trailing whitespace" $ do+ p <- Streams.withFileAsInput "tests/example4.txt" (\i -> readResponseHeader i)++ let (Just value) = getHeader p "Content-Length"+ assertEqual "Should have trimmed field value" "86" value++testChunkedEncoding =+ it "recognizes chunked transfer encoding and decodes" $ do+ c <- openConnection "localhost" localPort++ let q = buildRequest1 $ 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 = do+ it "recognzies fixed length message" $ do+ c <- openConnection "localhost" localPort++ let q = buildRequest1 $ 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)++ it "doesn't choke if server neglects Content-Length" $ do+ p <- Streams.withFileAsInput "tests/example3.txt" (\i -> readResponseHeader i)++ assertEqual "Incorrect parse of response" 200 (getStatusCode p)+ assertEqual "Incorrect parse of response" Nothing (getHeader p "Content-Length")+ assertEqual "Should not have pContentLength" Nothing (pContentLength p)+ return ()++ it "reads body without Content-Length or Transfer-Encoding" $ do+ c <- fakeConnectionHttp10+ let q = buildRequest1 $ do+ http GET "/fake"+ sendRequest c q emptyBody+ receiveResponse c (\_ i1 -> do+ (i2, getCount) <- Streams.countInput i1+ o <- Streams.nullOutput+ Streams.connect i2 o++ end <- Streams.atEOF i2+ assertBool "Expected end of stream" end++ len <- getCount+ assertEqual "Incorrect number of bytes read" 4611 len)++ return ()+++fakeConnectionHttp10 :: IO Connection+fakeConnectionHttp10 = do+ x' <- S.readFile "tests/example3.txt"+ i <- Streams.fromByteString x'++ o <- Streams.nullOutput+ let c = makeConnection "bad.example.com" (return ()) o i+ return c+++{-+ Corner case where servers responding 204 No Content are not required to+ transmit a Content-Length header; Snap *does* send one, so we can't test it+ in the MockServer, so fake it with example5.txt+-}++testDevoidOfContent = do+ it "handles 204 No Content response without Content-Length"+ $ timeout_ 2 $ do+ (c, mv) <- fakeConnectionNoContent+ let q = buildRequest1 $ do+ http GET "/fake"+ sendRequest c q emptyBody+ receiveResponse c (\_ i1 -> do+ (i2, getCount) <- Streams.countInput i1+ o <- Streams.nullOutput+ Streams.connect i2 o++ end <- Streams.atEOF i2+ assertBool "Expected end of stream" end++ len <- getCount+ assertEqual "Incorrect number of bytes read" 0 len)+ putMVar mv ()+ return ()+ where+ secs :: Int+ secs = 10 ^ (6 :: Int)++ timeout_ :: Int -> IO a -> IO a+ timeout_ t m = timeout (t * secs) m >>= maybe (error "timeout") return+++fakeConnectionNoContent :: IO (Connection, MVar ())+fakeConnectionNoContent = do+ x' <- S.readFile "tests/example5.txt"+ i1 <- Streams.fromByteString x'+ mv <- newEmptyMVar+ i2 <- Streams.makeInputStream $ blockOn mv+ i3 <- Streams.concatInputStreams [i1, i2]++ o <- Streams.nullOutput+ let c = makeConnection "worse.example.com" (return ()) o i3+ return (c, mv)+ where+ blockOn :: MVar () -> IO (Maybe ByteString)+ blockOn mv = takeMVar mv >> return Nothing+++{-+ 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++ let q = buildRequest1 $ 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++ let q = buildRequest1 $ do+ http PUT "/resource/x149"+ setExpectContinue++ sendRequest c q (\o -> do+ Streams.write (Just (Builder.fromString "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++testSendBodyFor meth =+ it ("Sends a request body for " ++ show meth) $ do+ c <- openConnection "localhost" localPort++ let q = buildRequest1 $ do+ http meth "/size"+ setContentType "text/plain"+ setTransferEncoding++ sendRequest c q (\o -> do+ Streams.write (Just (Builder.fromString "a request")) o)++ receiveResponse c (\p i -> do+ assertEqual "Incorrect status code" 200 (getStatusCode p)+ (Just b') <- Streams.read i++ let size = readDecimal b' :: Int+ assertEqual "Should have received a request body" 9 size)++ closeConnection c++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")+ , ("country", Text.encodeUtf8 $ Text.pack "Nørway")+ ] handler+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler p i = do+ let code = getStatusCode p+ assertEqual "Expected 201" 201 code++ b' <- Streams.readExactly 48 i++ end <- Streams.atEOF i+ assertBool "Expected end of stream" end++ assertEqual "Incorrect URL encoding"+ "name=Kermit&role=St%26gehand&country=N%c3%b8rway"+ 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+++testGetLocalRedirects =+ it "GET internal handler follows local redirect on 307" $ do+ let url = S.concat ["http://", localhost, "/local"]++ 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+++testSplitURI =+ it "check splitURI for local redirects" $ do+ let a1 = "http://asdf@ya.ru:8000/hello/?asd=asd&abc=2"+ r1 = S.pack "/hello/?asd=asd&abc=2"+ assertEqual "Incorrect split uri 1" (S.pack a1) (splitURI (fromJust $ parseURI a1) r1)++ let a2 = "http://asdf@ya.ru:8000/again/?asd=asd&abc=2"+ r2 = S.pack "/again/?asd=asd&abc=2"+ assertEqual "Incorrect split uri 2" (S.pack a2) (splitURI (fromJust $ parseURI a2) r2)++ let a3 = "http://ya.ru:8000/here/?asd=asd&abc=2"+ r3 = S.pack "/here/?asd=asd&abc=2"+ assertEqual "Incorrect split uri 3" (S.pack a3) (splitURI (fromJust $ parseURI a3) r3)++ let a4 = "http://ya.ru/?asd=asd&abc=2#papa"+ r4 = S.pack "/?asd=asd&abc=2#papa"+ assertEqual "Incorrect split uri 4" (S.pack a4) (splitURI (fromJust $ parseURI a4) r4)++ let a5 = "http://ya.ru/?asd=asd&abc=2#papa"+ r5 = S.pack "http://google.ru/"+ assertEqual "Incorrect split uri 5" r5 (splitURI (fromJust $ parseURI a5) r5)+++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+ let q = buildRequest1 $ 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++-- Andreas Abel, 2022-03-30:+-- No 'jsonHandler' defined, unfortunately, so no testing it.++-- testParsingJson1 =+-- it "GET with JSON handler behaves" $ do+-- let url = S.concat ["http://", localhost, "/static/data-eu-gdp.json"]++-- x <- get url jsonHandler+-- let (Object o) = x+-- let (Just v) = Map.lookup "label" o+-- let (String t) = v++-- assertEqual "Incorrect response" "Europe (EU27)" t++-- testParsingJson2 =+-- it "GET with JSON handler parses using Aeson" $ do+-- let url = S.concat ["http://", localhost, "/static/data-jp-gdp.json"]++-- x <- get url jsonHandler :: IO GrossDomesticProduct++-- assertEqual "Incorrect response" "Japan" (gLabel x)+-- assertEqual "Data not parsed as expected" 2008 (fst $ last $ gData x)+-- -- L.putStr $ encodePretty x+++{-+ Go to the trouble to create a Haskell data type representing the JSON feed+ we're getting from the sample data files. The Generic trick doesn't work+ because data is a reserved word, of course.+-}++data GrossDomesticProduct = GrossDomesticProduct {+ gLabel :: Text,+ gData :: [(Int, Double)]+} deriving (Show, Generic)++instance FromJSON GrossDomesticProduct where+ parseJSON (Object o) = GrossDomesticProduct <$>+ o .: "label" <*>+ o .: "data"+ parseJSON _ = undefined+++instance ToJSON GrossDomesticProduct where+ toJSON (GrossDomesticProduct l d) = object+ ["label" .= l,+ "data" .= d]
+ tests/check.hs view
@@ -0,0 +1,25 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2014 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 a BSD licence.+--++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-unused-imports #-}++module Main where++import OpenSSL (withOpenSSL)+import Test.Hspec (hspec)++import MockServer (runMockServer)+import TestSuite (suite)++main :: IO ()+main = withOpenSSL $ do+ runMockServer+ hspec suite
+ tests/example1.txt view
@@ -0,0 +1,6 @@+HTTP/1.1 200 OK +Content-Type: text/plain +Content-Length: 10 + +Hi there.+
+ tests/example2.txt view
@@ -0,0 +1,17 @@+HTTP/1.1 200 OK +Content-Type: text/html; charset=UTF-8 +Server: Apache/2.2.22 +Expires: Fri, 04 Jan 2013 06:48:57 GMT +Date: Fri, 04 Jan 2013 06:48:56 GMT +Content-Length: 133 +Cache-Control: max-age=1 + +<html>+<head>+<title>Hello</title>+</head>+<body>+<h1>Hello!</h1>+<p>Hello world. <span class="FIXME">□</span></p>+</body>+</html>
+ tests/example3.txt view
binary file changed (absent → 4675 bytes)
+ tests/example4.txt view
@@ -0,0 +1,6 @@+HTTP/1.1 200 OK +Content-Type: text/plain +Content-Length: 86 + +This is an HTTP response with a header that has trailing whitespace. Bad+server, Bad!
+ tests/example5.txt view
@@ -0,0 +1,3 @@+HTTP/1.1 204 No Content +Server: Ye Plain Olde Text File +
+ tests/hello.html view
@@ -0,0 +1,9 @@+<html>+<head>+<title>Hello</title>+</head>+<body>+<h1>Hello!</h1>+<p>Hello world.</p>+</body>+</html>
+ tests/statler.jpg view
binary file changed (absent → 4611 bytes)