diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,37 @@ +* _v0.8.9_ + Ongoing maintenance continues, including support for GHC 9.2 and GHC 9.4 + +* _v0.8.6_ + Internal modules are exposed. Mostly so the test suite would only + depend on the library and not the code directly, but occasionally + someone needed to poke at the internals. Usual warning against + doing that applies. They are _not_ visible in the generated Haddock + documentation. + +* _v0.8.4_ + Support GHC 8.0 + +* _v0.8.3_ + A pure version of `buildRequest` is now available as `buildRequest1`. + Support for connecting to Unix domain sockets has been added. + +* _v0.7.0_ + The Request, Response, Headers, and RequestBuilder types have been + factored out and moved to **http-common**. They are still exported + by **http-streams**. + +* _v0.6.0_ + Entity body lengths (both for Requests and Responses) now Int64. + Library depends on **io-streams** 1.1. + +* _v0.5.0_ + Definition of Hostname and Port have been changed to ByteString + and Word16, respectively. + +* _v0.4.0_ + Type signature of `buildRequest` changed, removing the Connection + parameter. This allows you to construct Request objects before + opening a connection to the web server if you wish. + +* _v0.3.1_ + Initial public release diff --git a/LICENCE b/LICENCE deleted file mode 100644 --- a/LICENCE +++ /dev/null @@ -1,32 +0,0 @@ -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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright © 2012-2023 Athae Eredh Siniath and Others +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,57 @@ +An HTTP client +============== + +An HTTP client library for Haskell using the Snap Framework's +[io-streams](https://hackage.haskell.org/package/io-streams) library to handle +the streaming IO. + +A common case in writing RESTful web services is needing to make onward calls +to further servers. This package is intended to make this easy to do. +Though originally written for making calls from web apps written with +Snap, you can use this from any library or framework. + +Enjoy! + +Example +------- + +The underlying API is very simple: + +```haskell +main :: IO () +main = do + c <- openConnection "www.example.com" 80 + + let q = buildRequest1 $ do + http GET "/" + setAccept "text/html" + + sendRequest c q emptyBody + + receiveResponse c (\p i -> do + putStr $ show p + + x <- Streams.read i + S.putStr $ fromMaybe "" x) + + closeConnection c +``` + +There are also convenience functions for the common case of making +straight-forward GET and POST requests; for instance: + +```haskell + get "http://www.example.com/" (\_ i -> Streams.connect i stdout) +``` + +will _{ahem}_ stream the response body to stdout. Perhaps more +interesting (though less streams-oriented), is simply getting the +response as a ByteString using one of the pre-defined handlers: + +```haskell + x' <- get "https://secure.example.com/" concatHandler +``` + +See the documentation in +[Network.Http.Client](https://hackage.haskell.org/package/http-streams/docs/Network-Http-Client.html) +for further examples and details of usage of the API. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,64 +1,2 @@ --- --- 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.Text (display) -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 (..), Handle, 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 _ _ p _ = do - - withFile "config.h" WriteMode (\h -> do - discoverOperatingSystem h - discoverLibraryVersion h p) - - return () - -discoverOperatingSystem :: Handle -> IO () -discoverOperatingSystem h = do - hPutStrLn h ("#define " ++ s) - - where - o = buildOS - - s = case o of - Linux -> "__LINUX__" - OSX -> "__MACOSX__" - Windows -> "__WINDOWS__" - _ -> "__" ++ up o ++ "__" - - up x = map toUpper (show x) - -discoverLibraryVersion :: Handle -> PackageDescription -> IO () -discoverLibraryVersion h p = do - hPutStrLn h ("#define VERSION \"http-streams/" ++ s ++ "\"") - - where - i = package p - v = pkgVersion i - s = display v - +main = defaultMain diff --git a/http-streams.cabal b/http-streams.cabal --- a/http-streams.cabal +++ b/http-streams.cabal @@ -1,12 +1,10 @@ -cabal-version: >= 1.10 +cabal-version: 1.24 name: http-streams -version: 0.6.1.1 +version: 0.8.9.9 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 + handle 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. . @@ -14,48 +12,71 @@ 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.6 +license-file: LICENSE +author: Andrew Cowie +maintainer: Andrew Cowie +copyright: © 2012-2023 Athae Eredh Siniath and Others +category: Web, IO-Streams +tested-with: GHC == 8.10.7, GHC == 9.2.7, GHC == 9.4.5 stability: experimental -homepage: http://research.operationaldynamics.com/projects/http-streams/ -bug-reports: https://github.com/afcowie/http-streams/issues +homepage: https://github.com/aesiniath/http-streams/ +bug-reports: https://github.com/aesiniath/http-streams/issues +extra-source-files: README.md CHANGELOG.md + tests/MockServer.hs + tests/TestSuite.hs + tests/data-eu-gdp.json + tests/data-us-gdp.json + tests/data-jp-gdp.json + tests/statler.jpg + tests/multipart.bin + tests/example1.txt + tests/example2.txt + tests/example3.txt + tests/example4.txt + tests/example5.txt + tests/hello.txt + tests/hello.html -build-type: Custom +build-type: Simple +flag network-uri + description: Get Network.URI from the network-uri package + default: True + library default-language: Haskell2010 build-depends: attoparsec, - base >= 4 && <5, + base >= 4.5 && <5, + directory, base64-bytestring, - blaze-builder, + blaze-builder >= 0.4, bytestring, case-insensitive, - io-streams >= 1.1 && <1.2, - HsOpenSSL, - openssl-streams >= 1.1 && <1.2, + filepath, + io-streams >= 1.3 && < 1.6, + HsOpenSSL >= 0.11.2, + openssl-streams >= 1.1 && < 1.4, mtl, transformers, - network, text, unordered-containers, - aeson + aeson < 2.3, + attoparsec-aeson < 2.3, + http-common >= 0.8.3.4 + if flag(network-uri) + build-depends: network-uri >= 2.6, network >= 2.6 + else + build-depends: network-uri < 2.6, network < 2.6 - hs-source-dirs: src - exposed-modules: Network.Http.Client - other-modules: Network.Http.Types, + hs-source-dirs: lib + exposed-modules: Network.Http.Client, Network.Http.Connection, - Network.Http.RequestBuilder, Network.Http.ResponseParser, - Network.Http.Utilities, Network.Http.Inconvenience + other-modules: Network.Http.Utilities - ghc-options: -O2 - -Wall + ghc-options: -Wall -Wwarn -fwarn-tabs -funbox-strict-fields @@ -65,7 +86,7 @@ include-dirs: . - ghc-prof-options: -prof -fprof-auto-top + ghc-prof-options: -fprof-auto-exported test-suite check @@ -76,10 +97,11 @@ build-depends: HUnit, HsOpenSSL, - MonadCatchIO-transformers, + lifted-base, aeson-pretty, attoparsec, base, + directory, blaze-builder, base64-bytestring, bytestring, @@ -90,21 +112,24 @@ io-streams, mtl, transformers, - network, - openssl-streams, - 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, + network >= 2.6, + network-uri >= 2.6, + openssl-streams >= 1.1 && < 1.4, + random, + snap-core >= 1.0 && < 1.2, + snap-server >= 1.1 && < 1.2, text, unordered-containers, - aeson + aeson, + http-common >= 0.8.2, + http-streams - hs-source-dirs: src,tests - main-is: Check.hs + hs-source-dirs: tests + main-is: check.hs + other-modules: TestSuite + MockServer - ghc-options: -O2 - -threaded + ghc-options: -threaded -Wall -Wwarn -fwarn-tabs @@ -118,7 +143,7 @@ source-repository head type: git - location: git://github.com/afcowie/http-streams.git + location: git://github.com/aesiniath/http-streams.git -- vim: set tabstop=21 expandtab: diff --git a/lib/Network/Http/Client.hs b/lib/Network/Http/Client.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Client.hs @@ -0,0 +1,202 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2021 Athae Eredh Siniath and Others +-- +-- 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: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > 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 +-- +-- \ let q = 'buildRequest1' $ do +-- 'http' GET \"\/\" +-- 'setAccept' \"text/html\" +-- +-- \ 'sendRequest' c q 'emptyBody' +-- +-- \ `receiveResponse` c (\\p i -> do +-- xm <- Streams.read i +-- case xm of +-- Just x -> S.putStr x +-- Nothing -> \"\") +-- +-- \ '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, + openConnectionUnix, + + -- * Building Requests + -- | You setup a request using the RequestBuilder monad, and + -- get the resultant Request object by running 'buildRequest1'. The + -- first call doesn't have to be to 'http', but it looks better when + -- it is, don't you think? + Method(..), + RequestBuilder, + buildRequest1, + buildRequest, + http, + setHostname, + setAccept, + setAccept', + setAuthorizationBasic, + ContentType, + setContentType, + setContentLength, + FieldName, + Boundary, + randomBoundary, + setContentMultipart, + setExpectContinue, + setTransferEncoding, + setHeader, + + -- * Sending HTTP request + Request, + Response, + getHostname, + sendRequest, + emptyBody, + simpleBody, + fileBody, + inputStreamBody, + encodedFormBody, + multipartFormBody, + Part, + simplePart, + filePart, + inputStreamPart, + jsonBody, + + -- * Processing HTTP response + receiveResponse, + receiveResponseRaw, + unsafeReceiveResponse, + UnexpectedCompression, + StatusCode, + getStatusCode, + getStatusMessage, + getHeader, + debugHandler, + simpleHandler, + simpleHandler', + HttpClientError(..), + jsonHandler, + + -- * 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, + TooManyRedirects, + post, + postForm, + put, + + -- * Secure connections + openConnectionSSL, + baselineContextSSL, + modifyContextSSL, + establishConnection, + + -- * Testing support + makeConnection, + Headers, + getHeaders, + getHeadersFull, + packBoundary, + + -- * Deprecated + concatHandler, + concatHandler', + getRequestHeaders +) where + +import Network.Http.Types + +import Network.Http.Connection +import Network.Http.Inconvenience diff --git a/lib/Network/Http/Connection.hs b/lib/Network/Http/Connection.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Connection.hs @@ -0,0 +1,679 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2021 Athae Eredh Siniath and Others +-- +-- 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 CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide, not-home #-} + +module Network.Http.Connection ( + Connection (..), + -- constructors only for testing + makeConnection, + withConnection, + openConnection, + openConnectionSSL, + openConnectionUnix, + closeConnection, + getHostname, + getRequestHeaders, + getHeadersFull, + sendRequest, + receiveResponse, + receiveResponseRaw, + unsafeReceiveResponse, + UnexpectedCompression, + emptyBody, + simpleBody, + fileBody, + inputStreamBody, + debugHandler, + simpleHandler, + 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 Network.Socket +import OpenSSL (withOpenSSL) +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) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mappend, mempty) +#endif + +import Network.Http.Internal +import Network.Http.ResponseParser + +{- | +A connection to a web server. +-} +data Connection = Connection + { -- | will be used as the Host: header in the HTTP request. + cHost :: ByteString + , -- | called when the connection should be closed. + cClose :: IO () + , cOut :: OutputStream Builder + , cIn :: InputStream ByteString + } + +instance Show Connection where + show c = + {-# SCC "Connection.show" #-} + concat + [ "Host: " + , S.unpack $ cHost c + , "\n" + ] + +{- | +Create a raw Connection object from the given parts. This is +primarily of use when teseting, for example: + +> fakeConnection :: IO Connection +> fakeConnection = do +> o <- Streams.nullOutput +> i <- Streams.nullInput +> c <- makeConnection "www.example.com" (return()) o i +> return c + +is an idiom we use frequently in testing and benchmarking, usually +replacing the InputStream with something like: + +> x' <- S.readFile "properly-formatted-response.txt" +> i <- Streams.fromByteString x' + +If you're going to do that, keep in mind that you /must/ have CR-LF +pairs after each header line and between the header and body to +be compliant with the HTTP protocol; otherwise, parsers will +reject your message. +-} +makeConnection :: + -- | will be used as the @Host:@ header in the HTTP request. + ByteString -> + -- | an action to be called when the connection is terminated. + IO () -> + -- | write end of the HTTP client-server connection. + OutputStream ByteString -> + -- | read end of the HTTP client-server connection. + InputStream ByteString -> + IO Connection +makeConnection h c o1 i = do + o2 <- Streams.builderStream o1 + return $! Connection h c o2 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 +> let q = buildRequest1 $ 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 h1' p = do + is <- getAddrInfo (Just hints) (Just h1) (Just $ show p) + let addr = head is + let a = addrAddress addr + s <- socket (addrFamily addr) Stream defaultProtocol + + connect s a + (i, o1) <- Streams.socketToStreams s + + o2 <- Streams.builderStream o1 + + return + Connection + { cHost = h2' + , cClose = close s + , cOut = o2 + , cIn = i + } + where + hints = + defaultHints + { addrFlags = [AI_NUMERICSERV] + , addrSocketType = Stream + } + h2' = + if p == 80 + then h1' + else S.concat [h1', ":", S.pack $ show p] + h1 = S.unpack h1' + +{- | +Open a secure connection to a web server. + +> import OpenSSL (withOpenSSL) +> +> main :: IO () +> main = 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@. + +/There is no longer a need to call @withOpenSSL@ explicitly; the +initialization is invoked once per process for you/ +-} +openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection +openConnectionSSL ctx h1' p = withOpenSSL $ do + is <- getAddrInfo Nothing (Just h1) (Just $ show p) + + let a = addrAddress $ head is + f = addrFamily $ head is + s <- socket f Stream defaultProtocol + + connect s a + + ssl <- SSL.connection ctx s + SSL.setTlsextHostName ssl h1 + SSL.connect ssl + + (i, o1) <- Streams.sslToStreams ssl + + o2 <- Streams.builderStream o1 + + return + Connection + { cHost = h2' + , cClose = closeSSL s ssl + , cOut = o2 + , cIn = i + } + where + h2' :: ByteString + h2' = + if p == 443 + then h1' + else S.concat [h1', ":", S.pack $ show p] + h1 = S.unpack h1' + +closeSSL :: Socket -> SSL -> IO () +closeSSL s ssl = do + SSL.shutdown ssl SSL.Unidirectional + close s + +{- | +Open a connection to a Unix domain socket. + +> main :: IO () +> main = do +> c <- openConnectionUnix "/var/run/docker.sock" +> ... +> closeConnection c +-} +openConnectionUnix :: FilePath -> IO Connection +openConnectionUnix path = do + let a = SockAddrUnix path + s <- socket AF_UNIX Stream defaultProtocol + + connect s a + (i, o1) <- Streams.socketToStreams s + + o2 <- Streams.builderStream o1 + + return + Connection + { cHost = path' + , cClose = close s + , cOut = o2 + , cIn = i + } + where + path' = S.pack path + +{- | +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 (Builder.fromString "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 + -- 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 + o2 = cOut c + e = qBody q + t = qExpect q + msg = composeRequestBytes q h' + h' = cHost c + i = cIn c + rsp p = Builder.toByteString $ composeResponseBytes p + +{- | +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 :: Connection -> Request -> ByteString +getHostname c q = + case qHost q of + Just h' -> h' + Nothing -> cHost c + +{-# DEPRECATED getRequestHeaders "use retrieveHeaders . getHeadersFull instead" #-} +getRequestHeaders :: Connection -> Request -> [(ByteString, ByteString)] +getRequestHeaders c q = + ("Host", getHostname c q) : kvs + where + h = qHeaders q + kvs = retrieveHeaders h + +{- | +Get the headers that will be sent with this request. You likely won't +need this but there are some corner cases where people need to make +calculations based on all the headers before they go out over the wire. + +If you'd like the request headers as an association list, import the header +functions: + +> import Network.Http.Types + +then use 'Network.Http.Types.retreiveHeaders' as follows: + +>>> let kvs = retreiveHeaders $ getHeadersFull c q +>>> :t kvs +:: [(ByteString, ByteString)] +-} +getHeadersFull :: Connection -> Request -> Headers +getHeadersFull c q = + h' + where + h = qHeaders q + h' = updateHeader h "Host" (getHostname c q) + +{- | +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 i +> 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. + +Throws 'UnexpectedCompression' if it doesn't know how to handle the +compression format used in the response. +-} + +{- + 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 + +{- | +This is a specialized variant of 'receiveResponse' that /explicitly/ does +not handle the content encoding of the response body stream (it will not +decompress anything). Unless you really want the raw gzipped content coming +down from the server, use @receiveResponse@. +-} + +{- + See notes at receiveResponse. +-} +receiveResponseRaw :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β +receiveResponseRaw c handler = do + p <- readResponseHeader i + let p' = + p + { pContentEncoding = Identity + } + + i' <- readResponseBody p' i + + x <- handler p i' + + Streams.skipToEof i' + + return x + where + i = cIn c + +{- | +Handle the response coming back from the server. This function +is the same as receiveResponse, but it does not consume the body for +you after the handler is done. This means that it can only be safely used +if the handler will fully consume the body, there is no body, or when +the connection is not being reused (no pipelining). +-} +unsafeReceiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β +unsafeReceiveResponse c handler = do + p <- readResponseHeader i + i' <- readResponseBody p i + + handler p i' + 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 () + +{- | +Sometimes you just want to send some bytes to the server as a the body of your +request. This is easy to use, but if you're doing anything massive use +'inputStreamBody'; if you're sending a file use 'fileBody'; if you have an +object that needs to be sent as JSON use 'jsonBody' +-} +simpleBody :: ByteString -> OutputStream Builder -> IO () +simpleBody x' o = do + let b = Builder.fromByteString x' + Streams.write (Just b) o + +{- | +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 +> +> let q = buildRequest1 $ 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 + S.putStr $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes 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 simpleHandler +> ... + +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" simpleHandler + +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. +-} +simpleHandler :: Response -> InputStream ByteString -> IO ByteString +simpleHandler _ i1 = do + i2 <- Streams.map Builder.fromByteString i1 + x <- Streams.fold mappend mempty i2 + return $ Builder.toByteString x + +concatHandler :: Response -> InputStream ByteString -> IO ByteString +concatHandler = simpleHandler +{-# DEPRECATED concatHandler "Use simpleHandler instead" #-} + +{- | +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/lib/Network/Http/Inconvenience.hs b/lib/Network/Http/Inconvenience.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Inconvenience.hs @@ -0,0 +1,753 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2021 Athae Eredh Siniath and Others +-- +-- 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_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide, not-home #-} + +module Network.Http.Inconvenience ( + URL, + modifyContextSSL, + establishConnection, + get, + post, + postForm, + encodedFormBody, + multipartFormBody, + Part, + simplePart, + filePart, + inputStreamPart, + put, + baselineContextSSL, + simpleHandler', + concatHandler', + jsonBody, + jsonHandler, + TooManyRedirects (..), + HttpClientError (..), + -- for testing + splitURI, + parseURL, +) where + +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as Builder ( + fromByteString, + fromLazyByteString, + fromWord8, + toByteString, + ) +import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString) +import Control.Exception (Exception, bracket, throw) +import Data.Aeson (FromJSON, Result (..), ToJSON, encode, fromJSON) +import Data.Aeson.Parser (json') +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) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (intersperse) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Typeable (Typeable) +import Data.Word (Word16) +import GHC.Exts +import GHC.Word (Word8 (..)) +import Network.URI ( + URI (..), + URIAuth (..), + escapeURIString, + isAbsoluteURI, + isAllowedInURI, + parseRelativeReference, + parseURI, + uriToString, + ) +import OpenSSL (withOpenSSL) +import OpenSSL.Session (SSLContext) +import qualified OpenSSL.Session as SSL +import System.FilePath.Posix (takeFileName) +import System.IO.Streams (InputStream, OutputStream) +import qualified System.IO.Streams as Streams +import qualified System.IO.Streams.Attoparsec as Streams +import System.IO.Unsafe (unsafePerformIO) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid (..), mappend) +#endif + +import Network.Http.Connection +import Network.Http.Internal +import Network.Http.RequestBuilder + +-- (see also http://downloads.haskell.org/~ghc/8.4.2/docs/html/users_guide/phases.html#standard-cpp-macros +-- for a list of predefined CPP macros provided by GHC and/or Cabal; see also the cabal user's guide) +#if defined(linux_HOST_OS) || defined(freebsd_HOST_OS) +import System.Directory (doesDirectoryExist) +#endif + +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 `mappend` Builder.fromByteString x + esc (c, r) = + let b'' = + if c == ' ' + then b' `mappend` Builder.fromWord8 (c2w '+') + else b' `mappend` hexd c + in go b'' r + +hexd :: Char -> Builder +hexd c0 = + Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi + `mappend` 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#)) +#if MIN_VERSION_base(4,16,0) + uncheckedShiftRL'# a# b# = word8ToWord# (uncheckedShiftRLWord8# a# b#) +#else + uncheckedShiftRL'# = uncheckedShiftRL# +#endif + +urlEncodeTable :: HashSet Char +urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0 .. 255] + where + f c + | c >= 'A' && c <= 'Z' = True + | c >= 'a' && c <= 'z' = True + | c >= '0' && c <= '9' = True + f c = c `elem` ("$-_.!~*'()," :: String) + +------------------------------------------------------------------------------ + +{- + 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 https:// 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, secure, or unix domain, +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 +> let q = buildRequest1 $ 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 + "unix:" -> do + openConnectionUnix $ uriPath u + _ -> error ("Unknown URI scheme " ++ scheme) + where + scheme = uriScheme u + + auth = case uriAuthority u of + Just x -> x + Nothing -> URIAuth "" "localhost" "" + + host = S.pack (uriRegName auth) + port = case uriPort auth of + "" -> 80 + _ -> read $ tail $ uriPort auth :: Word16 + ports = case uriPort auth of + "" -> 443 + _ -> read $ tail $ uriPort auth :: Word16 + +{- | +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, OpenBSD and FreeBSD systems, this function also configures +OpenSSL to verify certificates using the system/distribution supplied +certificate authorities' certificates + +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 such 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 = withOpenSSL $ do + ctx <- SSL.context + SSL.contextSetDefaultCiphers ctx +#if defined(darwin_HOST_OS) + SSL.contextSetVerificationMode ctx SSL.VerifyNone +#elif defined(mingw32_HOST_OS) + SSL.contextSetVerificationMode ctx SSL.VerifyNone +#elif defined(freebsd_HOST_OS) + SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem" + SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing +#elif defined(openbsd_HOST_OS) + SSL.contextSetCAFile ctx "/etc/ssl/cert.pem" + SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing +#else + fedora <- doesDirectoryExist "/etc/pki/tls" + if fedora + then do + SSL.contextSetCAFile ctx "/etc/pki/tls/certs/ca-bundle.crt" + else do + 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 = escapeURIString isAllowedInURI $ T.unpack $ T.decodeUtf8 r' + +------------------------------------------------------------------------------ + +{- + Account for bug where "http://www.example.com" is parsed with no + path element, resulting in an illegal HTTP request line. +-} + +pathFrom :: URI -> ByteString +pathFrom u = case url of + "" -> "/" + _ -> url + where + url = + 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. + +Throws 'TooManyRedirects' if more than 5 redirects are thrown. +-} +get :: + -- | Resource to GET from. + URL -> + -- | Handler function to receive the response from the server. + (Response -> InputStream ByteString -> IO β) -> + IO β +get r' handler = getN 0 r' handler + +getN n r' handler = do + bracket + (establish u) + (teardown) + (process) + where + teardown = closeConnection + + u = parseURL r' + + q = buildRequest1 $ do + http GET (pathFrom u) + setAccept "*/*" + + process c = do + sendRequest c q emptyBody + + receiveResponse c (wrapRedirect u 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 :: + URI -> + Int -> + (Response -> InputStream ByteString -> IO β) -> + Response -> + InputStream ByteString -> + IO β +wrapRedirect u n handler p i = do + if (s == 301 || s == 302 || s == 303 || s == 307) + then case lm of + Just l -> getN n' (splitURI u 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 + +splitURI :: URI -> URL -> URL +splitURI old new' = + let new = S.unpack new' + in if isAbsoluteURI new + then new' + else + let rel = parseRelativeReference new + in case rel of + Nothing -> new' + Just x -> + S.pack $ + uriToString + id + old + { uriPath = uriPath x + , uriQuery = uriQuery x + , uriFragment = uriFragment x + } + "" + +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 :: + -- | Resource to POST to. + URL -> + -- | MIME type of the request body being sent. + ContentType -> + -- | Handler function to write content to server. + (OutputStream Builder -> IO α) -> + -- | Handler function to receive the response from the server. + (Response -> InputStream ByteString -> IO β) -> + IO β +post r' t body handler = do + bracket + (establish u) + (teardown) + (process) + where + teardown = closeConnection + + u = parseURL r' + + q = buildRequest1 $ do + http POST (pathFrom u) + setAccept "*/*" + setContentType t + + process c = do + _ <- 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 :: + -- | Resource to POST to. + URL -> + -- | List of name=value pairs. Will be sent URL-encoded. + [(ByteString, ByteString)] -> + -- | Handler function to receive the response from the server. + (Response -> InputStream ByteString -> IO β) -> + IO β +postForm r' nvs handler = do + bracket + (establish u) + (teardown) + (process) + where + teardown = closeConnection + + u = parseURL r' + + q = buildRequest1 $ do + http POST (pathFrom u) + setAccept "*/*" + setContentType "application/x-www-form-urlencoded" + + process c = do + _ <- 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 (Builder.fromString "&") $ map combine nvs + + combine :: (ByteString, ByteString) -> Builder + combine (n', v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", urlEncodeBuilder v'] + +{- | +Build a list of parts into an upload body. + +You use this partially applied: + +> boundary <- randomBoundary +> +> let q = buildRequest1 $ do +> http POST "/api/v1/upload" +> setContentMultipart boundary +> +> let parts = +> [ simplePart "metadata" Nothing metadata +> , filePart "submission" (Just "audio/wav") filepath +> ] +> +> sendRequest c q (multipartFormBody boundary parts) + +You /must/ have called 'setContentMultipart' when forming the request or the +request body you are sending will be invalid and (obviously) you must pass in +that same 'Boundary' value when calling this function. +-} +multipartFormBody :: Boundary -> [Part] -> OutputStream Builder -> IO () +multipartFormBody boundary parts o = do + mapM_ handlePart parts + handleEnding + where + handlePart :: Part -> IO () + handlePart (Part field possibleContentType possibleFilename action) = do + let h' = composeMultipartBytes boundary field possibleFilename possibleContentType + Streams.write (Just h') o + action o + + handleEnding :: IO () + handleEnding = do + Streams.write (Just (composeMultipartEnding boundary)) o + +{- | +Information about each of the parts of a @multipart/form-data@ form upload. +Build these with 'simplePart', 'filePart', or 'inputStreamPart'. +-} +data Part = Part + { partFieldName :: FieldName + , partContentType :: Maybe ContentType + , partFilename :: Maybe FilePath + , partDataHandler :: OutputStream Builder -> IO () + } + +{- | +Given a simple static set of bytes, send them as a part in a multipart form +upload. You need to specify the name of the field for the form, and optionally +can supply a MIME content-type. +-} +simplePart :: FieldName -> Maybe ContentType -> ByteString -> Part +simplePart name possibleContentType x' = + let action o = do + i1 <- Streams.fromByteString x' + i2 <- Streams.map Builder.fromByteString i1 + Streams.supply i2 o + in Part name possibleContentType Nothing action + +{- | +The most common case in using multipart form data is to upload a file. Specify +the name of the field, optionally a MIME content-type, and then the path to +the file to be transmitted. The filename (without directory) will be used to +name the file to the server. +-} +filePart :: FieldName -> Maybe ContentType -> FilePath -> Part +filePart name possibleContentType path = + let action o = do + Streams.withFileAsInput + path + ( \i1 -> do + i2 <- Streams.map Builder.fromByteString i1 + Streams.supply i2 o + ) + + filename = takeFileName path + in Part name possibleContentType (Just filename) action + +{- | +Build a piece of a multipart submission from an 'InputStream'. You need to +specify a field name for this piece of the submission, and can optionally +indicate the MIME type and a filename (if what you are sending is going to be +interpreted as a file). +-} +inputStreamPart :: FieldName -> Maybe ContentType -> Maybe FilePath -> InputStream ByteString -> Part +inputStreamPart name possibleContentType possilbeFilename i1 = + let action o = do + i2 <- Streams.map Builder.fromByteString i1 + Streams.supply i2 o + in Part name possibleContentType possilbeFilename action + +{- | +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 :: + -- | Resource to PUT to. + URL -> + -- | MIME type of the request body being sent. + ContentType -> + -- | Handler function to write content to server. + (OutputStream Builder -> IO α) -> + -- | Handler function to receive the response from the server. + (Response -> InputStream ByteString -> IO β) -> + IO β +put r' t body handler = do + bracket + (establish u) + (teardown) + (process) + where + teardown = closeConnection + + u = parseURL r' + + q = buildRequest1 $ do + http PUT (pathFrom u) + setAccept "*/*" + setHeader "Content-Type" t + + process c = do + _ <- 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 +'HttpClientError' if the response status code was other than @2xx@. +-} +simpleHandler' :: Response -> InputStream ByteString -> IO ByteString +simpleHandler' p i = + if s >= 300 + then throw (HttpClientError s m) + else simpleHandler p i + where + s = getStatusCode p + m = getStatusMessage p + +concatHandler' :: Response -> InputStream ByteString -> IO ByteString +concatHandler' = simpleHandler' + +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. +-} + +{- | +If you've got an object of a type with a 'ToJSON' instance and you need to +send that object as JSON up to a web service API, this can help. + +You use this partially applied: + +> sendRequest c q (jsonBody thing) +-} +jsonBody :: ToJSON a => a -> OutputStream Builder -> IO () +jsonBody thing o = do + let b = Builder.fromLazyByteString (encode thing) + Streams.write (Just b) o + +{- | +If you're working with a data stream that is in @application/json@, +then chances are you're using @aeson@ to handle the JSON to Haskell +decoding. If so, then this helper function might be of use. + +> v <- get "http://api.example.com/v1/" jsonHandler + +This function feeds the input body to the 'Data.Aeson.Parser.json'' +@attoparsec@ Parser in order to get the aeson Value type. This is then +marshalled to your type represeting the source data, via the FromJSON +typeclass. + +The above example was actually insufficient; when working with +@aeson@ you need to fix the type so it knows what FromJSON instance +to use. Let's say you're getting Person objects, then it would be + +> v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person + +assuming your Person type had a FromJSON instance, of course. + +/Note/ + +This function parses a single top level JSON object or array, which +is all you're supposed to get if it's a valid document. People do +all kinds of crazy things though, so beware. Also, this function (like the +"concatHander" convenience) loads the entire response into memory; it's +not /streaming/; if you're receiving a document which is (say) a very +long array of objects then you may want to implement your own +handler function, perhaps using "Streams.parserToInputStream" and +the 'Data.Aeson.Parser' combinators directly — with a result type of +InputStream Value, perhaps — by which you could then iterate over +the Values one at a time in constant space. +-} + +{- + This looks simple. It wasn't. The types involved are rediculous to + disentangle. The biggest problem is that the Parser type used in + [aeson] is *NOT* the Parser type from [attoparsec]. But the parsing + function `json` and `json` from Aeson use the attoparsec Parser even + though the rest of the top level page is all about Aeson's parser as + used in FromJSON! + + Anyway, `json` and `json'` are [attoparsec] Parser [aeson] Value; we + run that using the [io-streams] convenience function + `parseFromStream` which gets us a Value which is the intermediate + abstract syntax tree for a JSON document. Then (and this was hard + to find) to work with that in terms of the FromJSON typeclass, you + use the `fromJSON` function which has type (FromJSON α => Value -> + Result α). Then finally, pull the result out of it. Why in Bog's + name this wasn't just Either I'll never know. +-} +jsonHandler :: + (FromJSON α) => + Response -> + InputStream ByteString -> + IO α +jsonHandler _ i = do + v <- Streams.parseFromStream json' i -- Value + let r = fromJSON v -- Result + case r of + (Success a) -> return a + (Error str) -> error str diff --git a/lib/Network/Http/ResponseParser.hs b/lib/Network/Http/ResponseParser.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/ResponseParser.hs @@ -0,0 +1,273 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2021 Athae Eredh Siniath and Others +-- +-- 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 CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide, not-home #-} + +module Network.Http.ResponseParser ( + readResponseHeader, + readResponseBody, + UnexpectedCompression (..), + -- for testing + readDecimal, +) where + +import Prelude hiding (take, takeWhile) + +import Control.Exception (Exception, throwIO) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Attoparsec.ByteString.Char8 +import Data.Bits (Bits (..)) +import Data.ByteString (ByteString) +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 (Generator, InputStream) +import qualified System.IO.Streams as Streams +import qualified System.IO.Streams.Attoparsec as Streams + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Network.Http.Internal +import Network.Http.Utilities + +{- + The chunk size coming down from the server is somewhat arbitrary; + it's really just an indication of how many bytes need to be read + before the next size marker or end marker - neither of which has + anything to do with streaming on our side. Instead, we'll feed + bytes into our InputStream at an appropriate intermediate size. +-} +__BITE_SIZE__ :: Int +__BITE_SIZE__ = 32 * 1024 + +{- + 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 + (sc, sm) <- Streams.parseFromStream parseStatusLine i + + hs <- readHeaderFields i + + let h = buildHeaders hs + let te = case lookupHeader h "Transfer-Encoding" of + Just x' -> + if mk x' == "chunked" + then Chunked + else None + Nothing -> None + + let ce = case lookupHeader h "Content-Encoding" of + Just x' -> + if mk x' == "gzip" + then Gzip + else Identity + Nothing -> Identity + + let nm = case lookupHeader h "Content-Length" of + Just x' -> Just (readDecimal x' :: Int64) + Nothing -> case sc of + 204 -> Just 0 + 304 -> Just 0 + 100 -> Just 0 + _ -> Nothing + + return + Response + { pStatusCode = sc + , pStatusMsg = sm + , pTransferEncoding = te + , pContentEncoding = ce + , pContentLength = nm + , pHeaders = h + } + +parseStatusLine :: Parser (Int, ByteString) +parseStatusLine = do + sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' ' + sm <- takeTill (== '\r') <* crlf + return (sc, sm) + where + version c = c == '1' || c == '0' + +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 t of + None -> case l of + Just n -> readFixedLengthBody i1 n + Nothing -> readUnlimitedBody i1 + Chunked -> readChunkedBody i1 + + i3 <- case c of + Identity -> return i2 + Gzip -> readCompressedBody i2 + Deflate -> throwIO (UnexpectedCompression $ show c) + + return i3 + where + t = pTransferEncoding p + c = pContentEncoding p + l = pContentLength p + +readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α +readDecimal str' = + S.foldl' f 0 x' + where + f !cnt !i = cnt * 10 + digitToInt i + + x' = head $ S.words str' + + {-# INLINE digitToInt #-} + digitToInt :: (Enum α, Num α, Bits α) => Char -> α + digitToInt c + | c >= '0' && c <= '9' = toEnum $! ord c - ord '0' + | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit" +{-# INLINE readDecimal #-} + +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.fromGenerator (consumeChunks i1) + return i2 + +{- + For a response body in chunked transfer encoding, iterate over + the individual chunks, reading the size parameter, then + looping over that chunk in bites of at most __BYTE_SIZE__, + yielding them to the receiveResponse InputStream accordingly. +-} +consumeChunks :: InputStream ByteString -> Generator ByteString () +consumeChunks i1 = do + !n <- parseSize + + if n > 0 + then do + -- read one or more bites, then loop to next chunk + go n + skipCRLF + consumeChunks i1 + else do + -- skip "trailers" and consume final CRLF + skipEnd + where + go 0 = return () + go !n = do + (!x', !r) <- liftIO $ readN n i1 + Streams.yield x' + go r + + parseSize = do + n <- liftIO $ Streams.parseFromStream transferChunkSize i1 + return n + + skipEnd = do + liftIO $ do + _ <- readHeaderFields i1 + return () + + skipCRLF = do + liftIO $ do + _ <- Streams.parseFromStream crlf i1 + return () + +{- + Read the specified number of bytes up to a maximum of __BITE_SIZE__, + returning a resultant ByteString and the number of bytes remaining. +-} + +readN :: Int -> InputStream ByteString -> IO (ByteString, Int) +readN n i1 = do + !x' <- Streams.readExactly p i1 + return (x', r) + where + !d = n - size + + !p = + if d > 0 + then size + else n + + !r = + if d > 0 + then d + else 0 + + size = __BITE_SIZE__ + +transferChunkSize :: Parser (Int) +transferChunkSize = do + !n <- hexadecimal + void (takeTill (== '\r')) + void crlf + return n + +--------------------------------------------------------------------- + +{- + 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 -> Int64 -> IO (InputStream ByteString) +readFixedLengthBody i1 n = do + i2 <- Streams.takeBytes n i1 + return i2 + +{- + On the other hand, there is the (predominently HTTP/1.0) case + where there is no content length sent and no chunking, with the + result that only the connection closing marks the end of the + response body. +-} +readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString) +readUnlimitedBody i1 = do + return i1 + +--------------------------------------------------------------------- + +readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString) +readCompressedBody i1 = do + i2 <- Streams.gunzip i1 + return i2 diff --git a/lib/Network/Http/Utilities.hs b/lib/Network/Http/Utilities.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Utilities.hs @@ -0,0 +1,269 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2021 Athae Eredh Siniath and Others +-- +-- The code in this file, and the program it is a part of, is +-- made available to you by its authors as open source software: +-- you can redistribute it and/or modify it under the terms of +-- the BSD licence. +-- +-- This file is essentially a clone of Snap.Internal.Parsing, +-- the HTTP request parser implementation in the Snap Framework; +-- snap-core's src/Snap/Internal/Parsing.hs and snap-server's +-- src/Snap/Internal/Http/Parser.hs, copied here to specialize +-- it to Response parsing. This code replaces the attoparsec +-- based implementation formerly in ResponseParser, but is +-- kept separate to aid syncing changes from snap-core as they +-- become available. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_HADDOCK hide, not-home #-} + +module Network.Http.Utilities ( + readResponseLine, + readHeaderFields, +) where + +------------------------------------------------------------------------------ +import Control.Exception (throwIO) +import Control.Monad (when) +import Data.Bits +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Internal (ByteString, w2c) +import qualified Data.ByteString.Unsafe as S +import Data.Char hiding (digitToInt, isDigit, isSpace) +import GHC.Exts (Int (..), Int#, (+#)) +import System.IO.Streams (InputStream) +import qualified System.IO.Streams as Streams +import Prelude hiding (head, take, takeWhile) + +---------------------------------------------------------------------------- + +import Network.Http.Types + +------------------------------------------------------------------------------ + +{- + This is vestigial; originally it was the Request parsing + code in Snap. Keeping it here until we can use if for + response parsing. +-} +parseRequest :: InputStream ByteString -> IO (Maybe Request) +parseRequest input = do + eof <- Streams.atEOF input + if eof + then return Nothing + else do + line <- readResponseLine input + let (!mStr, !s) = bSp line + let (!uri, !vStr) = bSp s + let !version = pVer vStr :: (Int, Int) + + -- hdrs <- readHeaderFields input + return $! Nothing + where + pVer s = + if "HTTP/" `S.isPrefixOf` s + then pVers (S.unsafeDrop 5 s) + else (1, 0) + + bSp = splitCh ' ' + + pVers s = (c, d) + where + (!a, !b) = splitCh '.' s + !c = unsafeFromNat a + !d = unsafeFromNat b + +{- + Read a single line of an HTTP response. +-} +readResponseLine :: InputStream ByteString -> IO ByteString +readResponseLine input = go [] + where + throwNoCRLF = + throwIO $ + HttpParseException "parse error: expected line ending in crlf" + + throwBadCRLF = + throwIO $ + HttpParseException "parse error: got cr without subsequent lf" + + go !l = do + !mb <- Streams.read input + !s <- maybe throwNoCRLF return mb + + case findCRLF s of + FoundCRLF idx# -> foundCRLF l s idx# + NoCR -> noCRLF l s + LastIsCR idx# -> lastIsCR l s idx# + _ -> throwBadCRLF + + foundCRLF l s idx# = do + let !i1 = (I# idx#) + let !i2 = (I# (idx# +# 2#)) + let !a = S.unsafeTake i1 s + when (i2 < S.length s) $ do + let !b = S.unsafeDrop i2 s + Streams.unRead b input + + -- Optimize for the common case: dl is almost always "id" + let !out = if null l then a else S.concat (reverse (a : l)) + return out + + noCRLF l s = go (s : l) + + lastIsCR l s idx# = do + !t <- Streams.read input >>= maybe throwNoCRLF return + if S.null t + then lastIsCR l s idx# + else do + let !c = S.unsafeHead t + if c /= 10 + then throwBadCRLF + else do + let !a = S.unsafeTake (I# idx#) s + let !b = S.unsafeDrop 1 t + when (not $ S.null b) $ Streams.unRead b input + let !out = if null l then a else S.concat (reverse (a : l)) + return out + +------------------------------------------------------------------------------ +data CS + = FoundCRLF !Int# + | NoCR + | LastIsCR !Int# + | BadCR + +------------------------------------------------------------------------------ +findCRLF :: ByteString -> CS +findCRLF b = + case S.elemIndex '\r' b of + Nothing -> NoCR + Just !i@(I# i#) -> + let !i' = i + 1 + in if i' < S.length b + then + if S.unsafeIndex b i' == 10 + then FoundCRLF i# + else BadCR + else LastIsCR i# +{-# INLINE findCRLF #-} + +------------------------------------------------------------------------------ +splitCh :: Char -> ByteString -> (ByteString, ByteString) +splitCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) + where + f !i = + let !a = S.unsafeTake i s + !b = S.unsafeDrop (i + 1) s + in (a, b) +{-# INLINE splitCh #-} + +------------------------------------------------------------------------------ +breakCh :: Char -> ByteString -> (ByteString, ByteString) +breakCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) + where + f !i = + let !a = S.unsafeTake i s + !b = S.unsafeDrop i s + in (a, b) +{-# INLINE breakCh #-} + +------------------------------------------------------------------------------ +splitHeader :: ByteString -> (ByteString, ByteString) +splitHeader !s = maybe (s, S.empty) f (S.elemIndex ':' s) + where + l = S.length s + + f i = + let !a = S.unsafeTake i s + in (a, skipSp (i + 1)) + + skipSp !i + | i >= l = S.empty + | otherwise = + let c = S.unsafeIndex s i + in if isLWS $ w2c c + then skipSp $ i + 1 + else S.unsafeDrop i s +{-# INLINE splitHeader #-} + +------------------------------------------------------------------------------ +isLWS :: Char -> Bool +isLWS c = c == ' ' || c == '\t' +{-# INLINE isLWS #-} + +------------------------------------------------------------------------------ + +{- + Read the remainder of the response message's header section, + parsing into key/value pairs. Note that this function terminates + when it hits the "blank" line (ie, CRLF CRLF pair), which it + consumes. +-} +readHeaderFields :: InputStream ByteString -> IO [(ByteString, ByteString)] +readHeaderFields input = do + f <- go id + return $! f [] + where + go !dlistSoFar = do + line <- readResponseLine input + if S.null line + then return dlistSoFar + else do + let (!k, !v) = splitHeader line + vf <- pCont id + let vs = vf [] + let !v' = if null vs then v else S.concat (v : vs) + let !t = (k, v') + go (dlistSoFar . (t :)) + where + trimBegin = S.dropWhile isLWS + + pCont !dlist = do + mbS <- Streams.peek input + maybe + (return dlist) + ( \s -> + if S.null s + then Streams.read input >> pCont dlist + else + if isLWS $ w2c $ S.unsafeHead s + then procCont dlist + else return dlist + ) + mbS + + procCont !dlist = do + line <- readResponseLine input + let !t = trimBegin line + pCont (dlist . (" " :) . (t :)) + +----------------------- +-- utility functions -- +----------------------- + +------------------------------------------------------------------------------ + +-- | Note: only works for nonnegative naturals +unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a +unsafeFromNat = S.foldl' f 0 + where + zero = ord '0' + f !cnt !i = cnt * 10 + toEnum (digitToInt i) + + digitToInt c = + if d >= 0 && d <= 9 + then d + else error $ "bad digit: '" ++ [c] ++ "'" + where + !d = ord c - zero +{-# INLINE unsafeFromNat #-} diff --git a/src/Network/Http/Client.hs b/src/Network/Http/Client.hs deleted file mode 100644 --- a/src/Network/Http/Client.hs +++ /dev/null @@ -1,176 +0,0 @@ --- --- 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: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > 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' $ do --- 'http' GET \"\/\" --- 'setAccept' \"text/html\" --- --- \ 'sendRequest' c q 'emptyBody' --- --- \ `receiveResponse` c (\\p i -> do --- xm <- Streams.read i --- case xm of --- Just x -> S.putStr x --- Nothing -> \"\") --- --- \ '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, - receiveResponseRaw, - StatusCode, - getStatusCode, - getStatusMessage, - getHeader, - debugHandler, - concatHandler, - concatHandler', - jsonHandler, - - -- * 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, - - -- * Testing support - makeConnection -) 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 deleted file mode 100644 --- a/src/Network/Http/Connection.hs +++ /dev/null @@ -1,585 +0,0 @@ --- --- 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, - getHostname, - sendRequest, - receiveResponse, - receiveResponseRaw, - 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 Data.Word (Word16) -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 = ByteString - -type Port = Word16 - --- | 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 Builder, - cIn :: InputStream ByteString - } - -instance Show Connection where - show c = {-# SCC "Connection.show" #-} - concat - ["Host: ", - S.unpack $ cHost c, - "\n"] - - --- --- | Create a raw Connection object from the given parts. This is --- primarily of use when teseting, for example: --- --- > fakeConnection :: IO Connection --- > fakeConnection = do --- > o <- Streams.nullOutput --- > i <- Streams.nullInput --- > c <- makeConnection "www.example.com" (return()) o i --- > return c --- --- is an idiom we use frequently in testing and benchmarking, usually --- replacing the InputStream with something like: --- --- > x' <- S.readFile "properly-formatted-response.txt" --- > i <- Streams.fromByteString x' --- --- If you're going to do that, keep in mind that you /must/ have CR-LF --- pairs after each header line and between the header and body to --- be compliant with the HTTP protocol; otherwise, parsers will --- reject your message. --- -makeConnection - :: ByteString - -- ^ will be used as the @Host:@ header in the HTTP request. - -> IO () - -- ^ an action to be called when the connection is terminated. - -> OutputStream ByteString - -- ^ write end of the HTTP client-server connection. - -> InputStream ByteString - -- ^ read end of the HTTP client-server connection. - -> IO Connection -makeConnection h c o1 i = do - o2 <- Streams.builderStream o1 - return $! Connection h c o2 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 $ 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 h1' p = do - is <- getAddrInfo (Just hints) (Just h1) (Just $ show p) - let addr = head is - let a = addrAddress addr - s <- socket (addrFamily addr) Stream defaultProtocol - - connect s a - (i,o1) <- Streams.socketToStreams s - - o2 <- Streams.builderStream o1 - - return Connection { - cHost = h2', - cClose = close s, - cOut = o2, - cIn = i - } - where - hints = defaultHints {addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV]} - h2' = if p == 80 - then h1' - else S.concat [ h1', ":", S.pack $ show p ] - h1 = S.unpack h1' - --- --- | Open a secure connection to a web server. --- --- 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 h1' p = do - is <- getAddrInfo Nothing (Just h1) (Just $ show p) - - let a = addrAddress $ head is - f = addrFamily $ head is - s <- socket f Stream defaultProtocol - - connect s a - - ssl <- SSL.connection ctx s - SSL.connect ssl - - (i,o1) <- Streams.sslToStreams ssl - - o2 <- Streams.builderStream o1 - - return Connection { - cHost = h2', - cClose = closeSSL s ssl, - cOut = o2, - cIn = i - } - where - h2' :: ByteString - h2' = if p == 443 - then h1' - else S.concat [ h1', ":", S.pack $ show p ] - h1 = S.unpack h1' - -closeSSL :: Socket -> SSL -> IO () -closeSSL s ssl = do - 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 (Builder.fromString "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 - -- 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 - o2 = cOut c - e = qBody q - t = qExpect q - msg = composeRequestBytes q h' - h' = cHost c - i = cIn c - rsp p = Builder.toByteString $ composeResponseBytes p - - --- --- | 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 :: Connection -> Request -> ByteString -getHostname c q = - case qHost q of - Just h' -> h' - Nothing -> cHost c - - --- --- | 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 i --- > 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 - --- --- | This is a specialized variant of 'receiveResponse' that /explicitly/ does --- not handle the content encoding of the response body stream (it will not --- decompress anything). Unless you really want the raw gzipped content coming --- down from the server, use @receiveResponse@. --- -{- - See notes at receiveResponse. --} -receiveResponseRaw :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β -receiveResponseRaw c handler = do - p <- readResponseHeader i - let p' = p { - pContentEncoding = Identity - } - - 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 $ 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 - S.putStr $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes 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 deleted file mode 100644 --- a/src/Network/Http/Inconvenience.hs +++ /dev/null @@ -1,573 +0,0 @@ --- --- 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', - jsonHandler, - - -- for testing - TooManyRedirects(..), - HttpClientError(..) -) where - -import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder as Builder (fromByteString, - fromWord8, toByteString) -import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString) -import Control.Exception (Exception, bracket, throw) -import Data.Aeson (FromJSON, Result (..), fromJSON, json') -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 (..), mappend) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Typeable (Typeable) -import Data.Word (Word16) -import GHC.Exts -import GHC.Word (Word8 (..)) -import Network.URI (URI (..), URIAuth (..), parseURI) -import OpenSSL.Session (SSLContext) -import qualified OpenSSL.Session as SSL -import System.IO.Streams (InputStream, OutputStream) -import qualified System.IO.Streams as Streams -import qualified System.IO.Streams.Attoparsec 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 `mappend` Builder.fromByteString x - esc (c,r) = let b'' = if c == ' ' - then b' `mappend` Builder.fromWord8 (c2w '+') - else b' `mappend` hexd c - in go b'' r - - -hexd :: Char -> Builder -hexd c0 = Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi - `mappend` 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 $ 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 = S.pack (uriRegName auth) - port = case uriPort auth of - "" -> 80 - _ -> read $ tail $ uriPort auth :: Word16 - ports = case uriPort auth of - "" -> 443 - _ -> read $ tail $ uriPort auth :: Word16 - - --- --- | 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 __WINDOWS__ - 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' - ------------------------------------------------------------------------------- - -{- - Account for bug where "http://www.example.com" is parsed with no - path element, resulting in an illegal HTTP request line. --} - -path :: URI -> ByteString -path u = case url of - "" -> "/" - _ -> url - where - url = 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 $ 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 $ 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 $ 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 (Builder.fromString "&") $ map combine nvs - - combine :: (ByteString,ByteString) -> Builder - combine (n',v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", 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 $ 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. --} - --- --- | If you're working with a data stream that is in @application/json@, --- then chances are you're using @aeson@ to handle the JSON to Haskell --- decoding. If so, then this helper function might be of use. --- --- > v <- get "http://api.example.com/v1/" jsonHandler --- --- This function feeds the input body to the 'Data.Aeson.Parser.json'' --- @attoparsec@ Parser in order to get the aeson Value type. This is then --- marshalled to your type represeting the source data, via the FromJSON --- typeclass. --- --- The above example was actually insufficient; when working with --- @aeson@ you need to fix the type so it knows what FromJSON instance --- to use. Let's say you're getting Person objects, then it would be --- --- > v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person --- --- assuming your Person type had a FromJSON instance, of course. --- --- /Note/ --- --- This function parses a single top level JSON object or array, which --- is all you're supposed to get if it's a valid document. People do --- all kinds of crazy things though, so beware. Also, this function (like the --- "concatHander" convenience) loads the entire response into memory; it's --- not /streaming/; if you're receiving a document which is (say) a very --- long array of objects then you may want to implement your own --- handler function, perhaps using "Streams.parserToInputStream" and --- the 'Data.Aeson.Parser' combinators directly — with a result type of --- InputStream Value, perhaps — by which you could then iterate over --- the Values one at a time in constant space. --- -{- - This looks simple. It wasn't. The types involved are rediculous to - disentangle. The biggest problem is that the Parser type used in - [aeson] is *NOT* the Parser type from [attoparsec]. But the parsing - function `json` and `json` from Aeson use the attoparsec Parser even - though the rest of the top level page is all about Aeson's parser as - used in FromJSON! - - Anyway, `json` and `json'` are [attoparsec] Parser [aeson] Value; we - run that using the [io-streams] convenience function - `parseFromStream` which gets us a Value which is the intermediate - abstract syntax tree for a JSON document. Then (and this was hard - to find) to work with that in terms of the FromJSON typeclass, you - use the `fromJSON` function which has type (FromJSON α => Value -> - Result α). Then finally, pull the result out of it. Why in Bog's - name this wasn't just Either I'll never know. --} -jsonHandler - :: (FromJSON α) - => Response - -> InputStream ByteString - -> IO α -jsonHandler _ i = do - v <- Streams.parseFromStream json' i -- Value - let r = fromJSON v -- Result - case r of - (Success a) -> return a - (Error str) -> error str - diff --git a/src/Network/Http/RequestBuilder.hs b/src/Network/Http/RequestBuilder.hs deleted file mode 100644 --- a/src/Network/Http/RequestBuilder.hs +++ /dev/null @@ -1,300 +0,0 @@ --- --- 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 CPP #-} -{-# 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, - fromString) -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.Int (Int64) -import Data.List (intersperse) -import Data.Monoid (mconcat) - -import Network.Http.Connection -import Network.Http.Types - -#include "config.h" - --- --- | 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 $ do --- > http POST "/api/v1/messages" --- > setContentType "application/json" --- > setHostname "clue.example.com" 80 --- > setAccept "text/html" --- > setHeader "X-WhoDoneIt" "The Butler" --- --- Obviously it's up to you to later actually /send/ JSON data. --- --- /Note/ --- --- The API of this function changed from version 0.3.1 to verison 0.4.0; --- the original requirement to pass a Connection object has been removed, --- thereby allowing you to build your Request before opening the --- connection to the web server. --- -buildRequest :: RequestBuilder α -> IO Request -buildRequest mm = do - let (RequestBuilder s) = (mm) - let q = Request { - qHost = Nothing, - 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" VERSION - let h2 = updateHeader h1 "Accept-Encoding" "gzip" - - let e = case m of - GET -> Empty - TRACE -> Empty - _ -> Chunking - - 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 :: Hostname -> Port -> RequestBuilder () -setHostname h' p = do - q <- get - put q { - qHost = Just v' - } - where - v' :: ByteString - v' = if p == 80 - then h' - else Builder.toByteString $ mconcat - [Builder.fromByteString h', - Builder.fromString ":", - Builder.fromShow p] - --- --- | 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 (Builder.fromString ", ") $ map format tqs - - format :: (ByteString,Float) -> Builder - format (t',q) = - mconcat - [Builder.fromByteString t', - Builder.fromString "; 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-originated 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 :: Int64 -> 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 deleted file mode 100644 --- a/src/Network/Http/ResponseParser.hs +++ /dev/null @@ -1,275 +0,0 @@ --- --- 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 - readDecimal -) where - -import Prelude hiding (take, takeWhile) - -import Control.Applicative -import Control.Exception (Exception, throwIO) -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) -import Data.Attoparsec.ByteString.Char8 -import Data.Bits (Bits (..)) -import Data.ByteString (ByteString) -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 (Generator, InputStream) -import qualified System.IO.Streams as Streams -import qualified System.IO.Streams.Attoparsec as Streams - -import Network.Http.Types -import Network.Http.Utilities - -{- - The chunk size coming down from the server is somewhat arbitrary; - it's really just an indication of how many bytes need to be read - before the next size marker or end marker - neither of which has - anything to do with streaming on our side. Instead, we'll feed - bytes into our InputStream at an appropriate intermediate size. --} -__BITE_SIZE__ :: Int -__BITE_SIZE__ = 32 * 1024 - - -{- - 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 - (sc,sm) <- Streams.parseFromStream parseStatusLine i - - hs <- readHeaderFields i - - let h = buildHeaders hs - let te = case lookupHeader h "Transfer-Encoding" of - Just x' -> if mk x' == "chunked" - then Chunked - else None - Nothing -> None - - let ce = case lookupHeader h "Content-Encoding" of - Just x' -> if mk x' == "gzip" - then Gzip - else Identity - Nothing -> Identity - - let nm = case lookupHeader h "Content-Length" of - Just x' -> Just (readDecimal x' :: Int64) - Nothing -> case sc of - 204 -> Just 0 - 304 -> Just 0 - 100 -> Just 0 - _ -> Nothing - - return Response { - pStatusCode = sc, - pStatusMsg = sm, - pTransferEncoding = te, - pContentEncoding = ce, - pContentLength = nm, - pHeaders = h - } - - -parseStatusLine :: Parser (Int,ByteString) -parseStatusLine = do - sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' ' - sm <- takeTill (== '\r') <* crlf - return (sc,sm) - where - version c = c == '1' || c == '0' - - -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 t of - None -> case l of - Just n -> readFixedLengthBody i1 n - Nothing -> readUnlimitedBody i1 - Chunked -> readChunkedBody i1 - - i3 <- case c of - Identity -> return i2 - Gzip -> readCompressedBody i2 - Deflate -> throwIO (UnexpectedCompression $ show c) - - return i3 - where - t = pTransferEncoding p - c = pContentEncoding p - l = pContentLength p - - -readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α -readDecimal str' = - S.foldl' f 0 x' - where - f !cnt !i = cnt * 10 + digitToInt i - - x' = head $ S.words str' - - {-# INLINE digitToInt #-} - digitToInt :: (Enum α, Num α, Bits α) => Char -> α - digitToInt c | c >= '0' && c <= '9' = toEnum $! ord c - ord '0' - | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit" -{-# INLINE readDecimal #-} - -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.fromGenerator (consumeChunks i1) - return i2 - - -{- - For a response body in chunked transfer encoding, iterate over - the individual chunks, reading the size parameter, then - looping over that chunk in bites of at most __BYTE_SIZE__, - yielding them to the receiveResponse InputStream accordingly. --} -consumeChunks :: InputStream ByteString -> Generator ByteString () -consumeChunks i1 = do - !n <- parseSize - - if n > 0 - then do - -- read one or more bites, then loop to next chunk - go n - skipCRLF - consumeChunks i1 - else do - -- skip "trailers" and consume final CRLF - skipEnd - - where - go 0 = return () - go !n = do - (!x',!r) <- liftIO $ readN n i1 - Streams.yield x' - go r - - parseSize = do - n <- liftIO $ Streams.parseFromStream transferChunkSize i1 - return n - - skipEnd = do - liftIO $ do - _ <- readHeaderFields i1 - return () - - skipCRLF = do - liftIO $ do - _ <- Streams.parseFromStream crlf i1 - return () - -{- - Read the specified number of bytes up to a maximum of __BITE_SIZE__, - returning a resultant ByteString and the number of bytes remaining. --} - -readN :: Int -> InputStream ByteString -> IO (ByteString, Int) -readN n i1 = do - !x' <- Streams.readExactly p i1 - return (x', r) - where - !d = n - size - - !p = if d > 0 - then size - else n - - !r = if d > 0 - then d - else 0 - - size = __BITE_SIZE__ - - -transferChunkSize :: Parser (Int) -transferChunkSize = do - !n <- hexadecimal - void (takeTill (== '\r')) - void crlf - return n - - ---------------------------------------------------------------------- - -{- - 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 -> Int64 -> IO (InputStream ByteString) -readFixedLengthBody i1 n = do - i2 <- Streams.takeBytes n i1 - return i2 - -{- - On the other hand, there is the (predominently HTTP/1.0) case - where there is no content length sent and no chunking, with the - result that only the connection closing marks the end of the - response body. --} -readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString) -readUnlimitedBody i1 = do - return i1 - - ---------------------------------------------------------------------- - -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 deleted file mode 100644 --- a/src/Network/Http/Types.hs +++ /dev/null @@ -1,387 +0,0 @@ --- --- 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 DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Http.Types ( - Request(..), - EntityBody(..), - ExpectMode(..), - Response(..), - StatusCode, - TransferEncoding(..), - ContentEncoding(..), - getStatusCode, - getStatusMessage, - getHeader, - Method(..), - Headers, - emptyHeaders, - updateHeader, - removeHeader, - buildHeaders, - lookupHeader, - HttpParseException(..), - - -- 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 (fromChar, - fromShow, - fromString) -import Control.Exception (Exception) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as S -import Data.CaseInsensitive (CI, mk, original) -import Data.HashMap.Strict (HashMap, delete, empty, foldrWithKey, insert, - insertWith, lookup) -import Data.Int (Int64) -import Data.List (foldl') -import Data.Monoid (mconcat, mempty) -import Data.Typeable (Typeable) - --- | 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. --- --- Note that the @Host:@ header is not set until --- 'Network.Http.Connection.sendRequest' is called, so you will not see --- it in the Show instance (unless you call 'setHostname' to override --- the value inherited from the @Connection@). --- -data Request - = Request { - qMethod :: !Method, - qHost :: !(Maybe 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 Int64 - -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 -> ByteString -> Builder -composeRequestBytes q h' = - mconcat - [requestline, - hostLine, - headerFields, - crlf] - where - requestline = mconcat - [method, - sp, - uri, - sp, - version, - crlf] - - method = case qMethod q of - GET -> Builder.fromString "GET" - HEAD -> Builder.fromString "HEAD" - POST -> Builder.fromString "POST" - PUT -> Builder.fromString "PUT" - DELETE -> Builder.fromString "DELETE" - TRACE -> Builder.fromString "TRACE" - OPTIONS -> Builder.fromString "OPTIONS" - CONNECT -> Builder.fromString "CONNECT" - PATCH -> Builder.fromString "PATCH" - (Method x) -> Builder.fromByteString x - - uri = Builder.copyByteString $ qPath q - - version = Builder.fromString "HTTP/1.1" - - hostLine = mconcat - [Builder.fromString"Host: ", - hostname, - crlf] - - hostname = case qHost q of - Just x' -> Builder.copyByteString x' - Nothing -> Builder.copyByteString h' - - headerFields = joinHeaders $ unWrap $ qHeaders q - - -crlf = Builder.fromString "\r\n" - -sp = Builder.fromChar ' ' - - -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, - pTransferEncoding :: !TransferEncoding, - pContentEncoding :: !ContentEncoding, - pContentLength :: !(Maybe Int64), - pHeaders :: !Headers - } - -instance Show Response where - show p = {-# SCC "Response.show" #-} - S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p - - -data TransferEncoding = None | Chunked - -data ContentEncoding = Identity | Gzip | Deflate - deriving (Show) - - --- --- | 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, - crlf] - where - statusline = mconcat - [version, - sp, - code, - sp, - message, - crlf] - - code = Builder.fromShow $ pStatusCode p - - message = Builder.copyByteString $ pStatusMsg p - - version = Builder.fromString "HTTP/1.1" - - headerFields = joinHeaders $ unWrap $ pHeaders p - - --- --- | 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, Builder.fromString ": ", value, crlf] - 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 = foldl' addHeader empty hs - -{- - insertWith is used here for the case where a header is repeated - (for example, Set-Cookie) and the values need to be intercalated - with ',' as per RFC 2616 §4.2. --} -addHeader - :: HashMap (CI ByteString) ByteString - -> (ByteString,ByteString) - -> HashMap (CI ByteString) ByteString -addHeader m (k,v) = - insertWith f (mk k) v m - where - f new old = S.concat [old, ",", new] - -lookupHeader :: Headers -> ByteString -> Maybe ByteString -lookupHeader x k = - lookup (mk k) m - where - !m = unWrap x - - -data HttpParseException = HttpParseException String - deriving (Typeable, Show) - -instance Exception HttpParseException diff --git a/src/Network/Http/Utilities.hs b/src/Network/Http/Utilities.hs deleted file mode 100644 --- a/src/Network/Http/Utilities.hs +++ /dev/null @@ -1,272 +0,0 @@ --- --- HTTP client for use with io-streams --- --- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd --- --- The code in this file, and the program it is a part of, is --- made available to you by its authors as open source software: --- you can redistribute it and/or modify it under the terms of --- the BSD licence. --- --- This file is essentially a clone of Snap.Internal.Parsing, --- the HTTP request parser implementation in the Snap Framework; --- snap-core's src/Snap/Internal/Parsing.hs and snap-server's --- src/Snap/Internal/Http/Parser.hs, copied here to specialize --- it to Response parsing. This code replaces the attoparsec --- based implementation formerly in ResponseParser, but is --- kept separate to aid syncing changes from snap-core as they --- become available. --- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE UnboxedTuples #-} - -module Network.Http.Utilities ( - readResponseLine, - readHeaderFields -) where - ------------------------------------------------------------------------------- -import Control.Exception (throwIO) -import Control.Monad (when) -import Data.Bits -import qualified Data.ByteString.Char8 as S -import Data.ByteString.Internal (ByteString, w2c) -import qualified Data.ByteString.Unsafe as S -import Data.Char hiding (digitToInt, isDigit, isSpace) -import GHC.Exts (Int (..), Int#, (+#)) -import Prelude hiding (head, take, takeWhile) -import System.IO.Streams (InputStream) -import qualified System.IO.Streams as Streams ----------------------------------------------------------------------------- - -import Network.Http.Types - ------------------------------------------------------------------------------- - -{- - This is vestigial; originally it was the Request parsing - code in Snap. Keeping it here until we can use if for - response parsing. --} -parseRequest :: InputStream ByteString -> IO (Maybe Request) -parseRequest input = do - eof <- Streams.atEOF input - if eof - then return Nothing - else do - line <- readResponseLine input - let (!mStr,!s) = bSp line - let (!uri, !vStr) = bSp s - let !version = pVer vStr :: (Int,Int) - --- hdrs <- readHeaderFields input - return $! Nothing - - where - - pVer s = if "HTTP/" `S.isPrefixOf` s - then pVers (S.unsafeDrop 5 s) - else (1, 0) - - bSp = splitCh ' ' - - pVers s = (c, d) - where - (!a, !b) = splitCh '.' s - !c = unsafeFromNat a - !d = unsafeFromNat b - - -{- - Read a single line of an HTTP response. --} -readResponseLine :: InputStream ByteString -> IO ByteString -readResponseLine input = go [] - where - throwNoCRLF = - throwIO $ - HttpParseException "parse error: expected line ending in crlf" - - throwBadCRLF = - throwIO $ - HttpParseException "parse error: got cr without subsequent lf" - - go !l = do - !mb <- Streams.read input - !s <- maybe throwNoCRLF return mb - - case findCRLF s of - FoundCRLF idx# -> foundCRLF l s idx# - NoCR -> noCRLF l s - LastIsCR idx# -> lastIsCR l s idx# - _ -> throwBadCRLF - - foundCRLF l s idx# = do - let !i1 = (I# idx#) - let !i2 = (I# (idx# +# 2#)) - let !a = S.unsafeTake i1 s - when (i2 < S.length s) $ do - let !b = S.unsafeDrop i2 s - Streams.unRead b input - - -- Optimize for the common case: dl is almost always "id" - let !out = if null l then a else S.concat (reverse (a:l)) - return out - - noCRLF l s = go (s:l) - - lastIsCR l s idx# = do - !t <- Streams.read input >>= maybe throwNoCRLF return - if S.null t - then lastIsCR l s idx# - else do - let !c = S.unsafeHead t - if c /= 10 - then throwBadCRLF - else do - let !a = S.unsafeTake (I# idx#) s - let !b = S.unsafeDrop 1 t - when (not $ S.null b) $ Streams.unRead b input - let !out = if null l then a else S.concat (reverse (a:l)) - return out - - ------------------------------------------------------------------------------- -data CS = FoundCRLF !Int# - | NoCR - | LastIsCR !Int# - | BadCR - - ------------------------------------------------------------------------------- -findCRLF :: ByteString -> CS -findCRLF b = - case S.elemIndex '\r' b of - Nothing -> NoCR - Just !i@(I# i#) -> - let !i' = i + 1 - in if i' < S.length b - then if S.unsafeIndex b i' == 10 - then FoundCRLF i# - else BadCR - else LastIsCR i# -{-# INLINE findCRLF #-} - - ------------------------------------------------------------------------------- -splitCh :: Char -> ByteString -> (ByteString, ByteString) -splitCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) - where - f !i = let !a = S.unsafeTake i s - !b = S.unsafeDrop (i + 1) s - in (a, b) -{-# INLINE splitCh #-} - - ------------------------------------------------------------------------------- -breakCh :: Char -> ByteString -> (ByteString, ByteString) -breakCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) - where - f !i = let !a = S.unsafeTake i s - !b = S.unsafeDrop i s - in (a, b) -{-# INLINE breakCh #-} - - ------------------------------------------------------------------------------- -splitHeader :: ByteString -> (ByteString, ByteString) -splitHeader !s = maybe (s, S.empty) f (S.elemIndex ':' s) - where - l = S.length s - - f i = let !a = S.unsafeTake i s - in (a, skipSp (i + 1)) - - skipSp !i | i >= l = S.empty - | otherwise = let c = S.unsafeIndex s i - in if isLWS $ w2c c - then skipSp $ i + 1 - else S.unsafeDrop i s - -{-# INLINE splitHeader #-} - - - ------------------------------------------------------------------------------- -isLWS :: Char -> Bool -isLWS c = c == ' ' || c == '\t' -{-# INLINE isLWS #-} - - ------------------------------------------------------------------------------- - -{- - Read the remainder of the response message's header section, - parsing into key/value pairs. Note that this function terminates - when it hits the "blank" line (ie, CRLF CRLF pair), which it - consumes. --} -readHeaderFields :: InputStream ByteString -> IO [(ByteString,ByteString)] -readHeaderFields input = do - f <- go id - return $! f [] - - where - go !dlistSoFar = do - line <- readResponseLine input - if S.null line - then return dlistSoFar - else do - let (!k,!v) = splitHeader line - vf <- pCont id - let vs = vf [] - let !v' = if null vs then v else S.concat (v:vs) - let !t = (k,v') - go (dlistSoFar . (t:)) - - where - trimBegin = S.dropWhile isLWS - - pCont !dlist = do - mbS <- Streams.peek input - maybe (return dlist) - (\s -> if S.null s - then Streams.read input >> pCont dlist - else if isLWS $ w2c $ S.unsafeHead s - then procCont dlist - else return dlist) - mbS - - procCont !dlist = do - line <- readResponseLine input - let !t = trimBegin line - pCont (dlist . (" ":) . (t:)) - - - - ----------------------- - -- utility functions -- - ----------------------- - - ------------------------------------------------------------------------------- --- | Note: only works for nonnegative naturals -unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a -unsafeFromNat = S.foldl' f 0 - where - zero = ord '0' - f !cnt !i = cnt * 10 + toEnum (digitToInt i) - - digitToInt c = if d >= 0 && d <= 9 - then d - else error $ "bad digit: '" ++ [c] ++ "'" - where - !d = ord c - zero -{-# INLINE unsafeFromNat #-} diff --git a/tests/Check.hs b/tests/Check.hs deleted file mode 100644 --- a/tests/Check.hs +++ /dev/null @@ -1,25 +0,0 @@ --- --- 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 #-} - -module Main where - -import OpenSSL (withOpenSSL) -import Test.Hspec (hspec) - -import MockServer (runMockServer) -import TestSuite (suite) - -main :: IO () -main = withOpenSSL $ do - runMockServer - hspec suite diff --git a/tests/MockServer.hs b/tests/MockServer.hs new file mode 100644 --- /dev/null +++ b/tests/MockServer.hs @@ -0,0 +1,306 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2021 Athae Eredh Siniath and Others +-- +-- The code in this file, and the program it is a part of, is made +-- available to you by its authors as open source software: you can +-- redistribute it and/or modify it under a BSD licence. +-- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +{-# OPTIONS -fno-warn-dodgy-imports #-} + +module MockServer (runMockServer, localPort) where + +{- + Per http://hackage.haskell.org/trac/ghc/ticket/7167, we suppress + the warning resulting from this line, necessary on <7.6 +-} +import Prelude hiding (catch) + +import Control.Applicative +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (SomeException) +import Control.Exception.Lifted (catch) +import "mtl" Control.Monad.Trans (liftIO) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Maybe (fromMaybe) +import System.Directory (getFileSize) +import Snap.Core +import Snap.Http.Server +import Snap.Util.FileServe +import System.IO (hFlush, hPutStrLn, stderr) + +import Network.Http.Client (Hostname, Port) + +localHost = "localhost" :: Hostname +localPort = 56981 :: Port + +main :: IO () +main = go + +{- + Binding the port to the IPv4 localhost appears to settle the problem + of localhost resolving ambigiously. If that doesn't work, we can + comment out the setBind and the resultant 0.0.0.0 does seem to work. +-} +go :: IO () +go = httpServe c site + where + c = + setAccessLog ConfigNoLog $ + setErrorLog ConfigNoLog $ + setHostname localHost $ + setBind localHost $ + setPort (fromIntegral localPort) $ + setVerbose False emptyConfig + +runMockServer :: IO () +runMockServer = do + _ <- forkIO go + threadDelay 2000000 + return () + +-- +-- Top level URL routing logic. +-- + +site :: Snap () +site = + catch + (routeRequests) + (\e -> serveError "Splat\n" e) + +routeRequests :: Snap () +routeRequests = + route + [ ("resource/:id", serveResource) + , ("static/:id", method GET serveStatic) + , ("time", serveTime) + , ("", ifTop handleAsText) + , ("bounce", serveRedirect) + , ("local", serveLocalRedirect) + , ("loop", serveRedirectEndlessly) + , ("empty", serveWithoutContent) + , ("postbox", method POST handlePostMethod) + , ("size", handleSizeRequest) + , ("api", handleRestfulRequest) + , ("cookies", serveRepeatedResponseHeaders) + ] + <|> serveNotFound + +serveResource :: Snap () +serveResource = do + r <- getRequest + + let m = rqMethod r + case m of + GET -> handleGetMethod + PUT -> handlePutWithExpectation + _ -> serveMethodNotAllowed + +serveStatic :: Snap () +serveStatic = do + im' <- getParam "id" + + let i' = fromMaybe "" im' + let f' = S.concat ["tests/", i'] + let f = S.unpack f' + + l <- liftIO $ getFileSize f + + let t = fileType defaultMimeTypes f + modifyResponse $ setContentType t + modifyResponse $ setContentLength $ fromIntegral l + b' <- liftIO $ S.readFile f + writeBS b' + +serveTime :: Snap () +serveTime = do + writeBS "Sun 30 Dec 12, 05:39:56.746Z\n" + +-- +-- Dispatch normal GET requests based on MIME type. +-- + +handleGetMethod :: Snap () +handleGetMethod = do + r <- getRequest + let mime0 = getHeader "Accept" r + + case mime0 of + Just "text/html" -> handleAsBrowser + _ -> handleAsText + +handleAsBrowser :: Snap () +handleAsBrowser = do + modifyResponse $ setResponseStatus 200 "OK" + modifyResponse $ setContentType "text/html; charset=UTF-8" + modifyResponse $ setHeader "Cache-Control" "max-age=1" + sendFile "tests/hello.html" + +handleAsText :: Snap () +handleAsText = do + modifyResponse $ setContentType "text/plain" + writeBS "Sounds good to me\n" + +handleRestfulRequest :: Snap () +handleRestfulRequest = do + modifyResponse $ setResponseStatus 200 "OK" + modifyResponse $ setContentType "application/json" + + sendFile "tests/data-eu-gdp.json" + +serveRedirect :: Snap () +serveRedirect = do + modifyResponse $ setResponseStatus 307 "Temporary Redirect" + modifyResponse $ setHeader "Cache-Control" "no-cache" + modifyResponse $ setHeader "Location" r' + where + r' = S.concat ["http://", localHost, ":", S.pack $ show $ localPort, "/time"] + +serveLocalRedirect :: Snap () +serveLocalRedirect = do + modifyResponse $ setResponseStatus 307 "Temporary Redirect" + modifyResponse $ setHeader "Cache-Control" "no-cache" + modifyResponse $ setHeader "Location" r' + where + r' = S.pack "/time" + +serveRedirectEndlessly :: Snap () +serveRedirectEndlessly = do + modifyResponse $ setResponseStatus 307 "Temporary Redirect" + modifyResponse $ setHeader "Cache-Control" "no-cache" + modifyResponse $ setHeader "Location" r' + where + r' = S.concat ["http://", localHost, ":", S.pack $ show $ localPort, "/loop"] + +{- + Attempt to test the bug with 204 No Content not closing in absence of a + Content-Length header, however Snap automatically adds one, it seems. So, + after the fact, this is unused and the case is tested in + TestServer.testDevoidOfContent. +-} + +serveWithoutContent :: Snap () +serveWithoutContent = do + modifyResponse $ setResponseStatus 204 "No Content" + modifyResponse $ setHeader "Cache-Control" "no-cache" + +serveRepeatedResponseHeaders :: Snap () +serveRepeatedResponseHeaders = do + modifyResponse $ addHeader "Set-Cookie" "stone=diamond" + modifyResponse $ addHeader "Set-Cookie" "metal=tungsten" + +handlePostMethod :: Snap () +handlePostMethod = do + setTimeout 5 + modifyResponse $ setResponseStatus 201 "Created" + modifyResponse $ setHeader "Cache-Control" "no-cache" + modifyResponse $ setHeader "Location" "http://server.example.com/something/788" + modifyResponse $ setContentType "text/plain" + + b' <- readRequestBody 1024 + writeLBS b' + +handlePutWithExpectation :: Snap () +handlePutWithExpectation = do + setTimeout 5 + modifyResponse $ setResponseStatus 201 "Created" + modifyResponse $ setHeader "Cache-Control" "no-cache" + modifyResponse $ setContentType "text/plain" + + b' <- readRequestBody 1024 + writeLBS b' + +handleSizeRequest :: Snap () +handleSizeRequest = do + r <- getRequest + let mm = getHeader "Content-Type" r + + t <- case mm of + Just m -> return m + _ -> do + serveUnsupported + return "" + + modifyResponse $ setResponseStatus 200 "OK" + modifyResponse $ setContentType t + + b' <- readRequestBody 65536 + writeBS $ S.pack $ show $ L.length b' + +updateResource :: Snap () +updateResource = do + bs' <- readRequestBody 4096 + let b' = fromLazy bs' + + im' <- getParam "id" + let i' = fromMaybe "0" im' + + -- TODO something + + modifyResponse $ setResponseStatus 204 "Updated" -- "No Content" + modifyResponse $ setHeader "Cache-Control" "no-cache" + modifyResponse $ setContentLength 0 + return () + where + fromLazy ls' = S.concat $ L.toChunks ls' + +serveNotFound :: Snap a +serveNotFound = do + modifyResponse $ setResponseStatus 404 "Not Found" + modifyResponse $ setHeader "Content-Type" "text/html" + + writeBS "404 Not Found" + + r <- getResponse + finishWith r + +serveBadRequest :: Snap () +serveBadRequest = do + modifyResponse $ setResponseStatus 400 "Bad Request" + writeBS "400 Bad Request\n" + +serveMethodNotAllowed :: Snap () +serveMethodNotAllowed = do + modifyResponse $ setResponseStatus 405 "Method Not Allowed" + modifyResponse $ setHeader "Allow" "GET, POST, PUT" + + writeBS "405 Method Not Allowed\n" + r <- getResponse + finishWith r + +serveUnsupported :: Snap () +serveUnsupported = do + modifyResponse $ setResponseStatus 415 "Unsupported Media Type" + writeBS "415 Unsupported Media Type\n" + r <- getResponse + finishWith r + +-- +-- The exception will be dumped to the server's stdout, while the supplied +-- message will be sent out with the response (ideally only for debugging +-- purposes, but easier than looking in log/error.log for details). +-- + +serveError :: ByteString -> SomeException -> Snap () +serveError x' e = do + debug msg + modifyResponse $ setResponseStatus 500 "Internal Server Error" + writeBS x' + r <- getResponse + finishWith r + where + msg = show (e :: SomeException) + +debug :: String -> Snap () +debug cs = do + liftIO $ do + hPutStrLn stderr "" + hPutStrLn stderr cs + hFlush stderr diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,857 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2021 Athae Eredh Siniath and Others +-- +-- 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 CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS -fno-warn-unused-imports #-} + +module TestSuite where + +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as Builder ( + fromByteString, + toByteString, + ) +import qualified Blaze.ByteString.Builder.Char8 as Builder ( + fromChar, + fromString, + ) +import Control.Applicative +import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Exception (Exception, bracket, handleJust) +import Control.Monad (forM_, guard) +import Data.Aeson ( + FromJSON, + ToJSON, + Value (..), + encode, + object, + parseJSON, + toJSON, + (.:), + (.=), + ) +import Data.Aeson.Encode.Pretty +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KeyMap +#else +import qualified Data.HashMap.Strict as KeyMap +#endif +import Data.Bits +import Data.Maybe (fromJust) +import Data.Monoid +import Data.String +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import GHC.Generics hiding (Selector) +import Network.Socket (SockAddr (..)) +import Network.URI (URI (..), URIAuth (..), parseURI) +import System.Timeout (timeout) +import Test.HUnit +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Expectations (Selector, anyException, shouldThrow) + +import Debug.Trace + +-- +-- Otherwise redundent imports, but useful for testing in GHCi. +-- + +import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly, parseTest) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy as L +import Debug.Trace +import System.IO.Streams (InputStream, OutputStream) +import qualified System.IO.Streams as Streams +import qualified System.IO.Streams.Debug as Streams + +-- +-- what we're actually testing +-- + +import MockServer (localPort) +import Network.Http.Client +import Network.Http.Connection (Connection (..)) +import Network.Http.Inconvenience ( + HttpClientError (..), + TooManyRedirects (..), + parseURL, + splitURI, + ) +import Network.Http.Internal ( + Request (..), + Response (..), + composeRequestBytes, + lookupHeader, + ) +import Network.Http.ResponseParser (readDecimal, readResponseHeader) + +localhost = S.pack ("localhost:" ++ show localPort) + +suite :: Spec +suite = do + describe "Opening a connection" $ do + testConnectionHost + + describe "Request, when serialized" $ do + testRequestLineFormat + testRequestTermination + testEnsureHostField + testAcceptHeaderFormat + testBasicAuthorizatonHeader + + describe "Parsing responses" $ do + testResponseParser1 + testResponseParserMismatch + testPaddedContentLength + -- testTrailingWhitespace + testChunkedEncoding + testContentLength + testDevoidOfContent + testCompressedResponse + testRepeatedResponseHeaders + + describe "Expectation handling" $ do + testExpectationContinue + + describe "Convenience API" $ do + testPutChunks + testPostChunks + testPostWithForm + testGetRedirects + testSplitURI + testParseURL + testParseURLHasEscaped + testGetLocalRedirects + testGetFormatsRequest + testExcessiveRedirects + testGeneralHandler + testEstablishConnection + testParsingJson1 + testParsingJson2 + testPutWithSimple + testPutWithJson + testMultipartUpload + + describe "Corner cases in protocol compliance" $ do + testSendBodyFor PUT + testSendBodyFor DELETE + testSendBodyFor PATCH + +testRequestTermination = + it "terminates with a blank line" $ do + c <- openConnection "localhost" localPort + let q = buildRequest1 $ do + http GET "/time" + setAccept "text/plain" + + let e' = Builder.toByteString $ composeRequestBytes q "booga" + let n = S.length e' - 4 + let (a', b') = S.splitAt n e' + + assertEqual "Termination not CRLF CRLF" "\r\n\r\n" b' + assertBool + "Must be only one blank line at end of headers" + ('\n' /= S.last a') + + closeConnection c + +testRequestLineFormat = do + it "has a properly formatted request line" $ + bracket + (fakeConnection) + (return) + ( \c -> do + let q = buildRequest1 $ do + http GET "/time" + + let e' = Builder.toByteString $ composeRequestBytes q (cHost c) + let l' = S.takeWhile (/= '\r') e' + + assertEqual "Invalid HTTP request line" "GET /time HTTP/1.1" l' + ) + + it "handles empty request path" $ + bracket + (fakeConnection) + (return) + ( \c -> do + let q = buildRequest1 $ do + http GET "" + + let e' = Builder.toByteString $ composeRequestBytes q (cHost c) + let l' = S.takeWhile (/= '\r') e' + + assertEqual "Invalid HTTP request line" "GET / HTTP/1.1" l' + ) + +fakeConnection :: IO Connection +fakeConnection = do + i <- Streams.nullInput + o <- Streams.nullOutput + c <- makeConnection "www.example.com" (return ()) o i + return c + +testAcceptHeaderFormat = + it "properly formats Accept header" $ do + let q = buildRequest1 $ do + setAccept' [("text/html", 1), ("*/*", 0.0)] + + let h = qHeaders q + let (Just a) = lookupHeader h "Accept" + assertEqual "Failed to format header" "text/html; q=1.0, */*; q=0.0" a + +testBasicAuthorizatonHeader = + it "properly formats Authorization header" $ do + let q = buildRequest1 $ do + setAuthorizationBasic "Aladdin" "open sesame" + + let h = qHeaders q + let (Just a) = lookupHeader h "Authorization" + assertEqual "Failed to format header" "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" a + +testConnectionHost = do + it "properly caches hostname and port" $ do + bracket + (openConnection "localhost" localPort) + closeConnection + ( \c -> do + let h' = cHost c + assertEqual + "Host value needs to be name, not IP address" + expected + h' + ) + where + expected = S.pack $ "localhost:" ++ show localPort + +{- + Incidentally, Host is *not* stored in the Headers map, but is a field + of the Request object. +-} +testEnsureHostField = + it "has a properly formatted Host header" $ do + let q1 = buildRequest1 $ do + http GET "/hello.txt" + + let h1 = qHost q1 + assertEqual "Incorrect Host header" Nothing h1 + + let q2 = buildRequest1 $ do + http GET "/hello.txt" + setHostname "other.example.com" 80 + + let h2 = qHost q2 + assertEqual "Incorrect Host header" (Just "other.example.com") h2 + + let q3 = buildRequest1 $ do + http GET "/hello.txt" + setHostname "other.example.com" 54321 + + let h3 = qHost q3 + assertEqual "Incorrect Host header" (Just "other.example.com:54321") h3 + +testResponseParser1 = + it "parses a simple 200 response" $ do + p <- Streams.withFileAsInput "tests/example1.txt" (\i -> readResponseHeader i) + + assertEqual "Incorrect parse of response" 200 (getStatusCode p) + return () + +testResponseParserMismatch = + it "parses response when HTTP version doesn't match" $ do + p <- Streams.withFileAsInput "tests/example3.txt" (\i -> readResponseHeader i) + + assertEqual "Incorrect parse of response" 200 (getStatusCode p) + return () + +testPaddedContentLength = + it "handles padded Content-Length" $ do + p <- Streams.withFileAsInput "tests/example4.txt" (\i -> readResponseHeader i) + + let (Just len) = pContentLength p + assertEqual "Should have trimmed in decimal conversion" 86 len + +{- + Presently inactive +-} +testTrailingWhitespace = + it "where headers have trailing whitespace" $ do + p <- Streams.withFileAsInput "tests/example4.txt" (\i -> readResponseHeader i) + + let (Just value) = getHeader p "Content-Length" + assertEqual "Should have trimmed field value" "86" value + +testChunkedEncoding = + it "recognizes chunked transfer encoding and decodes" $ do + c <- openConnection "localhost" localPort + + let q = buildRequest1 $ do + http GET "/time" + + sendRequest c q emptyBody + receiveResponse + c + ( \p i1 -> do + let cm = getHeader p "Transfer-Encoding" + assertEqual "Should be chunked encoding!" (Just "chunked") cm + + (i2, getCount) <- Streams.countInput i1 + Streams.skipToEof i2 + + len <- getCount + assertEqual "Incorrect number of bytes read" 29 len + ) + +testContentLength = do + it "recognzies fixed length message" $ do + c <- openConnection "localhost" localPort + + let q = buildRequest1 $ do + http GET "/static/statler.jpg" + + sendRequest c q emptyBody + + receiveResponse + c + ( \p i1 -> do + let nm = getHeader p "Content-Length" + assertMaybe "Should be a Content-Length header!" nm + + let n = read $ S.unpack $ fromJust nm :: Int + assertEqual "Should be a fixed length message!" 4611 n + + (i2, getCount) <- Streams.countInput i1 + x' <- Streams.readExactly 4611 i2 + + len <- getCount + assertEqual "Incorrect number of bytes read" 4611 len + assertBool "Incorrect length" (4611 == S.length x') + + end <- Streams.atEOF i2 + assertBool "Expected end of stream" end + ) + + it "doesn't choke if server neglects Content-Length" $ do + p <- Streams.withFileAsInput "tests/example3.txt" (\i -> readResponseHeader i) + + assertEqual "Incorrect parse of response" 200 (getStatusCode p) + assertEqual "Incorrect parse of response" Nothing (getHeader p "Content-Length") + assertEqual "Should not have pContentLength" Nothing (pContentLength p) + return () + + it "reads body without Content-Length or Transfer-Encoding" $ do + c <- fakeConnectionHttp10 + let q = buildRequest1 $ do + http GET "/fake" + sendRequest c q emptyBody + receiveResponse + c + ( \_ i1 -> do + (i2, getCount) <- Streams.countInput i1 + o <- Streams.nullOutput + Streams.connect i2 o + + end <- Streams.atEOF i2 + assertBool "Expected end of stream" end + + len <- getCount + assertEqual "Incorrect number of bytes read" 4611 len + ) + + return () + +fakeConnectionHttp10 :: IO Connection +fakeConnectionHttp10 = do + x' <- S.readFile "tests/example3.txt" + i <- Streams.fromByteString x' + + o <- Streams.nullOutput + c <- makeConnection "bad.example.com" (return ()) o i + return c + +{- + Corner case where servers responding 204 No Content are not required to + transmit a Content-Length header; Snap *does* send one, so we can't test it + in the MockServer, so fake it with example5.txt +-} + +testDevoidOfContent = do + it "handles 204 No Content response without Content-Length" $ + timeout_ 2 $ do + (c, mv) <- fakeConnectionNoContent + let q = buildRequest1 $ do + http GET "/fake" + sendRequest c q emptyBody + receiveResponse + c + ( \_ i1 -> do + (i2, getCount) <- Streams.countInput i1 + o <- Streams.nullOutput + Streams.connect i2 o + + end <- Streams.atEOF i2 + assertBool "Expected end of stream" end + + len <- getCount + assertEqual "Incorrect number of bytes read" 0 len + ) + putMVar mv () + return () + where + secs :: Int + secs = 10 ^ (6 :: Int) + + timeout_ :: Int -> IO a -> IO a + timeout_ t m = timeout (t * secs) m >>= maybe (error "timeout") return + +fakeConnectionNoContent :: IO (Connection, MVar ()) +fakeConnectionNoContent = do + x' <- S.readFile "tests/example5.txt" + i1 <- Streams.fromByteString x' + mv <- newEmptyMVar + i2 <- Streams.makeInputStream $ blockOn mv + i3 <- Streams.concatInputStreams [i1, i2] + + o <- Streams.nullOutput + c <- makeConnection "worse.example.com" (return ()) o i3 + return (c, mv) + where + blockOn :: MVar () -> IO (Maybe ByteString) + blockOn mv = takeMVar mv >> return Nothing + +{- + This had to change when we moved to an internal test server; seems + Snap is doing something funny when gzipping and switching to chunked + encoding no matter what I do. +-} +testCompressedResponse = + it "recognizes gzip content encoding and decompresses" $ do + c <- openConnection "localhost" localPort + + let q = buildRequest1 $ do + http GET "/static/hello.html" + setHeader "Accept-Encoding" "gzip" + + sendRequest c q emptyBody + + receiveResponse + c + ( \p i -> do + let nm = getHeader p "Content-Encoding" + assertMaybe "Should be a Content-Encoding header!" nm + assertEqual "Content-Encoding header should be 'gzip'!" (Just "gzip") nm + + (i2, getCount) <- Streams.countInput i + x' <- Streams.readExactly 102 i2 + + len <- getCount + assertEqual "Incorrect number of bytes read" 102 len + assertBool "Incorrect length" (102 == S.length x') + + end <- Streams.atEOF i + assertBool "Expected end of stream" end + ) + +{- + This isn't much of a test yet; we really need to test + a) that 100 Continue was received b) that it was absorbed + c) that body is correct size, and then d) 4xx and 5xx + responses are propegated through. +-} + +testExpectationContinue = + it "sends expectation and handles 100 response" $ do + c <- openConnection "localhost" localPort + + let q = buildRequest1 $ do + http PUT "/resource/x149" + setExpectContinue + + sendRequest + c + q + ( \o -> do + Streams.write (Just (Builder.fromString "Hello world\n")) o + ) + + receiveResponse + c + ( \p i -> do + assertEqual "Incorrect status code" 201 (getStatusCode p) + x' <- Streams.readExactly 12 i + + end <- Streams.atEOF i + assertBool "Expected end of stream" end + + assertEqual "Incorrect body" "Hello world\n" x' + ) + + closeConnection c + +assertMaybe :: String -> Maybe a -> Assertion +assertMaybe prefix m0 = + case m0 of + Nothing -> assertFailure prefix + Just _ -> assertBool "" True + +testPutChunks = + it "PUT correctly chunks known size entity body" $ do + let url = S.concat ["http://", localhost, "/size"] + + put url "text/plain" body handler + where + body :: OutputStream Builder -> IO () + body o = do + let x = mconcat $ replicate 33000 (Builder.fromChar 'x') + Streams.write (Just x) o + + handler :: Response -> InputStream ByteString -> IO () + handler _ i = do + (Just b') <- Streams.read i + + end <- Streams.atEOF i + assertBool "Expected end of stream" end + + let size = readDecimal b' :: Int + assertEqual "Should have replied with correct file size" 33000 size + +testSendBodyFor meth = + it ("Sends a request body for " ++ show meth) $ do + c <- openConnection "localhost" localPort + + let q = buildRequest1 $ do + http meth "/size" + setContentType "text/plain" + setTransferEncoding + + sendRequest + c + q + ( \o -> do + Streams.write (Just (Builder.fromString "a request")) o + ) + + receiveResponse + c + ( \p i -> do + assertEqual "Incorrect status code" 200 (getStatusCode p) + (Just b') <- Streams.read i + + let size = readDecimal b' :: Int + assertEqual "Should have received a request body" 9 size + ) + + closeConnection c + +testPostChunks = + it "POST correctly chunks a fileBody" $ do + let url = S.concat ["http://", localhost, "/size"] + + post url "image/jpeg" (fileBody "tests/statler.jpg") handler + where + handler :: Response -> InputStream ByteString -> IO () + handler p i = do + let code = getStatusCode p + assertEqual "Expected 200 OK" 200 code + + (Just b') <- Streams.read i + + end <- Streams.atEOF i + assertBool "Expected end of stream" end + + let size = readDecimal b' :: Int + assertEqual "Should have replied with correct file size" 4611 size + +testPostWithForm = + it "POST with form data correctly encodes parameters" $ do + let url = S.concat ["http://", localhost, "/postbox"] + + postForm + url + [ ("name", "Kermit") + , ("role", "St&gehand") + , ("country", Text.encodeUtf8 $ Text.pack "Nørway") + ] + handler + where + handler :: Response -> InputStream ByteString -> IO () + handler p i = do + let code = getStatusCode p + assertEqual "Expected 201" 201 code + + b' <- Streams.readExactly 48 i + + end <- Streams.atEOF i + assertBool "Expected end of stream" end + + assertEqual + "Incorrect URL encoding" + "name=Kermit&role=St%26gehand&country=N%c3%b8rway" + b' + +testGetRedirects = + it "GET internal handler follows redirect on 307" $ do + let url = S.concat ["http://", localhost, "/bounce"] + + get url handler + where + handler :: Response -> InputStream ByteString -> IO () + handler p i1 = do + let code = getStatusCode p + assertEqual "Should have been final code" 200 code + + (i2, getCount) <- Streams.countInput i1 + Streams.skipToEof i2 + + len <- getCount + assertEqual "Incorrect number of bytes read" 29 len + +testGetLocalRedirects = + it "GET internal handler follows local redirect on 307" $ do + let url = S.concat ["http://", localhost, "/local"] + + get url handler + where + handler :: Response -> InputStream ByteString -> IO () + handler p i1 = do + let code = getStatusCode p + assertEqual "Should have been final code" 200 code + + (i2, getCount) <- Streams.countInput i1 + Streams.skipToEof i2 + + len <- getCount + assertEqual "Incorrect number of bytes read" 29 len + +testSplitURI = + it "check splitURI for local redirects" $ do + let a1 = "http://asdf@ya.ru:8000/hello/?asd=asd&abc=2" + r1 = S.pack "/hello/?asd=asd&abc=2" + assertEqual "Incorrect split uri 1" (S.pack a1) (splitURI (fromJust $ parseURI a1) r1) + + let a2 = "http://asdf@ya.ru:8000/again/?asd=asd&abc=2" + r2 = S.pack "/again/?asd=asd&abc=2" + assertEqual "Incorrect split uri 2" (S.pack a2) (splitURI (fromJust $ parseURI a2) r2) + + let a3 = "http://ya.ru:8000/here/?asd=asd&abc=2" + r3 = S.pack "/here/?asd=asd&abc=2" + assertEqual "Incorrect split uri 3" (S.pack a3) (splitURI (fromJust $ parseURI a3) r3) + + let a4 = "http://ya.ru/?asd=asd&abc=2#papa" + r4 = S.pack "/?asd=asd&abc=2#papa" + assertEqual "Incorrect split uri 4" (S.pack a4) (splitURI (fromJust $ parseURI a4) r4) + + let a5 = "http://ya.ru/?asd=asd&abc=2#papa" + r5 = S.pack "http://google.ru/" + assertEqual "Incorrect split uri 5" r5 (splitURI (fromJust $ parseURI a5) r5) + +testParseURL = + it "Parse URL with chars needing encoding" $ do + let url = parseURL (Text.encodeUtf8 $ Text.pack "http://example.com/α") + assertEqual + "Incorrect URL parsing" + (URI "http:" (Just $ URIAuth "" "example.com" "") "/%CE%B1" "" "") + url + +testParseURLHasEscaped = + it "Parse URL with chars already encoded" $ do + let url = parseURL (Text.encodeUtf8 $ Text.pack "http://example.com/hello%20world") + assertEqual + "Incorrect URL parsing" + (URI "http:" (Just $ URIAuth "" "example.com" "") "/hello%20world" "" "") + url + +testGetFormatsRequest = + it "GET includes a properly formatted request path" $ do + let url = S.concat ["http://", localhost] + x' <- get url concatHandler' + + assertBool "Incorrect context path" (S.length x' > 0) + +testExcessiveRedirects = + it "too many redirects result in an exception" $ do + let url = S.concat ["http://", localhost, "/loop"] + + get url handler `shouldThrow` tooManyRedirects + where + handler :: Response -> InputStream ByteString -> IO () + handler _ _ = do + assertBool "Should have thrown exception before getting here" False + +testRepeatedResponseHeaders = + it "repeated response headers are properly concatonated" $ do + let url = S.concat ["http://", localhost, "/cookies"] + + get url handler + where + handler :: Response -> InputStream ByteString -> IO () + handler r _ = do + assertEqual "Invalid response headers" (Just "stone=diamond,metal=tungsten") (getHeader r "Set-Cookie") + +{- + From http://stackoverflow.com/questions/6147435/is-there-an-assertexception-in-any-of-the-haskell-test-frameworks + because "although HUnit doesn't have this, it's easy to write your + own". Uh huh. Surely there's an easier way to do this. +-} + +assertException :: (Exception e, Eq e) => e -> IO a -> IO () +assertException ex action = + handleJust isWanted (const $ return ()) $ do + _ <- action + assertFailure $ "Expected exception: " ++ show ex + where + isWanted = guard . (== ex) + +testGeneralHandler = + it "GET with general purpose handler throws exception on 404" $ do + let url = S.concat ["http://", localhost, "/booga"] + + get url concatHandler' `shouldThrow` httpClientError 404 + +tooManyRedirects :: Selector TooManyRedirects +tooManyRedirects = const True + +-- :: Int -> Selector HttpClientError +httpClientError :: Int -> HttpClientError -> Bool +httpClientError expected (HttpClientError actual _) = expected == actual + +testEstablishConnection = + it "public establish function behaves correctly" $ do + let url = S.concat ["http://", localhost, "/static/statler.jpg"] + + x' <- + withConnection (establishConnection url) $ + ( \c -> do + let q = buildRequest1 $ do + http GET "/static/statler.jpg" + -- TODO be nice if we could replace that with 'url'; + -- fix the routeRequests function in TestServer maybe? + sendRequest c q emptyBody + receiveResponse c concatHandler' + ) + + let len = S.length x' + assertEqual "Incorrect number of bytes read" 4611 len + +testParsingJson1 = + it "GET with JSON handler behaves" $ do + let url = S.concat ["http://", localhost, "/static/data-eu-gdp.json"] + + x <- get url jsonHandler + let (Object o) = x + let (Just v) = KeyMap.lookup "label" o + let (String t) = v + + assertEqual "Incorrect response" "Europe (EU27)" t + +testParsingJson2 = + it "GET with JSON handler parses using Aeson" $ do + let url = S.concat ["http://", localhost, "/static/data-jp-gdp.json"] + + x <- get url jsonHandler :: IO GrossDomesticProduct + + assertEqual "Incorrect response" "Japan" (gLabel x) + assertEqual "Data not parsed as expected" 2008 (fst $ last $ gData x) + +-- L.putStr $ encodePretty x + +{- + Go to the trouble to create a Haskell data type representing the JSON feed + we're getting from the sample data files. The Generic trick doesn't work + because data is a reserved word, of course. +-} + +data GrossDomesticProduct = GrossDomesticProduct + { gLabel :: Text + , gData :: [(Int, Double)] + } + deriving (Show, Generic) + +instance FromJSON GrossDomesticProduct where + parseJSON (Object o) = + GrossDomesticProduct + <$> o .: "label" + <*> o .: "data" + parseJSON _ = undefined + +instance ToJSON GrossDomesticProduct where + toJSON (GrossDomesticProduct l d) = + object + [ "label" .= l + , "data" .= d + ] + +testPutWithSimple = + it "PUT with static data" $ do + let url = S.concat ["http://", localhost, "/resource/y98"] + + x' <- put url "text/plain" (simpleBody b') simpleHandler + + assertEqual + "Object was encoded to JSON as expected" + "Hello" + x' + where + b' :: ByteString + b' = S.pack "Hello" + +testPutWithJson = + it "PUT with json data" $ do + let url = S.concat ["http://", localhost, "/resource/y99"] + + x' <- put url "application/json" (jsonBody obj) simpleHandler + + assertEqual + "Object was encoded to JSON as expected" + "{\"data\":[[2000,1],[2020,0]],\"label\":\"Sealand\"}" + x' + where + obj :: GrossDomesticProduct + obj = + GrossDomesticProduct + { gLabel = "Sealand" + , gData = [(2000, 1), (2020, 0)] + } + + obj' :: ByteString + obj' = L.toStrict (encode obj) + +testMultipartUpload = + it "PUT with json data" $ do + let url = S.concat ["http://", localhost, "/postbox"] + + let boundary = packBoundary "bEacHV0113YB@ll" + + let q = buildRequest1 $ do + http POST "/postbox" + setContentMultipart boundary + + let parts = + [ simplePart "first" Nothing "Old guys in the box." + , filePart "second" (Just "text/plain") "tests/hello.txt" + ] + + c <- openConnection "localhost" localPort + + sendRequest c q (multipartFormBody boundary parts) + + result <- receiveResponse c simpleHandler + + closeConnection c + + expected <- S.readFile "tests/multipart.bin" + assertEqual + "Multipart form data was not encoded as expected" + expected + result diff --git a/tests/check.hs b/tests/check.hs new file mode 100644 --- /dev/null +++ b/tests/check.hs @@ -0,0 +1,25 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd +-- +-- The code in this file, and the program it is a part of, is made +-- available to you by its authors as open source software: you can +-- redistribute it and/or modify it under a BSD licence. +-- + +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-unused-imports #-} + +module Main where + +import OpenSSL (withOpenSSL) +import Test.Hspec (hspec) + +import MockServer (runMockServer) +import TestSuite (suite) + +main :: IO () +main = withOpenSSL $ do + runMockServer + hspec suite diff --git a/tests/data-eu-gdp.json b/tests/data-eu-gdp.json new file mode 100644 --- /dev/null +++ b/tests/data-eu-gdp.json @@ -0,0 +1,4 @@ +{ + "label": "Europe (EU27)", + "data": [[1999, 3.0], [2000, 3.9], [2001, 2.0], [2002, 1.2], [2003, 1.3], [2004, 2.5], [2005, 2.0], [2006, 3.1], [2007, 2.9], [2008, 0.9]] +} diff --git a/tests/data-jp-gdp.json b/tests/data-jp-gdp.json new file mode 100644 --- /dev/null +++ b/tests/data-jp-gdp.json @@ -0,0 +1,4 @@ +{ + "label": "Japan", + "data": [[1999, -0.1], [2000, 2.9], [2001, 0.2], [2002, 0.3], [2003, 1.4], [2004, 2.7], [2005, 1.9], [2006, 2.0], [2007, 2.3], [2008, -0.7]] +} diff --git a/tests/data-us-gdp.json b/tests/data-us-gdp.json new file mode 100644 --- /dev/null +++ b/tests/data-us-gdp.json @@ -0,0 +1,4 @@ +{ + "label": "USA", + "data": [[1999, 4.4], [2000, 3.7], [2001, 0.8], [2002, 1.6], [2003, 2.5], [2004, 3.6], [2005, 2.9], [2006, 2.8], [2007, 2.0], [2008, 1.1]] +} diff --git a/tests/example1.txt b/tests/example1.txt new file mode 100644 --- /dev/null +++ b/tests/example1.txt @@ -0,0 +1,6 @@ +HTTP/1.1 200 OK +Content-Type: text/plain +Content-Length: 10 + +Hi there. + diff --git a/tests/example2.txt b/tests/example2.txt new file mode 100644 --- /dev/null +++ b/tests/example2.txt @@ -0,0 +1,17 @@ +HTTP/1.1 200 OK +Content-Type: text/html; charset=UTF-8 +Server: Apache/2.2.22 +Expires: Fri, 04 Jan 2013 06:48:57 GMT +Date: Fri, 04 Jan 2013 06:48:56 GMT +Content-Length: 133 +Cache-Control: max-age=1 + + + +Hello + + +

Hello!

+

Hello world. □

+ + diff --git a/tests/example3.txt b/tests/example3.txt new file mode 100644 Binary files /dev/null and b/tests/example3.txt differ diff --git a/tests/example4.txt b/tests/example4.txt new file mode 100644 --- /dev/null +++ b/tests/example4.txt @@ -0,0 +1,6 @@ +HTTP/1.1 200 OK +Content-Type: text/plain +Content-Length: 86 + +This is an HTTP response with a header that has trailing whitespace. Bad +server, Bad! diff --git a/tests/example5.txt b/tests/example5.txt new file mode 100644 --- /dev/null +++ b/tests/example5.txt @@ -0,0 +1,3 @@ +HTTP/1.1 204 No Content +Server: Ye Plain Olde Text File + diff --git a/tests/hello.html b/tests/hello.html new file mode 100644 --- /dev/null +++ b/tests/hello.html @@ -0,0 +1,9 @@ + + +Hello + + +

Hello!

+

Hello world.

+ + diff --git a/tests/hello.txt b/tests/hello.txt new file mode 100644 --- /dev/null +++ b/tests/hello.txt @@ -0,0 +1,1 @@ +Hello World diff --git a/tests/multipart.bin b/tests/multipart.bin new file mode 100644 --- /dev/null +++ b/tests/multipart.bin @@ -0,0 +1,12 @@ + +--bEacHV0113YB@ll +Content-Disposition: form-data; name="first" + +Old guys in the box. +--bEacHV0113YB@ll +Content-Disposition: form-data; name="second"; filename="hello.txt" +Content-Type: text/plain + +Hello World + +--bEacHV0113YB@ll-- diff --git a/tests/statler.jpg b/tests/statler.jpg new file mode 100644 Binary files /dev/null and b/tests/statler.jpg differ