http-streams 0.8.5.3 → 0.8.9.9
raw patch · 16 files changed
Files
- CHANGELOG.markdown +0/−27
- CHANGELOG.md +37/−0
- LICENCE +0/−32
- LICENSE +30/−0
- README.markdown +0/−68
- README.md +57/−0
- Setup.hs +1/−63
- http-streams.cabal +30/−35
- lib/Network/Http/Client.hs +18/−3
- lib/Network/Http/Connection.hs +419/−388
- lib/Network/Http/Inconvenience.hs +441/−308
- lib/Network/Http/ResponseParser.hs +53/−60
- lib/Network/Http/Utilities.hs +108/−110
- tests/MockServer.hs +36/−55
- tests/TestSuite.hs +377/−241
- tests/multipart.bin +12/−0
− CHANGELOG.markdown
@@ -1,27 +0,0 @@-* _v0.8.4_ - Support GHC 8.--* _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
+ CHANGELOG.md view
@@ -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
− LICENCE
@@ -1,32 +0,0 @@-An HTTP client for use with io-streams--Copyright © 2012-2017 Operational Dynamics Consulting, Pty Ltd 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.
+ LICENSE view
@@ -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.
− README.markdown
@@ -1,68 +0,0 @@-An HTTP client-==============--An HTTP client library for Haskell using the Snap Framework's-[io-streams](https://github.com/snapframework/io-streams) library to-handle the streaming IO.-<!-- replace with link to hackage when it is released -->--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 wep 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. There's also a [blog-post](http://blogs.operationaldynamics.com/andrew/software/haskell/http-streams-introduction)-introducing the library with a discussion of the design and usage.--Change Log-------------Now included in separate file [CHANGELOG](CHANGELOG.markdown).--AfC-
+ README.md view
@@ -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.
Setup.hs view
@@ -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
http-streams.cabal view
@@ -1,12 +1,10 @@-cabal-version: >= 1.10+cabal-version: 1.24 name: http-streams-version: 0.8.5.3+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,22 +12,23 @@ for full documentation. license: BSD3-license-file: LICENCE-author: Andrew Cowie <andrew@operationaldynamics.com>-maintainer: Andrew Cowie <andrew@operationaldynamics.com>-copyright: © 2012-2017 Operational Dynamics Consulting, Pty Ltd and Others+license-file: LICENSE+author: Andrew Cowie <istathar@gmail.com>+maintainer: Andrew Cowie <istathar@gmail.com>+copyright: © 2012-2023 Athae Eredh Siniath and Others category: Web, IO-Streams-tested-with: GHC == 8.0.2+tested-with: GHC == 8.10.7, GHC == 9.2.7, GHC == 9.4.5 stability: experimental-homepage: http://github.com/afcowie/http-streams/-bug-reports: https://github.com/afcowie/http-streams/issues-extra-source-files: README.markdown CHANGELOG.markdown+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@@ -38,11 +37,7 @@ tests/hello.txt tests/hello.html -build-type: Custom--custom-setup- setup-depends: base >= 4,- Cabal+build-type: Simple flag network-uri description: Get Network.URI from the network-uri package@@ -52,32 +47,34 @@ default-language: Haskell2010 build-depends: attoparsec,- base >= 4 && <5,+ base >= 4.5 && <5, directory, base64-bytestring, blaze-builder >= 0.4, bytestring, case-insensitive,- io-streams >= 1.3 && < 1.5,- HsOpenSSL >= 0.10.3.5,+ filepath,+ io-streams >= 1.3 && < 1.6,+ HsOpenSSL >= 0.11.2, openssl-streams >= 1.1 && < 1.4, mtl, transformers, text, unordered-containers,- aeson,- http-common >= 0.8.2+ 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: lib- exposed-modules: Network.Http.Client- other-modules: Network.Http.Connection,+ exposed-modules: Network.Http.Client,+ Network.Http.Connection, Network.Http.ResponseParser,- Network.Http.Utilities, Network.Http.Inconvenience+ other-modules: Network.Http.Utilities ghc-options: -Wall -Wwarn@@ -118,23 +115,21 @@ network >= 2.6, network-uri >= 2.6, openssl-streams >= 1.1 && < 1.4,- snap-core >= 1.0 && < 1.1,- snap-server >= 1.0 && < 1.1,- system-fileio >= 0.3.10 && < 0.4,- system-filepath >= 0.4.1 && < 0.5,+ random,+ snap-core >= 1.0 && < 1.2,+ snap-server >= 1.1 && < 1.2, text, unordered-containers, aeson, http-common >= 0.8.2,- http-streams >= 0.8.5+ http-streams - hs-source-dirs: lib,tests+ hs-source-dirs: tests main-is: check.hs other-modules: TestSuite MockServer - ghc-options: -O2- -threaded+ ghc-options: -threaded -Wall -Wwarn -fwarn-tabs@@ -148,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:
lib/Network/Http/Client.hs view
@@ -1,7 +1,7 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- 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:@@ -116,6 +116,10 @@ ContentType, setContentType, setContentLength,+ FieldName,+ Boundary,+ randomBoundary,+ setContentMultipart, setExpectContinue, setTransferEncoding, setHeader,@@ -126,21 +130,29 @@ 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,- concatHandler,- concatHandler',+ simpleHandler,+ simpleHandler', HttpClientError(..), jsonHandler, @@ -176,8 +188,11 @@ Headers, getHeaders, getHeadersFull,+ packBoundary, -- * Deprecated+ concatHandler,+ concatHandler', getRequestHeaders ) where
lib/Network/Http/Connection.hs view
@@ -1,22 +1,22 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- 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 CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide, not-home #-} module Network.Http.Connection (- Connection(..),- -- constructors only for testing+ Connection (..),+ -- constructors only for testing makeConnection, withConnection, openConnection,@@ -29,17 +29,23 @@ sendRequest, receiveResponse, receiveResponseRaw,+ unsafeReceiveResponse, UnexpectedCompression, emptyBody,+ simpleBody, fileBody, inputStreamBody, debugHandler,- concatHandler+ simpleHandler,+ concatHandler, ) where import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (flush, fromByteString,- toByteString)+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)@@ -59,114 +65,112 @@ import Network.Http.Internal import Network.Http.ResponseParser ------ | 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+{- |+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" #-}+ show c =+ {-# SCC "Connection.show" #-} concat- ["Host: ",- S.unpack $ cHost c,- "\n"]+ [ "Host: "+ , S.unpack $ cHost c+ , "\n"+ ] +{- |+Create a raw Connection object from the given parts. This is+primarily of use when teseting, for example: ------ | 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+> 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. ------ | 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'.---+> 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. ------ | 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.---+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)@@ -175,56 +179,59 @@ s <- socket (addrFamily addr) Stream defaultProtocol connect s a- (i,o1) <- Streams.socketToStreams s+ (i, o1) <- Streams.socketToStreams s o2 <- Streams.builderStream o1 - return Connection {- cHost = h2',- cClose = close s,- cOut = o2,- cIn = i- }+ return+ Connection+ { cHost = h2'+ , cClose = close s+ , cOut = o2+ , cIn = i+ } where- hints = defaultHints {- addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV],- addrSocketType = Stream- }- h2' = if p == 80- then h1'- else S.concat [ h1', ":", S.pack $ show p ]- h1 = S.unpack h1'+ 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/---+{- |+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)@@ -239,72 +246,76 @@ SSL.setTlsextHostName ssl h1 SSL.connect ssl - (i,o1) <- Streams.sslToStreams ssl+ (i, o1) <- Streams.sslToStreams ssl o2 <- Streams.builderStream o1 - return Connection {- cHost = h2',- cClose = closeSSL s ssl,- cOut = o2,- cIn = i- }+ 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'+ 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---+{- |+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+ (i, o1) <- Streams.socketToStreams s o2 <- Streams.builderStream o1 - return Connection {- cHost = path',- cClose = close s,- cOut = o2,- cIn = i- }+ return+ Connection+ { cHost = path'+ , cClose = close s+ , cOut = o2+ , cIn = i+ } where- path' = S.pack path+ 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)---+{- |+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,@@ -321,20 +332,19 @@ e2 <- case t of Normal -> do return e- Continue -> do Streams.write (Just Builder.flush) o2 - p <- readResponseHeader i+ 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+ -- ok to send+ return e+ _ -> do+ -- put the response back+ Streams.unRead (rsp p) i+ return Empty -- write the body, if there is one @@ -343,25 +353,21 @@ o3 <- Streams.nullOutput y <- handler o3 return y-- Chunking -> do+ Chunking -> do o3 <- Streams.contramap Builder.chunkedTransferEncoding o2- y <- handler o3+ y <- handler o3 Streams.write (Just Builder.chunkedTransferTerminator) o2 return y- (Static _) -> do--- o3 <- Streams.giveBytes (fromIntegral n :: Int64) o2- y <- handler o2+ -- 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@@ -371,20 +377,18 @@ 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.---+{- |+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 =@@ -393,54 +397,55 @@ 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)]---+{- |+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 = 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.---+{- |+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.@@ -452,10 +457,10 @@ -} receiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β receiveResponse c handler = do- p <- readResponseHeader i+ p <- readResponseHeader i i' <- readResponseBody p i - x <- handler p i'+ x <- handler p i' Streams.skipToEof i' @@ -463,25 +468,27 @@ 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@.---+{- |+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- }+ p <- readResponseHeader i+ let p' =+ p+ { pContentEncoding = Identity+ } i' <- readResponseBody p' i - x <- handler p i'+ x <- handler p i' Streams.skipToEof i' @@ -489,29 +496,55 @@ 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 ------ | Use this for the common case of the HTTP methods that only send--- headers and which have no entity body, i.e. 'GET' requests.---+ 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 ()---+{- |+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.@@ -520,21 +553,21 @@ 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. ------ | 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.---+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@@ -545,104 +578,102 @@ 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: ------ | 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.---+> 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: ------ | 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.+> ...+> 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. -}-concatHandler :: Response -> InputStream ByteString -> IO ByteString-concatHandler _ i1 = do+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.---+{- |+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
lib/Network/Http/Inconvenience.hs view
@@ -1,20 +1,20 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- 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 BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide, not-home #-} module Network.Http.Inconvenience ( URL,@@ -24,25 +24,35 @@ post, postForm, encodedFormBody,+ multipartFormBody,+ Part,+ simplePart,+ filePart,+ inputStreamPart, put, baselineContextSSL,+ simpleHandler', concatHandler',+ jsonBody, jsonHandler,- TooManyRedirects(..),- HttpClientError(..),-- -- for testing- splitURI+ TooManyRedirects (..),+ HttpClientError (..),+ -- for testing+ splitURI,+ parseURL, ) where -#include "config.h"- import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (fromByteString,- fromWord8, toByteString)+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 (..), fromJSON, json')+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@@ -58,11 +68,20 @@ import Data.Word (Word16) import GHC.Exts import GHC.Word (Word8 (..))-import Network.URI (URI (..), URIAuth (..), isAbsoluteURI,- parseRelativeReference, parseURI, uriToString)+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@@ -73,64 +92,70 @@ #endif import Network.Http.Connection+import Network.Http.Internal import Network.Http.RequestBuilder-import Network.Http.Types -#if defined __LINUX__ || defined __FREEBSD__+-- (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--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)---+{- |+URL-escapes a string (see+<http://tools.ietf.org/html/rfc2396.html#section-2.4>)+-} urlEncode :: ByteString -> URL urlEncode = Builder.toByteString . urlEncodeBuilder {-# INLINE urlEncode #-} ------- | URL-escapes a string (see--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.---+{- |+URL-escapes a string (see+<http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.+-} urlEncodeBuilder :: ByteString -> Builder urlEncodeBuilder = go mempty where go !b !s = maybe b' esc (S.uncons y) where- (x,y) = S.span (flip HashSet.member urlEncodeTable) s- b' = b `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-+ (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+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#))+ !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]+urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0 .. 255] where- f c | c >= 'A' && c <= 'Z' = True+ f c+ | c >= 'A' && c <= 'Z' = True | c >= 'a' && c <= 'z' = True | c >= '0' && c <= '9' = True- f c = c `elem` ("$-_.!~*'(),"::String)-+ f c = c `elem` ("$-_.!~*'()," :: String) ------------------------------------------------------------------------------ @@ -140,7 +165,7 @@ 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+ contortions are necessary to allow the library to be used for https:// URLs *without* requiring the developer to do 'withOpenSSL'. -} global :: IORef SSLContext@@ -149,35 +174,35 @@ 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'.---+{- |+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--- > ...---+{- |+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@@ -188,44 +213,45 @@ establish :: URI -> IO (Connection) establish u = case scheme of- "http:" -> do- openConnection host port- "https:" -> withOpenSSL $ do- ctx <- readIORef global- openConnectionSSL ctx host ports- "unix:" -> do- openConnectionUnix $ uriPath u- _ -> error ("Unknown URI scheme " ++ scheme)+ "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+ Just x -> x Nothing -> URIAuth "" "localhost" "" host = S.pack (uriRegName auth) port = case uriPort auth of- "" -> 80- _ -> read $ tail $ uriPort auth :: Word16+ "" -> 80+ _ -> read $ tail $ uriPort auth :: Word16 ports = case uriPort auth of- "" -> 443- _ -> read $ tail $ uriPort auth :: Word16+ "" -> 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. ------ | 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'.---+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@@ -233,16 +259,19 @@ hsopenssl, but feel free to change this as appropriate for your OS. -} baselineContextSSL :: IO SSLContext-baselineContextSSL = do+baselineContextSSL = withOpenSSL $ do ctx <- SSL.context SSL.contextSetDefaultCiphers ctx-#if defined __MACOSX__+#if defined(darwin_HOST_OS) SSL.contextSetVerificationMode ctx SSL.VerifyNone-#elif defined __WINDOWS__+#elif defined(mingw32_HOST_OS) SSL.contextSetVerificationMode ctx SSL.VerifyNone-#elif defined __FREEBSD__+#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@@ -254,14 +283,13 @@ #endif return ctx - parseURL :: URL -> URI parseURL r' = case parseURI r of- Just u -> u+ Just u -> u Nothing -> error ("Can't parse URI " ++ r) where- r = T.unpack $ T.decodeUtf8 r'+ r = escapeURIString isAllowedInURI $ T.unpack $ T.decodeUtf8 r' ------------------------------------------------------------------------------ @@ -270,43 +298,44 @@ path element, resulting in an illegal HTTP request line. -} -path :: URI -> ByteString-path u = case url of- "" -> "/"- _ -> url+pathFrom :: URI -> ByteString+pathFrom u = case url of+ "" -> "/"+ _ -> url where- url = T.encodeUtf8 $! T.pack- $! concat [uriPath u, uriQuery u, uriFragment u]-+ 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 :: URL- -- ^ Resource to GET from.- -> (Response -> InputStream ByteString -> IO β)- -- ^ Handler function to receive the response from the server.- -> IO β+{- |+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@@ -314,22 +343,20 @@ (establish u) (teardown) (process)- where teardown = closeConnection u = parseURL r' q = buildRequest1 $ do- http GET (path u)- setAccept "*/*"+ 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@@ -338,67 +365,66 @@ it for now. -} -wrapRedirect- :: URI- -> Int- -> (Response -> InputStream ByteString -> IO β)- -> Response- -> InputStream ByteString- -> IO β+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+ Just l -> getN n' (splitURI u l) handler+ Nothing -> handler p i else handler p i where- s = getStatusCode p+ s = getStatusCode p lm = getHeader p "Location"- !n' = if n < 5+ !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- } ""-+ 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)+ 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 β+{- |+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)@@ -410,9 +436,9 @@ u = parseURL r' q = buildRequest1 $ do- http POST (path u)- setAccept "*/*"- setContentType t+ http POST (pathFrom u)+ setAccept "*/*"+ setContentType t process c = do _ <- sendRequest c q body@@ -420,22 +446,21 @@ 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 β+{- |+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)@@ -447,9 +472,9 @@ u = parseURL r' q = buildRequest1 $ do- http POST (path u)- setAccept "*/*"- setContentType "application/x-www-form-urlencoded"+ http POST (pathFrom u)+ setAccept "*/*"+ setContentType "application/x-www-form-urlencoded" process c = do _ <- sendRequest c q (encodedFormBody nvs)@@ -457,55 +482,147 @@ 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. ------ | 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 ()+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']+ combine :: (ByteString, ByteString) -> Builder+ combine (n', v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", urlEncodeBuilder v'] +{- |+Build a list of parts into an upload body. ------ | 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 β+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)@@ -517,9 +634,9 @@ u = parseURL r' q = buildRequest1 $ do- http PUT (path u)- setAccept "*/*"- setHeader "Content-Type" t+ http PUT (pathFrom u)+ setAccept "*/*"+ setHeader "Content-Type" t process c = do _ <- sendRequest c q body@@ -527,23 +644,25 @@ 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@.----concatHandler' :: Response -> InputStream ByteString -> IO ByteString-concatHandler' p i =+{- |+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 concatHandler p i+ 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)+ deriving (Typeable) instance Exception HttpClientError @@ -557,39 +676,53 @@ 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.---+{- |+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@@ -607,14 +740,14 @@ 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 ::+ (FromJSON α) =>+ Response ->+ InputStream ByteString ->+ IO α jsonHandler _ i = do- v <- Streams.parseFromStream json' i -- Value- let r = fromJSON v -- Result+ v <- Streams.parseFromStream json' i -- Value+ let r = fromJSON v -- Result case r of- (Success a) -> return a- (Error str) -> error str+ (Success a) -> return a+ (Error str) -> error str
lib/Network/Http/ResponseParser.hs view
@@ -1,7 +1,7 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- 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:@@ -14,19 +14,18 @@ -- src/Snap/Internal/Http/Parser.hs, and various utility functions -- have been cloned from there. ----{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide, not-home #-} module Network.Http.ResponseParser ( readResponseHeader, readResponseBody,- UnexpectedCompression(..),-- -- for testing- readDecimal+ UnexpectedCompression (..),+ -- for testing+ readDecimal, ) where import Prelude hiding (take, takeWhile)@@ -63,61 +62,60 @@ __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+ (sc, sm) <- Streams.parseFromStream parseStatusLine i hs <- readHeaderFields i - let h = buildHeaders hs+ let h = buildHeaders hs let te = case lookupHeader h "Transfer-Encoding" of- Just x' -> if mk x' == "chunked"- then Chunked- else None+ 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+ 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- }+ 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 :: Parser (Int, ByteString) parseStatusLine = do sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' ' sm <- takeTill (== '\r') <* crlf- return (sc,sm)+ return (sc, sm) where version c = c == '1' || c == '0' - crlf :: Parser ByteString crlf = string "\r\n" - --------------------------------------------------------------------- {-@@ -126,17 +124,16 @@ -} 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+ 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)+ Identity -> return i2+ Gzip -> readCompressedBody i2+ Deflate -> throwIO (UnexpectedCompression $ show c) return i3 where@@ -144,7 +141,6 @@ c = pContentEncoding p l = pContentLength p - readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α readDecimal str' = S.foldl' f 0 x'@@ -155,16 +151,16 @@ {-# 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"+ 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)+ deriving (Typeable, Show) instance Exception UnexpectedCompression - --------------------------------------------------------------------- {-@@ -176,7 +172,6 @@ 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@@ -196,11 +191,10 @@ else do -- skip "trailers" and consume final CRLF skipEnd- where go 0 = return () go !n = do- (!x',!r) <- liftIO $ readN n i1+ (!x', !r) <- liftIO $ readN n i1 Streams.yield x' go r @@ -230,17 +224,18 @@ where !d = n - size - !p = if d > 0- then size- else n+ !p =+ if d > 0+ then size+ else n - !r = if d > 0- then d- else 0+ !r =+ if d > 0+ then d+ else 0 size = __BITE_SIZE__ - transferChunkSize :: Parser (Int) transferChunkSize = do !n <- hexadecimal@@ -248,7 +243,6 @@ void crlf return n - --------------------------------------------------------------------- {-@@ -270,7 +264,6 @@ readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString) readUnlimitedBody i1 = do return i1- ---------------------------------------------------------------------
lib/Network/Http/Utilities.hs view
@@ -1,7 +1,7 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- 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:@@ -17,18 +17,18 @@ -- kept separate to aid syncing changes from snap-core as they -- become available. ----{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide, not-home #-} module Network.Http.Utilities ( readResponseLine,- readHeaderFields+ readHeaderFields, ) where ------------------------------------------------------------------------------@@ -40,9 +40,10 @@ 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 Prelude hiding (head, take, takeWhile)+ ---------------------------------------------------------------------------- import Network.Http.Types@@ -58,30 +59,28 @@ 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+ 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)+ pVer s =+ if "HTTP/" `S.isPrefixOf` s+ then pVers (S.unsafeDrop 5 s)+ else (1, 0) - bSp = splitCh ' '+ bSp = splitCh ' ' pVers s = (c, d) where- (!a, !b) = splitCh '.' s- !c = unsafeFromNat a- !d = unsafeFromNat b-+ (!a, !b) = splitCh '.' s+ !c = unsafeFromNat a+ !d = unsafeFromNat b {- Read a single line of an HTTP response.@@ -91,21 +90,21 @@ where throwNoCRLF = throwIO $- HttpParseException "parse error: expected line ending in crlf"+ HttpParseException "parse error: expected line ending in crlf" throwBadCRLF = throwIO $- HttpParseException "parse error: got cr without subsequent lf"+ HttpParseException "parse error: got cr without subsequent lf" go !l = do !mb <- Streams.read input- !s <- maybe throwNoCRLF return mb+ !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+ NoCR -> noCRLF l s+ LastIsCR idx# -> lastIsCR l s idx#+ _ -> throwBadCRLF foundCRLF l s idx# = do let !i1 = (I# idx#)@@ -116,94 +115,92 @@ 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))+ let !out = if null l then a else S.concat (reverse (a : l)) return out - noCRLF l s = go (s:l)+ 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-+ 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-+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#+ 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)+ 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)+ 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+ 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 #-} - ------------------------------------------------------------------------------ {-@@ -212,50 +209,50 @@ when it hits the "blank" line (ie, CRLF CRLF pair), which it consumes. -}-readHeaderFields :: InputStream ByteString -> IO [(ByteString,ByteString)]+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:))-+ 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+ 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 --- -----------------------+ 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@@ -263,9 +260,10 @@ 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] ++ "'"+ digitToInt c =+ if d >= 0 && d <= 9+ then d+ else error $ "bad digit: '" ++ [c] ++ "'" where !d = ord c - zero {-# INLINE unsafeFromNat #-}
tests/MockServer.hs view
@@ -1,15 +1,15 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- 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 #-}+{-# LANGUAGE PackageImports #-}+ {-# OPTIONS -fno-warn-dodgy-imports #-} module MockServer (runMockServer, localPort) where@@ -29,8 +29,7 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Maybe (fromMaybe)-import Filesystem (getSize)-import Filesystem.Path.CurrentOS (decodeString)+import System.Directory (getFileSize) import Snap.Core import Snap.Http.Server import Snap.Util.FileServe@@ -52,13 +51,13 @@ go :: IO () go = httpServe c site where- c = setAccessLog ConfigNoLog $- setErrorLog ConfigNoLog $- setHostname localHost $- setBind localHost $- setPort (fromIntegral localPort) $- setVerbose False emptyConfig-+ c =+ setAccessLog ConfigNoLog $+ setErrorLog ConfigNoLog $+ setHostname localHost $+ setBind localHost $+ setPort (fromIntegral localPort) $+ setVerbose False emptyConfig runMockServer :: IO () runMockServer = do@@ -71,27 +70,28 @@ -- site :: Snap ()-site = catch- (routeRequests)- (\e -> serveError "Splat\n" e)+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-+ [ ("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@@ -99,10 +99,9 @@ let m = rqMethod r case m of- GET -> handleGetMethod- PUT -> handlePutWithExpectation- _ -> serveMethodNotAllowed-+ GET -> handleGetMethod+ PUT -> handlePutWithExpectation+ _ -> serveMethodNotAllowed serveStatic :: Snap () serveStatic = do@@ -112,7 +111,7 @@ let f' = S.concat ["tests/", i'] let f = S.unpack f' - l <- liftIO $ getSize $ decodeString f+ l <- liftIO $ getFileSize f let t = fileType defaultMimeTypes f modifyResponse $ setContentType t@@ -120,12 +119,10 @@ 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. --@@ -136,9 +133,8 @@ let mime0 = getHeader "Accept" r case mime0 of- Just "text/html" -> handleAsBrowser- _ -> handleAsText-+ Just "text/html" -> handleAsBrowser+ _ -> handleAsText handleAsBrowser :: Snap () handleAsBrowser = do@@ -147,13 +143,11 @@ 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"@@ -161,7 +155,6 @@ sendFile "tests/data-eu-gdp.json" - serveRedirect :: Snap () serveRedirect = do modifyResponse $ setResponseStatus 307 "Temporary Redirect"@@ -198,7 +191,6 @@ modifyResponse $ setResponseStatus 204 "No Content" modifyResponse $ setHeader "Cache-Control" "no-cache" - serveRepeatedResponseHeaders :: Snap () serveRepeatedResponseHeaders = do modifyResponse $ addHeader "Set-Cookie" "stone=diamond"@@ -215,7 +207,6 @@ b' <- readRequestBody 1024 writeLBS b' - handlePutWithExpectation :: Snap () handlePutWithExpectation = do setTimeout 5@@ -226,7 +217,6 @@ b' <- readRequestBody 1024 writeLBS b' - handleSizeRequest :: Snap () handleSizeRequest = do r <- getRequest@@ -234,7 +224,7 @@ t <- case mm of Just m -> return m- _ -> do+ _ -> do serveUnsupported return "" @@ -244,7 +234,6 @@ b' <- readRequestBody 65536 writeBS $ S.pack $ show $ L.length b' - updateResource :: Snap () updateResource = do bs' <- readRequestBody 4096@@ -262,7 +251,6 @@ where fromLazy ls' = S.concat $ L.toChunks ls' - serveNotFound :: Snap a serveNotFound = do modifyResponse $ setResponseStatus 404 "Not Found"@@ -273,13 +261,11 @@ 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"@@ -289,7 +275,6 @@ r <- getResponse finishWith r - serveUnsupported :: Snap () serveUnsupported = do modifyResponse $ setResponseStatus 415 "Unsupported Media Type"@@ -297,7 +282,6 @@ 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@@ -314,12 +298,9 @@ where msg = show (e :: SomeException) - debug :: String -> Snap () debug cs = do liftIO $ do hPutStrLn stderr "" hPutStrLn stderr cs hFlush stderr--
tests/TestSuite.hs view
@@ -1,33 +1,51 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- 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 DeriveGeneric #-}+{-# 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 qualified Blaze.ByteString.Builder as Builder (+ fromByteString,+ toByteString,+ )+import qualified Blaze.ByteString.Builder.Char8 as Builder (+ fromChar,+ fromString,+ ) import Control.Applicative import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar) import Control.Exception (Exception, bracket, handleJust) import Control.Monad (forM_, guard)-import Data.Aeson (FromJSON, ToJSON, Value (..), json, object, parseJSON,- toJSON, (.:), (.=))+import Data.Aeson (+ 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 qualified Data.HashMap.Strict as Map import Data.Maybe (fromJust) import Data.Monoid import Data.String@@ -36,11 +54,11 @@ import qualified Data.Text.Encoding as Text import GHC.Generics hiding (Selector) import Network.Socket (SockAddr (..))-import Network.URI (parseURI)+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 Test.HUnit import Debug.Trace @@ -64,13 +82,20 @@ import MockServer (localPort) import Network.Http.Client import Network.Http.Connection (Connection (..))-import Network.Http.Inconvenience (HttpClientError (..),- TooManyRedirects (..), splitURI)-import Network.Http.Internal (Request (..), Response (..),- composeRequestBytes, lookupHeader)+import Network.Http.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@@ -89,7 +114,7 @@ testResponseParser1 testResponseParserMismatch testPaddedContentLength--- testTrailingWhitespace+ -- testTrailingWhitespace testChunkedEncoding testContentLength testDevoidOfContent@@ -105,6 +130,8 @@ testPostWithForm testGetRedirects testSplitURI+ testParseURL+ testParseURLHasEscaped testGetLocalRedirects testGetFormatsRequest testExcessiveRedirects@@ -112,6 +139,9 @@ testEstablishConnection testParsingJson1 testParsingJson2+ testPutWithSimple+ testPutWithJson+ testMultipartUpload describe "Corner cases in protocol compliance" $ do testSendBodyFor PUT@@ -122,44 +152,48 @@ it "terminates with a blank line" $ do c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http GET "/time"- setAccept "text/plain"+ 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'+ 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"+ 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+ 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'+ 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')+ 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+ 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')+ 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@@ -168,11 +202,10 @@ 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)]+ setAccept' [("text/html", 1), ("*/*", 0.0)] let h = qHeaders q let (Just a) = lookupHeader h "Accept"@@ -181,25 +214,27 @@ testBasicAuthorizatonHeader = it "properly formats Authorization header" $ do let q = buildRequest1 $ do- setAuthorizationBasic "Aladdin" "open sesame"+ 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')+ 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.@@ -207,26 +242,25 @@ testEnsureHostField = it "has a properly formatted Host header" $ do let q1 = buildRequest1 $ do- http GET "/hello.txt"+ 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+ 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+ 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)@@ -263,45 +297,50 @@ c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http GET "/time"+ 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+ receiveResponse+ c+ ( \p i1 -> do+ let cm = getHeader p "Transfer-Encoding"+ assertEqual "Should be chunked encoding!" (Just "chunked") cm - len <- getCount- assertEqual "Incorrect number of bytes read" 29 len)+ (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"+ 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+ 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+ 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+ (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')+ 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)+ 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)@@ -314,22 +353,24 @@ it "reads body without Content-Length or Transfer-Encoding" $ do c <- fakeConnectionHttp10 let q = buildRequest1 $ do- http GET "/fake"+ http GET "/fake" sendRequest c q emptyBody- receiveResponse c (\_ i1 -> do- (i2, getCount) <- Streams.countInput i1- o <- Streams.nullOutput- Streams.connect i2 o+ 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+ end <- Streams.atEOF i2+ assertBool "Expected end of stream" end - len <- getCount- assertEqual "Incorrect number of bytes read" 4611 len)+ len <- getCount+ assertEqual "Incorrect number of bytes read" 4611 len+ ) return () - fakeConnectionHttp10 :: IO Connection fakeConnectionHttp10 = do x' <- S.readFile "tests/example3.txt"@@ -339,7 +380,6 @@ 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@@ -347,24 +387,27 @@ -} testDevoidOfContent = do- it "handles 204 No Content response without Content-Length"- $ timeout_ 2 $ do- (c, mv) <- fakeConnectionNoContent- let q = buildRequest1 $ 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+ 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+ end <- Streams.atEOF i2+ assertBool "Expected end of stream" end - len <- getCount- assertEqual "Incorrect number of bytes read" 0 len)- putMVar mv ()- return ()+ len <- getCount+ assertEqual "Incorrect number of bytes read" 0 len+ )+ putMVar mv ()+ return () where secs :: Int secs = 10 ^ (6 :: Int)@@ -372,7 +415,6 @@ 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"@@ -388,7 +430,6 @@ 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@@ -399,25 +440,28 @@ c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http GET "/static/hello.html"- setHeader "Accept-Encoding" "gzip"+ 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+ 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+ (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')+ 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)+ end <- Streams.atEOF i+ assertBool "Expected end of stream" end+ ) {- This isn't much of a test yet; we really need to test@@ -431,70 +475,82 @@ c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http PUT "/resource/x149"- setExpectContinue+ http PUT "/resource/x149"+ setExpectContinue - sendRequest c q (\o -> do- Streams.write (Just (Builder.fromString "Hello world\n")) o)+ 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+ 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+ end <- Streams.atEOF i+ assertBool "Expected end of stream" end - assertEqual "Incorrect body" "Hello world\n" x')+ 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-+ 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+ 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+ handler :: Response -> InputStream ByteString -> IO ()+ handler _ i = do+ (Just b') <- Streams.read i - end <- Streams.atEOF i- assertBool "Expected end of stream" end+ 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+ 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+ http meth "/size"+ setContentType "text/plain"+ setTransferEncoding - sendRequest c q (\o -> do- Streams.write (Just (Builder.fromString "a request")) o)+ 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+ 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)+ let size = readDecimal b' :: Int+ assertEqual "Should have received a request body" 9 size+ ) closeConnection c @@ -503,107 +559,122 @@ 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+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler p i = do+ let code = getStatusCode p+ assertEqual "Expected 200 OK" 200 code - end <- Streams.atEOF i- assertBool "Expected end of stream" end+ (Just b') <- Streams.read i - let size = readDecimal b' :: Int- assertEqual "Should have replied with correct file size" 4611 size+ 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+ 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 - end <- Streams.atEOF i- assertBool "Expected end of stream" end+ b' <- Streams.readExactly 48 i - assertEqual "Incorrect URL encoding"- "name=Kermit&role=St%26gehand&country=N%c3%b8rway"- b'+ 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+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler p i1 = do+ let code = getStatusCode p+ assertEqual "Should have been final code" 200 code - len <- getCount- assertEqual "Incorrect number of bytes read" 29 len+ (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+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler p i1 = do+ let code = getStatusCode p+ assertEqual "Should have been final code" 200 code - len <- getCount- assertEqual "Incorrect number of bytes read" 29 len+ (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"+ 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"+ 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"+ 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"+ 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"+ 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)+ 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 ]+ let url = S.concat ["http://", localhost] x' <- get url concatHandler' assertBool "Incorrect context path" (S.length x' > 0)@@ -613,20 +684,20 @@ 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+ 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")+ 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@@ -639,8 +710,8 @@ handleJust isWanted (const $ return ()) $ do _ <- action assertFailure $ "Expected exception: " ++ show ex- where isWanted = guard . (== ex)-+ where+ isWanted = guard . (== ex) testGeneralHandler = it "GET with general purpose handler throws exception on 404" $ do@@ -648,7 +719,6 @@ get url concatHandler' `shouldThrow` httpClientError 404 - tooManyRedirects :: Selector TooManyRedirects tooManyRedirects = const True @@ -656,31 +726,31 @@ 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"+ 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')+ 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) = Map.lookup "label" o+ let (Just v) = KeyMap.lookup "label" o let (String t) = v assertEqual "Incorrect response" "Europe (EU27)" t@@ -693,8 +763,8 @@ assertEqual "Incorrect response" "Japan" (gLabel x) assertEqual "Data not parsed as expected" 2008 (fst $ last $ gData x)--- L.putStr $ encodePretty x +-- L.putStr $ encodePretty x {- Go to the trouble to create a Haskell data type representing the JSON feed@@ -702,20 +772,86 @@ because data is a reserved word, of course. -} -data GrossDomesticProduct = GrossDomesticProduct {- gLabel :: Text,- gData :: [(Int, Double)]-} deriving (Show, Generic)+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-+ parseJSON (Object o) =+ GrossDomesticProduct+ <$> o .: "label"+ <*> o .: "data"+ parseJSON _ = undefined instance ToJSON GrossDomesticProduct where- toJSON (GrossDomesticProduct l d) = object- ["label" .= l,- "data" .= d]+ 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
+ tests/multipart.bin view
@@ -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--