diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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) diff --git a/http-streams.cabal b/http-streams.cabal new file mode 100644 --- /dev/null +++ b/http-streams.cabal @@ -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 +maintainer: Andrew Cowie +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: diff --git a/src/Network/Http/Client.hs b/src/Network/Http/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/Http/Client.hs @@ -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 + diff --git a/src/Network/Http/Connection.hs b/src/Network/Http/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/Http/Connection.hs @@ -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 diff --git a/src/Network/Http/Inconvenience.hs b/src/Network/Http/Inconvenience.hs new file mode 100644 --- /dev/null +++ b/src/Network/Http/Inconvenience.hs @@ -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 +-- ) +-- +urlEncode :: ByteString -> URL +urlEncode = Builder.toByteString . urlEncodeBuilder +{-# INLINE urlEncode #-} + + +-- +-- | URL-escapes a string (see +-- ) 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. +-} + diff --git a/src/Network/Http/RequestBuilder.hs b/src/Network/Http/RequestBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Network/Http/RequestBuilder.hs @@ -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 + diff --git a/src/Network/Http/ResponseParser.hs b/src/Network/Http/ResponseParser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Http/ResponseParser.hs @@ -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 diff --git a/src/Network/Http/Types.hs b/src/Network/Http/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Http/Types.hs @@ -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 + diff --git a/tests/Check.hs b/tests/Check.hs new file mode 100644 --- /dev/null +++ b/tests/Check.hs @@ -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 +