http-streams (empty) → 0.3.1.0
raw patch · 10 files changed
+2669/−0 lines, 10 filesdep +HUnitdep +HsOpenSSLdep +MonadCatchIO-transformersbuild-type:Customsetup-changed
Dependencies added: HUnit, HsOpenSSL, MonadCatchIO-transformers, attoparsec, base, base64-bytestring, blaze-builder, bytestring, case-insensitive, hspec, io-streams, mtl, network, openssl-streams, snap, snap-core, snap-server, system-fileio, system-filepath, text, unordered-containers
Files
- LICENCE +32/−0
- Setup.hs +48/−0
- http-streams.cabal +113/−0
- src/Network/Http/Client.hs +169/−0
- src/Network/Http/Connection.hs +517/−0
- src/Network/Http/Inconvenience.hs +497/−0
- src/Network/Http/RequestBuilder.hs +281/−0
- src/Network/Http/ResponseParser.hs +229/−0
- src/Network/Http/Types.hs +336/−0
- tests/Check.hs +447/−0
+ LICENCE view
@@ -0,0 +1,32 @@+An HTTP client for use with io-streams++Copyright © 2012 Operational Dynamics Consulting, Pty Ltd+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.+ + 3. Neither the name of the project nor the names of its contributors+ may be used to endorse or promote products derived from this + software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,48 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 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.+--++import Data.Char (toUpper)+import Distribution.PackageDescription (PackageDescription)+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)+import Distribution.Simple.Setup (ConfigFlags)+import Distribution.System (OS (..), buildOS)+import System.IO (IOMode (..), hPutStrLn, withFile)++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks {+ postConf = configure+ }++{-+ Simple detection of which operating system we're building on;+ there's no need to link the Cabal logic into our library, so+ we'll keep using CPP in Network.Http.Inconvenience.+-}++configure :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+configure _ _ _ _ = do++ withFile "config.h" WriteMode (\h -> do+ hPutStrLn h ("#define " ++ s))++ return ()++ where+ o = buildOS++ s = case o of+ Linux -> "__LINUX__"+ OSX -> "__MACOSX__"+ Windows -> "__WINDOWS__"+ _ -> "__" ++ up o ++ "__"++ up x = map toUpper (show x)
+ http-streams.cabal view
@@ -0,0 +1,113 @@+cabal-version: >= 1.10+name: http-streams+version: 0.3.1.0+synopsis: An HTTP client using io-streams+description:+ /Overview/+ .+ An HTTP client, using the Snap Framework's 'io-streams' library to+ hande the streaming IO. The API is optimized for ease of use for the+ rather common case of code needing to query web services and deal with+ the result.+ .+ The library is exported in a single module; see "Network.Http.Client"+ for full documentation.++license: BSD3+license-file: LICENCE+author: Andrew Cowie <andrew@operationaldynamics.com>+maintainer: Andrew Cowie <andrew@operationaldynamics.com>+copyright: © 2012-2013 Operational Dynamics Consulting, Pty Ltd and Others+category: Web+tested-with: GHC == 7.4+stability: experimental+homepage: http://research.operationaldynamics.com/projects/http-streams/+bug-reports: https://github.com/afcowie/http-streams/issues++build-type: Custom++library+ default-language: Haskell2010++ build-depends: attoparsec,+ base >= 4 && <5,+ base64-bytestring,+ blaze-builder,+ bytestring,+ case-insensitive,+ io-streams >= 1.0 && <1.1,+ HsOpenSSL,+ openssl-streams >= 1.0 && <1.1,+ mtl,+ network,+ text,+ unordered-containers++ hs-source-dirs: src+ exposed-modules: Network.Http.Client+ other-modules: Network.Http.Types,+ Network.Http.Connection,+ Network.Http.RequestBuilder,+ Network.Http.ResponseParser,+ Network.Http.Inconvenience++ ghc-options: -O2+ -Wall+ -Wwarn+ -fwarn-tabs+ -funbox-strict-fields+ -fno-warn-missing-signatures+ -fno-warn-unused-binds+ -fno-warn-unused-do-bind++ include-dirs: .++ ghc-prof-options: -prof -fprof-auto-top+++test-suite check+ type: exitcode-stdio-1.0++ default-language: Haskell2010++ build-depends:+ HUnit,+ HsOpenSSL,+ MonadCatchIO-transformers,+ attoparsec,+ base,+ blaze-builder,+ bytestring,+ case-insensitive,+ hspec,+ io-streams,+ mtl,+ network,+ openssl-streams >= 1.0 && <1.1,+ snap >= 0.9 && < 1.0,+ snap-core >= 0.9 && < 1.0,+ snap-server >= 0.9 && < 1.0,+ system-fileio >= 0.3.10 && < 0.4,+ system-filepath >= 0.4.1 && < 0.5,+ text,+ unordered-containers++ hs-source-dirs: src,tests+ main-is: Check.hs++ ghc-options: -O2+ -threaded+ -Wall+ -Wwarn+ -fwarn-tabs+ -funbox-strict-fields+ -fno-warn-missing-signatures+ -fno-warn-unused-binds+ -fno-warn-unused-do-bind++source-repository head+ type: git+ location: git://github.com/afcowie/http-streams.git+++-- vim: set tabstop=21 expandtab:
+ src/Network/Http/Client.hs view
@@ -0,0 +1,169 @@+--+-- 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.+--++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-orphans #-}++{-|+Maintainer: Andrew Cowie+Stability: Experimental++/Overview/++A simple HTTP client library, using the Snap Framework's @io-streams@+library to handle the streaming I\/O. The @http-streams@ API is designed+for ease of use when querying web services and dealing with the result.++Given:++> import System.IO.Streams (InputStream, OutputStream, stdout)+> import qualified System.IO.Streams as Streams+> import qualified Data.ByteString as S++and this library:++> import Network.Http.Client++the underlying API is straight-forward. In particular, constructing the+'Request' to send is quick and to the point:++@+\ main :: IO ()+\ main = do+\ c <- 'openConnection' \"www.example.com\" 80++\ q <- 'buildRequest' c $ do+\ 'http' GET \"\/\"+\ 'setAccept' \"text/html\"++\ 'sendRequest' c q 'emptyBody'++\ `receiveResponse` c (\\p i -> do+\ x <- Streams.read b+\ S.putStr $ fromMaybe \"\" x)++\ 'closeConnection' c+@++which would print the first chunk of the response back from the+server. Obviously in real usage you'll do something more interesting+with the 'Response' in the handler function, and consume the entire+response body from the InputStream ByteString.++Because this is all happening in 'IO' (the defining feature of+@io-streams@!), you can ensure resource cleanup on normal or+abnormal termination by using @Control.Exception@'s standard+'Control.Exception.bracket' function; see 'closeConnection' for an+example. For the common case we have a utility function which+wraps @bracket@ for you:++@+\ foo :: IO ByteString+\ foo = 'withConnection' ('openConnection' \"www.example.com\" 80) doStuff++\ doStuff :: Connection -> IO ByteString+@++There are also a set of convenience APIs that do just that, along with+the tedious bits like parsing URLs. For example, to do an HTTP GET and+stream the response body to stdout, you can simply do:++@+\ 'get' \"http:\/\/www.example.com\/file.txt\" (\\p i -> Streams.connect i stdout)+@++which on the one hand is \"easy\" while on the other exposes the the+'Response' and InputStream for you to read from. Of course, messing+around with URLs is all a bit inefficient, so if you already have e.g.+hostname and path, or if you need more control over the request being+created, then the underlying @http-streams@ API is simple enough to use+directly.+-}++module Network.Http.Client (+ -- * Connecting to server+ Hostname,+ Port,+ Connection,+ openConnection,++ -- * Building Requests+ -- | You setup a request using the RequestBuilder monad, and+ -- get the resultant Request object by running 'buildRequest'. The+ -- first call doesn't have to be to 'http', but it looks better when+ -- it is, don't you think?+ Method(..),+ RequestBuilder,+ buildRequest,+ http,+ setHostname,+ setAccept,+ setAccept',+ setAuthorizationBasic,+ ContentType,+ setContentType,+ setContentLength,+ setExpectContinue,+ setHeader,++ -- * Sending HTTP request+ Request,+ Response,+ Headers,+ getHostname,+ sendRequest,+ emptyBody,+ fileBody,+ inputStreamBody,+ encodedFormBody,++ -- * Processing HTTP response+ receiveResponse,+ StatusCode,+ getStatusCode,+ getStatusMessage,+ getHeader,+ debugHandler,+ concatHandler,+ concatHandler',++ -- * Resource cleanup+ closeConnection,+ withConnection,++ -- * Convenience APIs+ -- | Some simple functions for making requests with useful defaults.+ -- There's no @head@ function for the usual reason of needing to+ -- avoid collision with @Prelude@.+ --+ -- These convenience functions work with @http@ and @https@, but+ -- note that if you retrieve an @https@ URL, you /must/ wrap your+ -- @main@ function with 'OpenSSL.withOpenSSL' to initialize the+ -- native openssl library code.+ --+ URL,+ get,+ post,+ postForm,+ put,++ -- * Secure connections+ openConnectionSSL,+ baselineContextSSL,+ modifyContextSSL,+ establishConnection+) where++import Network.Http.Connection+import Network.Http.Inconvenience+import Network.Http.RequestBuilder+import Network.Http.Types+
+ src/Network/Http/Connection.hs view
@@ -0,0 +1,517 @@+--+-- 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.+--++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Http.Connection (+ Hostname,+ Port,+ Connection(..),+ -- constructors only for testing+ makeConnection,+ withConnection,+ openConnection,+ openConnectionSSL,+ closeConnection,+ sendRequest,+ receiveResponse,+ emptyBody,+ fileBody,+ inputStreamBody,+ debugHandler,+ concatHandler+) where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (flush, fromByteString,+ toByteString)+import qualified Blaze.ByteString.Builder.HTTP as Builder (chunkedTransferEncoding, chunkedTransferTerminator)+import Control.Exception (bracket)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.Monoid (mappend, mempty)+import Network.Socket+import OpenSSL.Session (SSL, SSLContext)+import qualified OpenSSL.Session as SSL+import System.IO.Streams (InputStream, OutputStream, stdout)+import qualified System.IO.Streams as Streams+import qualified System.IO.Streams.SSL as Streams hiding (connect)++import Network.Http.ResponseParser+import Network.Http.Types++{-+ This is a String because that's what the uri package works in. There+ was a fairly detailed disucssion on haskell-cafe about this, with+ the conclusion that URLs are composed of characters, not octets.+-}++type Hostname = String++type Port = Int++-- | A connection to a web server.+--+data Connection+ = Connection {+ cHost :: ByteString,+ -- ^ will be used as the Host: header in the HTTP request.+ cClose :: IO (),+ -- ^ called when the connection should be closed.+ cOut :: OutputStream ByteString,+ cIn :: InputStream ByteString+ }++instance Show Connection where+ show c = {-# SCC "Connection.show" #-}+ concat+ ["Connection {",+ "cHost = \"",+ S.unpack $ cHost c,+ "\"}"]+++--+-- | Creates a raw Connection object from the given parts.+--+makeConnection+ :: ByteString+ -- ^ will be used as the Host: header in the HTTP request.+ -> IO ()+ -- ^ called when the connection is terminated.+ -> OutputStream ByteString+ -- ^ write end of the HTTP client connection.+ -> InputStream ByteString+ -- ^ read end of the client connection.+ -> IO Connection+makeConnection h c o i =+ return $! Connection h c o i+++--+-- | Given an @IO@ action producing a 'Connection', and a computation+-- that needs one, runs the computation, cleaning up the+-- @Connection@ afterwards.+--+-- > x <- withConnection (openConnection "s3.example.com" 80) $ (\c -> do+-- > q <- buildRequest c $ do+-- > http GET "/bucket42/object/149"+-- > sendRequest c q emptyBody+-- > ...+-- > return "blah")+--+-- which can make the code making an HTTP request a lot more+-- straight-forward.+--+-- Wraps @Control.Exception@'s 'Control.Exception.bracket'.+--+withConnection :: IO Connection -> (Connection -> IO γ) -> IO γ+withConnection mkC =+ bracket mkC closeConnection+++--+-- | In order to make a request you first establish the TCP+-- connection to the server over which to send it.+--+-- Ordinarily you would supply the host part of the URL here and it will+-- be used as the value of the HTTP 1.1 @Host:@ field. However, you can+-- specify any server name or IP addresss and set the @Host:@ value+-- later with 'Network.Http.Client.setHostname' when building the+-- request.+--+-- Usage is as follows:+--+-- > c <- openConnection "localhost" 80+-- > ...+-- > closeConnection c+--+-- More likely, you'll use 'withConnection' to wrap the call in order+-- to ensure finalization.+--+-- HTTP pipelining is supported; you can reuse the connection to a+-- web server, but it's up to you to ensure you match the number of+-- requests sent to the number of responses read, and to process those+-- responses in order. This is all assuming that the /server/ supports+-- pipelining; be warned that not all do. Web browsers go to+-- extraordinary lengths to probe this; you probably only want to do+-- pipelining under controlled conditions. Otherwise just open a new+-- connection for subsequent requests.+--+openConnection :: Hostname -> Port -> IO Connection+openConnection h p = do+ is <- getAddrInfo (Just hints) (Just h) (Just $ show p)+ let addr = head is+ let a = addrAddress addr+ s <- socket (addrFamily addr) Stream defaultProtocol++ connect s a+ (i,o) <- Streams.socketToStreams s+ return Connection {+ cHost = h',+ cClose = close s,+ cOut = o,+ 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 ]++--+-- | Open a secure connection to a web server.+--+-- You need to wrap this (and subsequent code using this connection)+-- within a call to 'OpenSSL.withOpenSSL':+--+-- > import OpenSSL (withOpenSSL)+-- >+-- > main :: IO ()+-- > main = withOpenSSL $ do+-- > ctx <- baselineContextSSL+-- > c <- openConnectionSSL ctx "api.github.com" 443+-- > ...+-- > closeConnection c+--+-- If you want to tune the parameters used in making SSL connections,+-- manually specify certificates, etc, then setup your own context:+--+-- > import OpenSSL.Session (SSLContext)+-- > import qualified OpenSSL.Session as SSL+-- >+-- > ...+-- > ctx <- SSL.context+-- > ...+--+-- See "OpenSSL.Session".+--+-- Crypto is as provided by the system @openssl@ library, as wrapped+-- by the @HsOpenSSL@ package and @openssl-streams@.+--+openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection+openConnectionSSL ctx h p = do+ s <- socket AF_INET Stream defaultProtocol++ is <- getAddrInfo Nothing (Just h) (Just $ show p)++ let a = addrAddress $ head is+ connect s a++ ssl <- SSL.connection ctx s+ SSL.connect ssl++ (i,o) <- Streams.sslToStreams ssl+ return Connection {+ cHost = h',+ cClose = closeSSL s ssl,+ cOut = o,+ cIn = i+ }+ where+ h' :: ByteString+ h' = if p == 443+ then S.pack h+ else S.concat [ S.pack h, ":", S.pack $ show p ]++closeSSL :: Socket -> SSL -> IO ()+closeSSL s ssl = do+ SSL.shutdown ssl SSL.Unidirectional+ close s++--+-- | Having composed a 'Request' object with the headers and metadata for+-- this connection, you can now send the request to the server, along+-- with the entity body, if there is one. For the rather common case of+-- HTTP requests like 'GET' that don't send data, use 'emptyBody' as the+-- output stream:+--+-- > sendRequest c q emptyBody+--+-- For 'PUT' and 'POST' requests, you can use 'fileBody' or+-- 'inputStreamBody' to send content to the server, or you can work with+-- the @io-streams@ API directly:+--+-- > sendRequest c q (\o ->+-- > Streams.write (Just "Hello World\n") o)+--+{-+ I would like to enforce the constraints on the Empty and Static+ cases shown here, but those functions take OutputStream ByteString,+ and we are of course working in OutputStream Builder by that point.+-}+sendRequest :: Connection -> Request -> (OutputStream Builder -> IO α) -> IO α+sendRequest c q handler = do+ o2 <- Streams.builderStream o1++ -- write the headers++ Streams.write (Just msg) o2++ -- deal with the expect-continue mess++ e2 <- case t of+ Normal -> do+ return e++ Continue -> do+ Streams.write (Just Builder.flush) o2++ p <- readResponseHeader i++ case getStatusCode p of+ 100 -> do+ -- ok to send+ return e+ _ -> do+ -- put the response back+ Streams.unRead (rsp p) i+ return Empty++ -- write the body, if there is one++ x <- case e2 of+ Empty -> do+ o3 <- Streams.nullOutput+ y <- handler o3+ return y++ Chunking -> do+ o3 <- Streams.contramap Builder.chunkedTransferEncoding o2+ y <- handler o3+ Streams.write (Just Builder.chunkedTransferTerminator) o2+ return y++ (Static _) -> do+-- o3 <- Streams.giveBytes (fromIntegral n :: Int64) o2+ y <- handler o2+ return y+++ -- push the stream out by flushing the output buffers++ Streams.write (Just Builder.flush) o2++ return x++ where+ o1 = cOut c+ e = qBody q+ t = qExpect q+ msg = composeRequestBytes q+ i = cIn c+ rsp p = Builder.toByteString $ composeResponseBytes p+++--+-- | Handle the response coming back from the server. This function+-- hands control to a handler function you supply, passing you the+-- 'Response' object with the response headers and an 'InputStream'+-- containing the entity body.+--+-- For example, if you just wanted to print the first chunk of the+-- content from the server:+--+-- > receiveResponse c (\p i -> do+-- > m <- Streams.read b+-- > case m of+-- > Just bytes -> putStr bytes+-- > Nothing -> return ())+--+-- Obviously, you can do more sophisticated things with the+-- 'InputStream', which is the whole point of having an @io-streams@+-- based HTTP client library.+--+-- The final value from the handler function. is the return value of+-- @receiveResponse@, if you need it.+--+{-+ The reponse body coming from the server MUST be fully read, even+ if (especially if) the users's handler doesn't consume it all.+ This is necessary to maintain the HTTP protocol invariants;+ otherwise pipelining would not work. It's not entirely clear+ *which* InputStream is being drained here; the underlying+ InputStream ByteString in Connection remains unconsumed beyond the+ threshold of the current response, which is exactly what we need.+-}+receiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β+receiveResponse c handler = do+ p <- readResponseHeader i+ i' <- readResponseBody p i++ x <- handler p i'++ Streams.skipToEof i'++ return x+ where+ i = cIn c+++--+-- | Use this for the common case of the HTTP methods that only send+-- headers and which have no entity body, i.e. 'GET' requests.+--+emptyBody :: OutputStream Builder -> IO ()+emptyBody _ = return ()+++--+-- | Specify a local file to be sent to the server as the body of the+-- request.+--+-- You use this partially applied:+--+-- > sendRequest c q (fileBody "/etc/passwd")+--+-- Note that the type of @(fileBody \"\/path\/to\/file\")@ is just what+-- you need for the third argument to 'sendRequest', namely+--+-- >>> :t filePath "hello.txt"+-- :: OutputStream Builder -> IO ()+--+{-+ Relies on Streams.withFileAsInput generating (very) large chunks [which it+ does]. A more efficient way to do this would be interesting.+-}+fileBody :: FilePath -> OutputStream Builder -> IO ()+fileBody p o = do+ Streams.withFileAsInput p (\i -> inputStreamBody i o)+++--+-- | Read from a pre-existing 'InputStream' and pipe that through to the+-- connection to the server. This is useful in the general case where+-- something else has handed you stream to read from and you want to use+-- it as the entity body for the request.+--+-- You use this partially applied:+--+-- > i <- getStreamFromVault -- magic, clearly+-- > sendRequest c q (inputStreamBody i)+--+-- This function maps "Builder.fromByteString" over the input, which will+-- be efficient if the ByteString chunks are large.+--+{-+ Note that this has to be 'supply' and not 'connect' as we do not+ want the end of stream to prematurely terminate the chunked encoding+ pipeline!+-}+inputStreamBody :: InputStream ByteString -> OutputStream Builder -> IO ()+inputStreamBody i1 o = do+ i2 <- Streams.map Builder.fromByteString i1+ Streams.supply i2 o+++--+-- | Print the response headers and response body to @stdout@. You can+-- use this with 'receiveResponse' or one of the convenience functions+-- when testing. For example, doing:+--+-- > c <- openConnection "kernel.operationaldynamics.com" 58080+-- >+-- > q <- buildRequest c $ do+-- > http GET "/time"+-- >+-- > sendRequest c q emptyBody+-- >+-- > receiveResponse c debugHandler+--+-- would print out:+--+-- > HTTP/1.1 200 OK+-- > Transfer-Encoding: chunked+-- > Content-Type: text/plain+-- > Vary: Accept-Encoding+-- > Server: Snap/0.9.2.4+-- > Content-Encoding: gzip+-- > Date: Mon, 21 Jan 2013 06:13:37 GMT+-- >+-- > Mon 21 Jan 13, 06:13:37.303Z+--+-- or thereabouts.+--+debugHandler :: Response -> InputStream ByteString -> IO ()+debugHandler p i = do+ putStr $ show p+ Streams.connect i stdout+++--+-- | Sometimes you just want the entire response body as a single blob.+-- This function concatonates all the bytes from the response into a+-- ByteString. If using the main @http-streams@ API, you would use it+-- as follows:+--+-- > ...+-- > x' <- receiveResponse c concatHandler+-- > ...+--+-- The methods in the convenience API all take a function to handle the+-- response; this function is passed directly to the 'receiveResponse'+-- call underlying the request. Thus this utility function can be used+-- for 'get' as well:+--+-- > x' <- get "http://www.example.com/document.txt" concatHandler+--+-- Either way, the usual caveats about allocating a+-- single object from streaming I/O apply: do not use this if you are+-- not absolutely certain that the response body will fit in a+-- reasonable amount of memory.+--+-- Note that this function makes no discrimination based on the+-- response's HTTP status code. You're almost certainly better off+-- writing your own handler function.+--+{-+ I'd welcome a better name for this function.+-}+concatHandler :: Response -> InputStream ByteString -> IO ByteString+concatHandler _ i1 = do+ i2 <- Streams.map Builder.fromByteString i1+ x <- Streams.fold mappend mempty i2+ return $ Builder.toByteString x+++--+-- | Shutdown the connection. You need to call this release the+-- underlying socket file descriptor and related network resources. To+-- do so reliably, use this in conjunction with 'openConnection' in a+-- call to 'Control.Exception.bracket':+--+-- > --+-- > -- Make connection, cleaning up afterward+-- > --+-- >+-- > foo :: IO ByteString+-- > foo = bracket+-- > (openConnection "localhost" 80)+-- > (closeConnection)+-- > (doStuff)+-- >+-- > --+-- > -- Actually use Connection to send Request and receive Response+-- > --+-- >+-- > doStuff :: Connection -> IO ByteString+--+-- or, just use 'withConnection'.+--+-- While returning a ByteString is probably the most common use case,+-- you could conceivably do more processing of the response in 'doStuff'+-- and have it and 'foo' return a different type.+--+closeConnection :: Connection -> IO ()+closeConnection c = cClose c
+ src/Network/Http/Inconvenience.hs view
@@ -0,0 +1,497 @@+--+-- 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.+--++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-orphans #-}++module Network.Http.Inconvenience (+ URL,+ modifyContextSSL,+ establishConnection,+ get,+ post,+ postForm,+ encodedFormBody,+ put,+ baselineContextSSL,+ concatHandler',++ -- for testing+ TooManyRedirects(..),+ HttpClientError(..)+) where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (fromByteString,+ fromWord8, toByteString)+import Control.Exception (Exception, bracket, throw)+import Data.Bits (Bits (..))+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.ByteString.Internal (c2w, w2c)+import Data.Char (intToDigit, isAlphaNum)+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List (intersperse)+import Data.Monoid (Monoid (..), (<>))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Typeable (Typeable)+import GHC.Exts+import GHC.Word (Word8 (..))+import Network.URI (URI (..), URIAuth (..), parseURI)+import OpenSSL.Session (SSLContext)+import qualified OpenSSL.Session as SSL+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Streams+import System.IO.Unsafe (unsafePerformIO)++import Network.Http.Connection+import Network.Http.RequestBuilder+import Network.Http.Types++#include "config.h"++type URL = ByteString++------------------------------------------------------------------------------++--+-- | URL-escapes a string (see+-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)+--+urlEncode :: ByteString -> URL+urlEncode = Builder.toByteString . urlEncodeBuilder+{-# INLINE urlEncode #-}+++--+-- | URL-escapes a string (see+-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.+--+urlEncodeBuilder :: ByteString -> Builder+urlEncodeBuilder = go mempty+ where+ go !b !s = maybe b' esc (S.uncons y)+ where+ (x,y) = S.span (flip HashSet.member urlEncodeTable) s+ b' = b <> Builder.fromByteString x+ esc (c,r) = let b'' = if c == ' '+ then b' <> Builder.fromWord8 (c2w '+')+ else b' <> hexd c+ in go b'' r+++hexd :: Char -> Builder+hexd c0 = Builder.fromWord8 (c2w '%') <> Builder.fromWord8 hi+ <> Builder.fromWord8 low+ where+ !c = c2w c0+ toDigit = c2w . intToDigit+ !low = toDigit $ fromEnum $ c .&. 0xf+ !hi = toDigit $ (c .&. 0xf0) `shiftr` 4++ shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#))+++urlEncodeTable :: HashSet Char+urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0..255]+ where+ f c = isAlphaNum c || elem c "$-.!*'(),"+++------------------------------------------------------------------------------++{-+ The default SSLContext used by the convenience APIs in the http-streams+ library. This is a kludge, unsafe bad yada yada. The technique, however,+ was described on a Haskell Wiki page, so that makes it an officially+ supported kludge. The justification for doing this is a) the functions+ accessing this IORef are themselves all in the IO monad, and b) these+ contortions are necessary to allow the library to be used for http:// URLs+ *without* requiring the developer to do 'withOpenSSL'.+-}+global :: IORef SSLContext+global = unsafePerformIO $ do+ ctx <- baselineContextSSL+ newIORef ctx+{-# NOINLINE global #-}++--+-- | Modify the context being used to configure the SSL tunnel used by+-- the convenience API functions to make @https://@ connections. The+-- default is that setup by 'baselineContextSSL'.+--+modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO ()+modifyContextSSL f = do+ ctx <- readIORef global+ ctx' <- f ctx+ writeIORef global ctx'++--+-- | Given a URL, work out whether it is normal or secure, and then+-- open the connection to the webserver including setting the+-- appropriate default port if one was not specified in the URL. This+-- is what powers the convenience API, but you may find it useful in+-- composing your own similar functions.+--+-- For example (on the assumption that your server behaves when given+-- an absolute URI as the request path), this will open a connection+-- to server @www.example.com@ port @443@ and request @/photo.jpg@:+--+-- > let url = "https://www.example.com/photo.jpg"+-- >+-- > c <- establishConnection url+-- > q <- buildRequest c $ do+-- > http GET url+-- > ...+--+establishConnection :: URL -> IO (Connection)+establishConnection r' = do+ establish u+ where+ u = parseURL r'+{-# INLINE establishConnection #-}++establish :: URI -> IO (Connection)+establish u =+ case scheme of+ "http:" -> do+ openConnection host port+ "https:" -> do+ ctx <- readIORef global+ openConnectionSSL ctx host ports+ _ -> error ("Unknown URI scheme " ++ scheme)+ where+ scheme = uriScheme u++ auth = case uriAuthority u of+ Just x -> x+ Nothing -> URIAuth "" "localhost" ""++ host = uriRegName auth+ port = case uriPort auth of+ "" -> 80+ _ -> read $ tail $ uriPort auth :: Int+ ports = case uriPort auth of+ "" -> 443+ _ -> read $ tail $ uriPort auth :: Int+++--+-- | Creates a basic SSL context. This is the SSL context used if you make an+-- @\"https:\/\/\"@ request using one of the convenience functions. It+-- configures OpenSSL to use the default set of ciphers.+--+-- On Linux systems, this function also configures OpenSSL to verify+-- certificates using the system certificates stored in @\/etc\/ssl\/certs@.+--+-- On other systems, /no certificate validation is performed/ by the+-- generated 'SSLContext' because there is no canonical place to find+-- the set of system certificates. When using this library on a+-- non-Linux system, you are encouraged to install the system+-- certificates somewhere and create your own 'SSLContext'.+--+{-+ We would like to turn certificate verification on for everyone, but+ this has proved contingent on leveraging platform specific mechanisms+ to reach the certificate store. That logic should probably be in+ hsopenssl, but feel free to change this as appropriate for your OS.+-}+baselineContextSSL :: IO SSLContext+baselineContextSSL = do+ ctx <- SSL.context+ SSL.contextSetDefaultCiphers ctx+#if defined __MACOSX__+ SSL.contextSetVerificationMode ctx SSL.VerifyNone+#elif defined __WIN32__+ SSL.contextSetVerificationMode ctx SSL.VerifyNone+#else+ SSL.contextSetCADirectory ctx "/etc/ssl/certs"+ SSL.contextSetVerificationMode ctx $+ SSL.VerifyPeer True True Nothing+#endif+ return ctx+++parseURL :: URL -> URI+parseURL r' =+ case parseURI r of+ Just u -> u+ Nothing -> error ("Can't parse URI " ++ r)+ where+ r = T.unpack $ T.decodeUtf8 r'++------------------------------------------------------------------------------++path :: URI -> ByteString+path u = T.encodeUtf8 $! T.pack+ $! concat [uriPath u, uriQuery u, uriFragment u]+++------------------------------------------------------------------------------++--+-- | Issue an HTTP GET request and pass the resultant response to the+-- supplied handler function. This code will silently follow redirects,+-- to a maximum depth of 5 hops.+--+-- The handler function is as for 'receiveResponse', so you can use one+-- of the supplied convenience handlers if you're in a hurry:+--+-- > x' <- get "http://www.bbc.co.uk/news/" concatHandler+--+-- But as ever the disadvantage of doing this is that you're not doing+-- anything intelligent with the HTTP response status code. If you want+-- an exception raised in the event of a non @2xx@ response, you can use:+--+-- > x' <- get "http://www.bbc.co.uk/news/" concatHandler'+--+-- but for anything more refined you'll find it easy to simply write+-- your own handler function.+--+get :: URL+ -- ^ Resource to GET from.+ -> (Response -> InputStream ByteString -> IO β)+ -- ^ Handler function to receive the response from the server.+ -> IO β+get r' handler = getN 0 r' handler++getN n r' handler = do+ bracket+ (establish u)+ (teardown)+ (process)++ where+ teardown = closeConnection++ u = parseURL r'++ process c = do+ q <- buildRequest c $ do+ http GET (path u)+ setAccept "*/*"++ sendRequest c q emptyBody++ receiveResponse c (wrapRedirect n handler)+++{-+ This is fairly simple-minded. Improvements could include reusing+ the Connection if the redirect is to the same host, and closing+ the original Connection if it is not. These are both things that+ can be done manually if using the full API, so not worried about+ it for now.+-}++wrapRedirect+ :: Int+ -> (Response -> InputStream ByteString -> IO β)+ -> Response+ -> InputStream ByteString+ -> IO β+wrapRedirect n handler p i = do+ if (s == 301 || s == 302 || s == 303 || s == 307)+ then case lm of+ Just l -> getN n' l handler+ Nothing -> handler p i+ else handler p i+ where+ s = getStatusCode p+ lm = getHeader p "Location"+ !n' = if n < 5+ then n + 1+ else throw $! TooManyRedirects n++data TooManyRedirects = TooManyRedirects Int+ deriving (Typeable, Show, Eq)++instance Exception TooManyRedirects+++--+-- | Send content to a server via an HTTP POST request. Use this+-- function if you have an 'OutputStream' with the body content.+--+post :: URL+ -- ^ Resource to POST to.+ -> ContentType+ -- ^ MIME type of the request body being sent.+ -> (OutputStream Builder -> IO α)+ -- ^ Handler function to write content to server.+ -> (Response -> InputStream ByteString -> IO β)+ -- ^ Handler function to receive the response from the server.+ -> IO β+post r' t body handler = do+ bracket+ (establish u)+ (teardown)+ (process)+ where+ teardown = closeConnection++ u = parseURL r'++ process c = do+ q <- buildRequest c $ do+ http POST (path u)+ setAccept "*/*"+ setContentType t++ _ <- sendRequest c q body++ x <- receiveResponse c handler+ return x+++--+-- | Send form data to a server via an HTTP POST request. This is the+-- usual use case; most services expect the body to be MIME type+-- @application/x-www-form-urlencoded@ as this is what conventional+-- web browsers send on form submission. If you want to POST to a URL+-- with an arbitrary Content-Type, use 'post'.+--+postForm+ :: URL+ -- ^ Resource to POST to.+ -> [(ByteString, ByteString)]+ -- ^ List of name=value pairs. Will be sent URL-encoded.+ -> (Response -> InputStream ByteString -> IO β)+ -- ^ Handler function to receive the response from the server.+ -> IO β+postForm r' nvs handler = do+ bracket+ (establish u)+ (teardown)+ (process)+ where+ teardown = closeConnection++ u = parseURL r'++ process c = do+ q <- buildRequest c $ do+ http POST (path u)+ setAccept "*/*"+ setContentType "application/x-www-form-urlencoded"++ _ <- sendRequest c q (encodedFormBody nvs)++ x <- receiveResponse c handler+ return x+++--+-- | Specify name/value pairs to be sent to the server in the manner+-- used by web browsers when submitting a form via a POST request.+-- Parameters will be URL encoded per RFC 2396 and combined into a+-- single string which will be sent as the body of your request.+--+-- You use this partially applied:+--+-- > let nvs = [("name","Kermit"),+-- > ("type","frog")]+-- > ("role","stagehand")]+-- >+-- > sendRequest c q (encodedFormBody nvs)+--+-- Note that it's going to be up to you to call 'setContentType' with+-- a value of @\"application/x-www-form-urlencoded\"@ when building the+-- Request object; the 'postForm' convenience (which uses this+-- @encodedFormBody@ function) takes care of this for you, obviously.+--+encodedFormBody :: [(ByteString,ByteString)] -> OutputStream Builder -> IO ()+encodedFormBody nvs o = do+ Streams.write (Just b) o+ where+ b = mconcat $ intersperse "&" $ map combine nvs++ combine :: (ByteString,ByteString) -> Builder+ combine (n',v') = mconcat [urlEncodeBuilder n', "=", urlEncodeBuilder v']+++--+-- | Place content on the server at the given URL via an HTTP PUT+-- request, specifying the content type and a function to write the+-- content to the supplied 'OutputStream'. You might see:+--+-- > put "http://s3.example.com/bucket42/object149" "text/plain"+-- > (fileBody "hello.txt") (\p i -> do+-- > putStr $ show p+-- > Streams.connect i stdout)+--+put :: URL+ -- ^ Resource to PUT to.+ -> ContentType+ -- ^ MIME type of the request body being sent.+ -> (OutputStream Builder -> IO α)+ -- ^ Handler function to write content to server.+ -> (Response -> InputStream ByteString -> IO β)+ -- ^ Handler function to receive the response from the server.+ -> IO β+put r' t body handler = do+ bracket+ (establish u)+ (teardown)+ (process)+ where+ teardown = closeConnection++ u = parseURL r'++ process c = do+ q <- buildRequest c $ do+ http PUT (path u)+ setAccept "*/*"+ setHeader "Content-Type" t++ _ <- sendRequest c q body++ x <- receiveResponse c handler+ return x+++--+-- | A special case of 'concatHandler', this function will return the+-- entire response body as a single ByteString, but will throw an+-- exception if the response status code was other than @2xx@.+--+concatHandler' :: Response -> InputStream ByteString -> IO ByteString+concatHandler' p i =+ if s >= 300+ then throw (HttpClientError s m)+ else concatHandler p i+ where+ s = getStatusCode p+ m = getStatusMessage p++data HttpClientError = HttpClientError Int ByteString+ deriving (Typeable)++instance Exception HttpClientError++instance Show HttpClientError where+ show (HttpClientError s msg) = Prelude.show s ++ " " ++ S.unpack msg++{-+ There should probably also be HttpServerError and maybe even+ HttpRedirectError, but as these names don't seem to show up+ in the runtime when raised, not sure it's worth the bother. It's+ not like we'd want anything different in their Show instances.+-}+
+ src/Network/Http/RequestBuilder.hs view
@@ -0,0 +1,281 @@+--+-- 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.+--++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Http.RequestBuilder (+ RequestBuilder,+ buildRequest,+ http,+ setHostname,+ setAccept,+ setAccept',+ setAuthorizationBasic,+ ContentType,+ setContentType,+ setContentLength,+ setExpectContinue,+ setHeader+) where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (fromByteString,+ toByteString)+import qualified Blaze.ByteString.Builder.Char8 as Builder (fromShow)+import Control.Monad.State+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base64 as BS64+import Data.ByteString.Char8 ()+import qualified Data.ByteString.Char8 as S+import Data.List (intersperse)+import Data.Monoid (mconcat)++import Network.Http.Connection+import Network.Http.Types++--+-- | The RequestBuilder monad allows you to abuse do-notation to+-- conveniently setup a 'Request' object.+--+newtype RequestBuilder α = RequestBuilder (State Request α)+ deriving (Monad, MonadState Request)++--+-- | Run a RequestBuilder, yielding a Request object you can use on the+-- given connection.+--+-- > q <- buildRequest c $ do+-- > http POST "/api/v1/messages"+-- > setContentType "application/json"+-- > setAccept "text/html"+-- > setHeader "X-WhoDoneIt" "The Butler"+--+-- Obviously it's up to you to later actually /send/ JSON data.+--+buildRequest :: Connection -> RequestBuilder α -> IO Request+buildRequest c mm = do+ let (RequestBuilder s) = (mm)+ let h = cHost c+ let q = Request {+ qHost = h,+ qMethod = GET,+ qPath = "/",+ qBody = Empty,+ qExpect = Normal,+ qHeaders = emptyHeaders+ }+ return $ execState s q+++--+-- | Begin constructing a Request, starting with the request line.+--+http :: Method -> ByteString -> RequestBuilder ()+http m p' = do+ q <- get+ let h0 = qHeaders q+ let h1 = updateHeader h0 "User-Agent" "http-streams/0.3.1.0"+ let h2 = updateHeader h1 "Accept-Encoding" "gzip"++ let e = case m of+ GET -> Empty+ POST -> Chunking+ PUT -> Chunking+ _ -> Empty++ let h3 = case e of+ Chunking -> updateHeader h2 "Transfer-Encoding" "chunked"+ _ -> h2++ put q {+ qMethod = m,+ qPath = p',+ qBody = e,+ qHeaders = h3+ }++--+-- | Set the [virtual] hostname for the request. In ordinary conditions+-- you won't need to call this, as the @Host:@ header is a required+-- header in HTTP 1.1 and is set directly from the name of the server+-- you connected to when calling 'Network.Http.Connection.openConnection'.+--+setHostname :: ByteString -> RequestBuilder ()+setHostname v' = do+ q <- get+ put q {+ qHost = v'+ }++--+-- | Set a generic header to be sent in the HTTP request. The other+-- methods in the RequestBuilder API are expressed in terms of this+-- function, but we recommend you use them where offered for their+-- stronger types.+--+setHeader :: ByteString -> ByteString -> RequestBuilder ()+setHeader k' v' = do+ q <- get+ let h0 = qHeaders q+ let h1 = updateHeader h0 k' v'+ put q {+ qHeaders = h1+ }++deleteHeader :: ByteString -> RequestBuilder ()+deleteHeader k' = do+ q <- get+ let h0 = qHeaders q+ let h1 = removeHeader h0 k'+ put q {+ qHeaders = h1+ }++{-# INLINE setEntityBody #-}+setEntityBody :: EntityBody -> RequestBuilder ()+setEntityBody e = do+ q <- get+ put q {+ qBody = e+ }++{-# INLINE setExpectMode #-}+setExpectMode :: ExpectMode -> RequestBuilder ()+setExpectMode e = do+ q <- get+ put q {+ qExpect = e+ }++--+-- | Indicate the content type you are willing to receive in a reply+-- from the server. For more complex @Accept:@ headers, use+-- 'setAccept''.+--+setAccept :: ByteString -> RequestBuilder ()+setAccept v' = do+ setHeader "Accept" v'++--+-- | Indicate the content types you are willing to receive in a reply+-- from the server in order of preference. A call of the form:+--+-- > setAccept' [("text/html", 1.0),+-- > ("application/xml", 0.8),+-- > ("*/*", 0)]+--+-- will result in an @Accept:@ header value of+-- @text\/html; q=1.0, application\/xml; q=0.8, *\/*; q=0.0@ as you+-- would expect.+--+setAccept' :: [(ByteString,Float)] -> RequestBuilder ()+setAccept' tqs = do+ setHeader "Accept" v'+ where+ v' = Builder.toByteString v+ v = mconcat $ intersperse ", " $ map format tqs++ format :: (ByteString,Float) -> Builder+ format (t',q) =+ mconcat+ [Builder.fromByteString t',+ "; q=",+ Builder.fromShow q]+++--+-- | Set username and password credentials per the HTTP basic+-- authentication method.+--+-- > setAuthorizationBasic "Aladdin" "open sesame"+--+-- will result in an @Authorization:@ header value of+-- @Basic: QWxhZGRpbjpvcGVuIHNlc2FtZQ==@.+--+-- Basic authentication does /not/ use a message digest function to+-- encipher the password; the above string is only base-64 encoded and+-- is thus plain-text visible to any observer on the wire and all+-- caches and servers at the other end, making basic authentication+-- completely insecure. A number of web services, however, use SSL to+-- encrypt the connection that then use HTTP basic authentication to+-- validate requests. Keep in mind in these cases the secret is still+-- sent to the servers on the other side and passes in clear through+-- all layers after the SSL termination. Do /not/ use basic+-- authentication to protect secure or user-originaed privacy-sensitve+-- information.+--+{-+ This would be better using Builder, right?+-}+setAuthorizationBasic :: ByteString -> ByteString -> RequestBuilder ()+setAuthorizationBasic user' passwd' = do+ setHeader "Authorization" v'+ where+ v' = S.concat ["Basic ", msg']+ msg' = BS64.encode str'+ str' = S.concat [user', ":", passwd']+++type ContentType = ByteString+++--+-- | Set the MIME type corresponding to the body of the request you are+-- sending. Defaults to @\"text\/plain\"@, so usually you need to set+-- this if 'PUT'ting.+--+setContentType :: ContentType -> RequestBuilder ()+setContentType v' = do+ setHeader "Content-Type" v'++--+-- | Specify the length of the request body, in bytes.+--+-- RFC 2616 requires that we either send a @Content-Length@ header or+-- use @Transfer-Encoding: chunked@. If you know the exact size ahead+-- of time, then call this function; the body content will still be+-- streamed out by @io-streams@ in more-or-less constant space.+--+-- This function is special: in a PUT or POST request, @http-streams@+-- will assume chunked transfer-encoding /unless/ you specify a content+-- length here, in which case you need to ensure your body function+-- writes precisely that many bytes.+--+--+setContentLength :: Int -> RequestBuilder ()+setContentLength n = do+ deleteHeader "Transfer-Encoding"+ setHeader "Content-Length" (S.pack $ show n)+ setEntityBody $ Static n++--+-- | Specify that this request should set the expectation that the+-- server needs to approve the request before you send it.+--+-- This function is special: in a PUT or POST request, @http-streams@+-- will wait for the server to reply with an HTTP/1.1 100 Continue+-- status before sending the entity body. This is handled internally;+-- you will get the real response (be it successful 2xx, client error,+-- 4xx, or server error 5xx) in 'receiveResponse'. In theory, it+-- should be 417 if the expectation failed.+--+-- Only bother with this if you know the service you're talking to+-- requires clients to send an @Expect: 100-continue@ header and will+-- handle it properly. Most servers don't do any precondition checking,+-- automatically send an intermediate 100 response, and then just read+-- the body regardless, making this a bit of a no-op in most cases.+--+setExpectContinue :: RequestBuilder ()+setExpectContinue = do+ setHeader "Expect" "100-continue"+ setExpectMode Continue+
+ src/Network/Http/ResponseParser.hs view
@@ -0,0 +1,229 @@+--+-- 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.+--+-- Significant portions of this file were written while studying+-- 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, and various utility functions+-- have been cloned from there.+--++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Http.ResponseParser (+ readResponseHeader,+ readResponseBody,++ -- for testing+ parseResponse,+ readDecimal+) where++import Prelude hiding (take, takeWhile)++import Control.Applicative+import Control.Exception (Exception, throw, throwIO)+import Control.Monad (void)+import Data.Attoparsec.ByteString.Char8+import Data.Bits (Bits (..))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.CaseInsensitive (mk)+import Data.Char (ord)+import Data.Int (Int64)+import Data.Typeable (Typeable)+import System.IO.Streams (InputStream)+import qualified System.IO.Streams as Streams+import qualified System.IO.Streams.Attoparsec as Streams++import Network.Http.Types++{-+ 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++ let hp = buildHeaders hs++ _ <- crlf++ return Response {+ pStatusCode = sc,+ pStatusMsg = sm,+ pHeaders = hp+ }+++parseStatusLine :: Parser (Int,ByteString)+parseStatusLine = do+ sc <- string "HTTP/1.1 " *> decimal <* char ' '+ sm <- takeTill (== '\r') <* crlf+ return (sc,sm)++{-+ 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"+++---------------------------------------------------------------------++{-+ Switch on the encoding and compression headers, wrapping the raw+ InputStream to present the entity body's actual bytes.+-}+readResponseBody :: Response -> InputStream ByteString -> IO (InputStream ByteString)+readResponseBody p i1 = do++ i2 <- case encoding of+ None -> readFixedLengthBody i1 n+ Chunked -> readChunkedBody i1++ i3 <- case compression of+ Identity -> return i2+ Gzip -> readCompressedBody i2+ Deflate -> throwIO (UnexpectedCompression $ show compression)++ return i3+ where++ encoding = case header "Transfer-Encoding" of+ Just x'-> if mk x' == "chunked"+ then Chunked+ else None+ Nothing -> None++ compression = case header "Content-Encoding" of+ Just x'-> if mk x' == "gzip"+ then Gzip+ else Identity+ Nothing -> Identity++ header = getHeader p++ n = case header "Content-Length" of+ Just x' -> readDecimal x' :: Int+ Nothing -> 0+++readDecimal :: (Enum a, Num a, Bits a) => ByteString -> a+readDecimal = S.foldl' f 0+ where+ f !cnt !i = cnt * 10 + digitToInt i++ {-# INLINE digitToInt #-}+ digitToInt :: (Enum a, Num a, Bits a) => Char -> a+ digitToInt c | c >= '0' && c <= '9' = toEnum $! ord c - ord '0'+ | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit"+{-# INLINE readDecimal #-}+++data TransferEncoding = None | Chunked++data ContentEncoding = Identity | Gzip | Deflate+ deriving (Show)++data UnexpectedCompression = UnexpectedCompression String+ deriving (Typeable, Show)++instance Exception UnexpectedCompression+++---------------------------------------------------------------------++{-+ Process a response body in chunked transfer encoding, taking the+ resultant bytes and reproducing them as an InputStream+-}+readChunkedBody :: InputStream ByteString -> IO (InputStream ByteString)+readChunkedBody i1 = do+ i2 <- Streams.parserToInputStream parseTransferChunk i1+ return i2+++{-+ Treat chunks larger than 256kB as a denial-of-service attack.+-}+mAX_CHUNK_SIZE :: Int+mAX_CHUNK_SIZE = (2::Int)^(18::Int)++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+ then do+ -- skip trailers and consume final CRLF+ _ <- many parseHeader+ void crlf+ return Nothing+ else do+ -- now safe to take this many bytes.+ !x' <- take n+ void crlf+ return $! Just x'++data HttpParseException = HttpParseException String+ deriving (Typeable, Show)++instance Exception HttpParseException++---------------------------------------------------------------------++{-+ This has the rather crucial side effect of terminating the stream+ after the requested number of bytes. Otherwise, code handling+ responses waits on more input until an HTTP timeout occurs.+-}+readFixedLengthBody :: InputStream ByteString -> Int -> IO (InputStream ByteString)+readFixedLengthBody i1 n = do+ i2 <- Streams.takeBytes (fromIntegral n :: Int64) i1+ return i2+++---------------------------------------------------------------------++readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString)+readCompressedBody i1 = do+ i2 <- Streams.gunzip i1+ return i2
+ src/Network/Http/Types.hs view
@@ -0,0 +1,336 @@+--+-- 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.+--++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-orphans #-}++module Network.Http.Types (+ Request(..),+ EntityBody(..),+ ExpectMode(..),+ getHostname,+ Response(..),+ StatusCode,+ getStatusCode,+ getStatusMessage,+ getHeader,+ Method(..),+ Headers,+ emptyHeaders,+ updateHeader,+ removeHeader,+ buildHeaders,+ lookupHeader,++ -- for testing+ composeRequestBytes,+ composeResponseBytes+) where++import Prelude hiding (lookup)++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (copyByteString,+ copyByteString,+ fromByteString,+ fromByteString,+ toByteString)+import qualified Blaze.ByteString.Builder.Char8 as Builder+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)+import Data.Monoid (mconcat, mempty)+import Data.String (IsString, fromString)++-- | HTTP Methods, as per RFC 2616+data Method+ = GET+ | HEAD+ | POST+ | PUT+ | DELETE+ | TRACE+ | OPTIONS+ | CONNECT+ | PATCH+ | Method ByteString+ deriving (Show, Read, Ord)+++instance Eq Method where+ GET == GET = True+ HEAD == HEAD = True+ POST == POST = True+ PUT == PUT = True+ DELETE == DELETE = True+ TRACE == TRACE = True+ OPTIONS == OPTIONS = True+ CONNECT == CONNECT = True+ PATCH == PATCH = True+ GET == Method "GET" = True+ HEAD == Method "HEAD" = True+ POST == Method "POST" = True+ PUT == Method "PUT" = True+ DELETE == Method "DELETE" = True+ TRACE == Method "TRACE" = True+ OPTIONS == Method "OPTIONS" = True+ CONNECT == Method "CONNECT" = True+ PATCH == Method "PATCH" = True+ Method a == Method b = a == b+ m@(Method _) == other = other == m+ _ == _ = False++--+-- | A description of the request that will be sent to the server. Note+-- unlike other HTTP libraries, the request body is /not/ a part of this+-- object; that will be streamed out by you when actually sending the+-- request with 'sendRequest'.+--+-- 'Request' has a useful @Show@ instance that will output the request+-- line and headers (as it will be sent over the wire but with the @\\r@+-- characters stripped) which can be handy for debugging.+--+data Request+ = Request {+ qMethod :: Method,+ qHost :: ByteString,+ qPath :: ByteString,+ qBody :: EntityBody,+ qExpect :: ExpectMode,+ qHeaders :: Headers+ }++instance Show Request where+ show q = {-# SCC "Request.show" #-}+ S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeRequestBytes q+++data EntityBody = Empty | Chunking | Static Int++data ExpectMode = Normal | Continue++{-+ The bit that builds up the actual string to be transmitted. This+ is on the critical path for every request, so we'll want to revisit+ this to improve performance.++ - Rewrite rule for Method?+ - How can serializing the Headers be made efficient?++ This code includes the RFC compliant CR-LF sequences as line+ terminators, which is why the Show instance above has to bother+ with removing them.+-}++composeRequestBytes :: Request -> Builder+composeRequestBytes q =+ mconcat+ [requestline,+ hostLine,+ headerFields,+ "\r\n"]+ where+ requestline = mconcat+ [method,+ " ",+ uri,+ " ",+ version,+ "\r\n"]+ method = Builder.fromString $ show $ qMethod q+ uri = Builder.copyByteString $ qPath q+ version = "HTTP/1.1"++ hostLine = mconcat ["Host: ", hostname, "\r\n"]+ hostname = Builder.copyByteString $ qHost q++ headerFields = joinHeaders $ unWrap $ qHeaders q+++--+-- | Get the virtual hostname that will be used as the @Host:@ header in+-- the HTTP 1.1 request. Per RFC 2616 § 14.23, this will be of the form+-- @hostname:port@ if the port number is other than the default, ie 80+-- for HTTP.+--+getHostname :: Request -> ByteString+getHostname q = qHost q++type StatusCode = Int++--+-- | A description of the response received from the server. Note+-- unlike other HTTP libraries, the response body is /not/ a part+-- of this object; that will be streamed in by you when calling+-- 'receiveResponse'.+--+-- Like 'Request', 'Response' has a @Show@ instance that will output+-- the status line and response headers as they were received from the+-- server.+--+data Response+ = Response {+ pStatusCode :: StatusCode,+ pStatusMsg :: ByteString,+ pHeaders :: Headers+ }++instance Show Response where+ show p = {-# SCC "Response.show" #-}+ S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p++--+-- | Get the HTTP response status code.+--+getStatusCode :: Response -> StatusCode+getStatusCode = pStatusCode+{-# INLINE getStatusCode #-}++--+-- | Get the HTTP response status message. Keep in mind that this is+-- /not/ normative; whereas 'getStatusCode' values are authoritative.+--+getStatusMessage :: Response -> ByteString+getStatusMessage = pStatusMsg+{-# INLINE getStatusMessage #-}++--+-- | Lookup a header in the response. HTTP header field names are+-- case-insensitive, so you can specify the name to lookup however you+-- like. If the header is not present @Nothing@ will be returned.+--+-- > let n = case getHeader p "Content-Length" of+-- > Just x' -> read x' :: Int+-- > Nothing -> 0+--+-- which of course is essentially what goes on inside the library when+-- @http-streams@ receives a response from the server and has to figure+-- out how many bytes to read.+--+-- There is a fair bit of complexity in some of the other HTTP response+-- fields, so there are a number of specialized functions for reading+-- those values where we've found them useful.+--+getHeader :: Response -> ByteString -> Maybe ByteString+getHeader p k =+ lookupHeader h k+ where+ h = pHeaders p+++composeResponseBytes :: Response -> Builder+composeResponseBytes p =+ mconcat+ [statusline,+ headerFields,+ "\r\n"]+ where+ statusline = mconcat+ [version,+ " ",+ code,+ " ",+ message,+ "\r\n"]+ code = Builder.fromShow $ pStatusCode p+ message = Builder.copyByteString $ pStatusMsg p+ version = "HTTP/1.1"+ headerFields = joinHeaders $ unWrap $ pHeaders p+++instance IsString Builder where+ fromString x = Builder.fromString x++--+-- | The map of headers in a 'Request' or 'Response'. Note that HTTP+-- header field names are case insensitive, so if you call 'setHeader'+-- on a field that's already defined but with a different capitalization+-- you will replace the existing value.+--+{-+ This is a fair bit of trouble just to avoid using a typedef here.+ Probably worth it, though; every other HTTP client library out there+ exposes the gory details of the underlying map implementation, and+ to use it you need to figure out all kinds of crazy imports. Indeed,+ this code used here in the Show instance for debugging has been+ copied & pasted around various projects of mine since I started+ writing Haskell. It's quite tedious, and very arcane! So, wrap it+ up.+-}+newtype Headers = Wrap {+ unWrap :: HashMap (CI ByteString) ByteString+}++instance Show Headers where+ show x = S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ joinHeaders $ unWrap x++joinHeaders :: HashMap (CI ByteString) ByteString -> Builder+joinHeaders m = foldrWithKey combine mempty m++combine :: CI ByteString -> ByteString -> Builder -> Builder+combine k v acc =+ mconcat [acc, key, ": ", value, "\r\n"]+ where+ key = Builder.copyByteString $ original k+ value = Builder.fromByteString v+{-# INLINE combine #-}++emptyHeaders :: Headers+emptyHeaders =+ Wrap empty++{-+ Set a header field to the specified value. This will overwrite+ any existing value for the field. Remember that HTTP fields names+ are case insensitive!+-}+updateHeader :: Headers -> ByteString -> ByteString -> Headers+updateHeader x k v =+ Wrap result+ where+ result = insert (mk k) v m+ m = unWrap x++removeHeader :: Headers -> ByteString -> Headers+removeHeader x k =+ Wrap result+ where+ result = delete (mk k) m+ m = unWrap x+++{-+ Given a list of key,value pairs, construct a 'Headers' map. This is+ only going to be used by RequestBuilder and ResponseParser,+ obviously. And yes, as usual, we go to a lot of trouble to splice+ out the function doing the work, in the name of type sanity.+-}+buildHeaders :: [(ByteString,ByteString)] -> Headers+buildHeaders hs =+ Wrap result+ where+ result = foldr addHeader empty hs++addHeader+ :: (ByteString,ByteString)+ -> HashMap (CI ByteString) ByteString+ -> HashMap (CI ByteString) ByteString+addHeader (k,v) m =+ insert (mk k) v m++lookupHeader :: Headers -> ByteString -> Maybe ByteString+lookupHeader x k =+ lookup (mk k) m+ where+ m = unWrap x+
+ tests/Check.hs view
@@ -0,0 +1,447 @@+--+-- 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 a BSD licence.+--++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-unused-imports #-}++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 (shouldThrow, Selector, anyException)+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 Network.Http.Client+import Network.Http.Connection (Connection (..))+import Network.Http.Inconvenience (HttpClientError (..),+ TooManyRedirects (..))+import Network.Http.ResponseParser (parseResponse, readDecimal)+import Network.Http.Types (Request (..), composeRequestBytes, lookupHeader)+import TestServer (localPort, runTestServer)++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+ testChunkedEncoding+ testContentLength+ testCompressedResponse++ describe "Expectation handling" $ do+ testExpectationContinue++ describe "Convenience API" $ do+ testPutChunks+ testPostChunks+ testPostWithForm+ testGetRedirects+ testExcessiveRedirects+ testGeneralHandler+ testEstablishConnection+++testRequestTermination =+ it "terminates with a blank line" $ do+ c <- openConnection "127.0.0.1" localPort+ q <- buildRequest c $ do+ http GET "/time"+ setAccept "text/plain"++ let e' = Builder.toByteString $ composeRequestBytes q+ 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 c $ do+ http GET "/time"++ let e' = Builder.toByteString $ composeRequestBytes q+ 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+ return $ Connection {+ cHost = "www.example.com",+ cClose = return (),+ cIn = i,+ cOut = o+ }+++testAcceptHeaderFormat =+ it "properly formats Accept header" $ do+ c <- fakeConnection+ q <- buildRequest c $ 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+ c <- fakeConnection+ q <- buildRequest c $ do+ setAuthorizationBasic "Aladdin" "open sesame"++ let h = qHeaders q+ 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+ 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+ c <- fakeConnection+ q1 <- buildRequest c $ do+ http GET "/hello.txt"++ let h1 = qHost q1+ assertEqual "Incorrect Host header" "www.example.com" h1++ q2 <- buildRequest c $ do+ http GET "/hello.txt"+ setHostname "other.example.com"++ let h2 = qHost q2+ assertEqual "Incorrect Host header" "other.example.com" h2+++testResponseParser1 =+ it "parses a simple 200 response" $ do+ b' <- S.readFile "tests/example1.txt"+ parseTest parseResponse b'+ return ()+++testChunkedEncoding =+ it "recognizes chunked transfer encoding and decodes" $ do+ c <- openConnection "127.0.0.1" localPort++ q <- buildRequest c $ 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 "127.0.0.1" localPort++ q <- buildRequest c $ 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 "127.0.0.1" localPort++ q <- buildRequest c $ 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 "127.0.0.1" localPort++ q <- buildRequest c $ 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+++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+++{-+ 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 c $ 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+