packages feed

http-streams 0.6.1.1 → 0.8.9.9

raw patch · 34 files changed

Files

+ 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 Operational Dynamics Consulting, Pty Ltd-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--    1. Redistributions of source code must retain the above copyright-       notice, this list of conditions and the following disclaimer.--    2. Redistributions in binary form must reproduce the above-       copyright notice, this list of conditions and the following-       disclaimer in the documentation and/or other materials provided-       with the distribution.-      -    3. Neither the name of the project nor the names of its contributors-       may be used to endorse or promote products derived from this -       software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ 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.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.6.1.1+version:             0.8.9.9 synopsis:            An HTTP client using io-streams description:- /Overview/- .  An HTTP client, using the Snap Framework's 'io-streams' library to- hande the streaming IO. The API is optimized for ease of use for the+ handle the streaming IO. The API is optimized for ease of use for the  rather common case of code needing to query web services and deal with  the result.  .@@ -14,48 +12,71 @@  for full documentation.  license:             BSD3-license-file:        LICENCE-author:              Andrew Cowie <andrew@operationaldynamics.com>-maintainer:          Andrew Cowie <andrew@operationaldynamics.com>-copyright:           © 2012-2013 Operational Dynamics Consulting, Pty Ltd and Others-category:            Web-tested-with:         GHC == 7.6+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.10.7, GHC == 9.2.7, GHC == 9.4.5 stability:           experimental-homepage:            http://research.operationaldynamics.com/projects/http-streams/-bug-reports:         https://github.com/afcowie/http-streams/issues+homepage:            https://github.com/aesiniath/http-streams/+bug-reports:         https://github.com/aesiniath/http-streams/issues+extra-source-files:  README.md CHANGELOG.md+                     tests/MockServer.hs+                     tests/TestSuite.hs+                     tests/data-eu-gdp.json+                     tests/data-us-gdp.json+                     tests/data-jp-gdp.json+                     tests/statler.jpg+                     tests/multipart.bin+                     tests/example1.txt+                     tests/example2.txt+                     tests/example3.txt+                     tests/example4.txt+                     tests/example5.txt+                     tests/hello.txt+                     tests/hello.html -build-type:          Custom+build-type:          Simple +flag network-uri+   description: Get Network.URI from the network-uri package+   default: True+ library   default-language:  Haskell2010    build-depends:     attoparsec,-                     base >= 4 && <5,+                     base >= 4.5 && <5,+                     directory,                      base64-bytestring,-                     blaze-builder,+                     blaze-builder >= 0.4,                      bytestring,                      case-insensitive,-                     io-streams >= 1.1 && <1.2,-                     HsOpenSSL,-                     openssl-streams >= 1.1 && <1.2,+                     filepath,+                     io-streams >= 1.3 && < 1.6,+                     HsOpenSSL >= 0.11.2,+                     openssl-streams >= 1.1 && < 1.4,                      mtl,                      transformers,-                     network,                      text,                      unordered-containers,-                     aeson+                     aeson < 2.3,+                     attoparsec-aeson < 2.3,+                     http-common >= 0.8.3.4+  if flag(network-uri)+    build-depends: network-uri >= 2.6, network >= 2.6+  else+    build-depends: network-uri < 2.6, network < 2.6 -  hs-source-dirs:    src-  exposed-modules:   Network.Http.Client-  other-modules:     Network.Http.Types,+  hs-source-dirs:    lib+  exposed-modules:   Network.Http.Client,                      Network.Http.Connection,-                     Network.Http.RequestBuilder,                      Network.Http.ResponseParser,-                     Network.Http.Utilities,                      Network.Http.Inconvenience+  other-modules:     Network.Http.Utilities -  ghc-options:       -O2-                     -Wall+  ghc-options:       -Wall                      -Wwarn                      -fwarn-tabs                      -funbox-strict-fields@@ -65,7 +86,7 @@    include-dirs:      . -  ghc-prof-options:  -prof -fprof-auto-top+  ghc-prof-options:  -fprof-auto-exported   test-suite           check@@ -76,10 +97,11 @@   build-depends:                      HUnit,                      HsOpenSSL,-                     MonadCatchIO-transformers,+                     lifted-base,                      aeson-pretty,                      attoparsec,                      base,+                     directory,                      blaze-builder,                      base64-bytestring,                      bytestring,@@ -90,21 +112,24 @@                      io-streams,                      mtl,                      transformers,-                     network,-                     openssl-streams,-                     snap-core       >= 0.9    && < 1.0,-                     snap-server     >= 0.9    && < 1.0,-                     system-fileio   >= 0.3.10 && < 0.4,-                     system-filepath >= 0.4.1  && < 0.5,+                     network >= 2.6,+                     network-uri >= 2.6,+                     openssl-streams >= 1.1    && < 1.4,+                     random,+                     snap-core       >= 1.0    && < 1.2,+                     snap-server     >= 1.1    && < 1.2,                      text,                      unordered-containers,-                     aeson+                     aeson,+                     http-common  >= 0.8.2,+                     http-streams -  hs-source-dirs:    src,tests-  main-is:           Check.hs+  hs-source-dirs:    tests+  main-is:           check.hs+  other-modules:     TestSuite+                     MockServer -  ghc-options:       -O2-                     -threaded+  ghc-options:       -threaded                      -Wall                      -Wwarn                      -fwarn-tabs@@ -118,7 +143,7 @@  source-repository    head   type:              git-  location:          git://github.com/afcowie/http-streams.git+  location:          git://github.com/aesiniath/http-streams.git   -- vim: set tabstop=21 expandtab:
+ lib/Network/Http/Client.hs view
@@ -0,0 +1,202 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2021 Athae Eredh Siniath and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the BSD licence.+--++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-orphans #-}++-- |+-- Maintainer: Andrew Cowie+-- Stability: Experimental+--+-- /Overview/+--+-- A simple HTTP client library, using the Snap Framework's @io-streams@+-- library to handle the streaming I\/O. The @http-streams@ API is designed+-- for ease of use when querying web services and dealing with the result.+--+-- Given:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import System.IO.Streams (InputStream, OutputStream, stdout)+-- > import qualified System.IO.Streams as Streams+-- > import qualified Data.ByteString as S+--+-- and this library:+--+-- > import Network.Http.Client+--+-- the underlying API is straight-forward. In particular, constructing the+-- 'Request' to send is quick and to the point:+--+-- @+-- main :: IO ()+-- main = do+-- \    c <- 'openConnection' \"www.example.com\" 80+--+-- \    let q = 'buildRequest1' $ do+--                 'http' GET \"\/\"+--                 'setAccept' \"text/html\"+--+-- \    'sendRequest' c q 'emptyBody'+--+-- \    `receiveResponse` c (\\p i -> do+--         xm <- Streams.read i+--         case xm of+--             Just x    -> S.putStr x+--             Nothing   -> \"\")+--+-- \    'closeConnection' c+-- @+--+-- which would print the first chunk of the response back from the+-- server. Obviously in real usage you'll do something more interesting+-- with the 'Response' in the handler function, and consume the entire+-- response body from the InputStream ByteString.+--+-- Because this is all happening in 'IO' (the defining feature of+-- @io-streams@!), you can ensure resource cleanup on normal or+-- abnormal termination by using @Control.Exception@'s standard+-- 'Control.Exception.bracket' function; see 'closeConnection' for an+-- example. For the common case we have a utility function which+-- wraps @bracket@ for you:+--+-- @+-- foo :: IO ByteString+-- foo = 'withConnection' ('openConnection' \"www.example.com\" 80) doStuff+--+-- doStuff :: Connection -> IO ByteString+-- @+--+-- There are also a set of convenience APIs that do just that, along with+-- the tedious bits like parsing URLs. For example, to do an HTTP GET and+-- stream the response body to stdout, you can simply do:+--+-- @+--     'get' \"http:\/\/www.example.com\/file.txt\" (\\p i -> Streams.connect i stdout)+-- @+--+-- which on the one hand is \"easy\" while on the other exposes the the+-- 'Response' and InputStream for you to read from. Of course, messing+-- around with URLs is all a bit inefficient, so if you already have e.g.+-- hostname and path, or if you need more control over the request being+-- created, then the underlying @http-streams@ API is simple enough to use+-- directly.+--+module Network.Http.Client (+    -- * Connecting to server+    Hostname,+    Port,+    Connection,+    openConnection,+    openConnectionUnix,++    -- * Building Requests+    -- | You setup a request using the RequestBuilder monad, and+    -- get the resultant Request object by running 'buildRequest1'. The+    -- first call doesn't have to be to 'http', but it looks better when+    -- it is, don't you think?+    Method(..),+    RequestBuilder,+    buildRequest1,+    buildRequest,+    http,+    setHostname,+    setAccept,+    setAccept',+    setAuthorizationBasic,+    ContentType,+    setContentType,+    setContentLength,+    FieldName,+    Boundary,+    randomBoundary,+    setContentMultipart,+    setExpectContinue,+    setTransferEncoding,+    setHeader,++    -- * Sending HTTP request+    Request,+    Response,+    getHostname,+    sendRequest,+    emptyBody,+    simpleBody,+    fileBody,+    inputStreamBody,+    encodedFormBody,+    multipartFormBody,+    Part,+    simplePart,+    filePart,+    inputStreamPart,+    jsonBody,++    -- * Processing HTTP response+    receiveResponse,+    receiveResponseRaw,+    unsafeReceiveResponse,+    UnexpectedCompression,+    StatusCode,+    getStatusCode,+    getStatusMessage,+    getHeader,+    debugHandler,+    simpleHandler,+    simpleHandler',+    HttpClientError(..),+    jsonHandler,++    -- * Resource cleanup+    closeConnection,+    withConnection,++    -- * Convenience APIs+    -- | Some simple functions for making requests with useful defaults.+    -- There's no @head@ function for the usual reason of needing to+    -- avoid collision with @Prelude@.+    --+    -- These convenience functions work with @http@ and @https@, but+    --  note that if you retrieve an @https@ URL, you /must/ wrap your+    -- @main@ function with 'OpenSSL.withOpenSSL' to initialize the+    -- native openssl library code.+    --+    URL,+    get,+    TooManyRedirects,+    post,+    postForm,+    put,++    -- * Secure connections+    openConnectionSSL,+    baselineContextSSL,+    modifyContextSSL,+    establishConnection,++    -- * Testing support+    makeConnection,+    Headers,+    getHeaders,+    getHeadersFull,+    packBoundary,++    -- * Deprecated+    concatHandler,+    concatHandler',+    getRequestHeaders+) where++import Network.Http.Types++import Network.Http.Connection+import Network.Http.Inconvenience
+ lib/Network/Http/Connection.hs view
@@ -0,0 +1,679 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2021 Athae Eredh Siniath and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the BSD licence.+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide, not-home #-}++module Network.Http.Connection (+    Connection (..),+    -- constructors only for testing+    makeConnection,+    withConnection,+    openConnection,+    openConnectionSSL,+    openConnectionUnix,+    closeConnection,+    getHostname,+    getRequestHeaders,+    getHeadersFull,+    sendRequest,+    receiveResponse,+    receiveResponseRaw,+    unsafeReceiveResponse,+    UnexpectedCompression,+    emptyBody,+    simpleBody,+    fileBody,+    inputStreamBody,+    debugHandler,+    simpleHandler,+    concatHandler,+) where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (+    flush,+    fromByteString,+    toByteString,+ )+import qualified Blaze.ByteString.Builder.HTTP as Builder (chunkedTransferEncoding, chunkedTransferTerminator)+import Control.Exception (bracket)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Network.Socket+import OpenSSL (withOpenSSL)+import OpenSSL.Session (SSL, SSLContext)+import qualified OpenSSL.Session as SSL+import System.IO.Streams (InputStream, OutputStream, stdout)+import qualified System.IO.Streams as Streams+import qualified System.IO.Streams.SSL as Streams hiding (connect)++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mappend, mempty)+#endif++import Network.Http.Internal+import Network.Http.ResponseParser++{- |+A connection to a web server.+-}+data Connection = Connection+    { -- | will be used as the Host: header in the HTTP request.+      cHost :: ByteString+    , -- | called when the connection should be closed.+      cClose :: IO ()+    , cOut :: OutputStream Builder+    , cIn :: InputStream ByteString+    }++instance Show Connection where+    show c =+        {-# SCC "Connection.show" #-}+        concat+            [ "Host: "+            , S.unpack $ cHost c+            , "\n"+            ]++{- |+Create a raw Connection object from the given parts. This is+primarily of use when teseting, for example:++> fakeConnection :: IO Connection+> fakeConnection = do+>     o  <- Streams.nullOutput+>     i  <- Streams.nullInput+>     c  <- makeConnection "www.example.com" (return()) o i+>     return c++is an idiom we use frequently in testing and benchmarking, usually+replacing the InputStream with something like:++>     x' <- S.readFile "properly-formatted-response.txt"+>     i  <- Streams.fromByteString x'++If you're going to do that, keep in mind that you /must/ have CR-LF+pairs after each header line and between the header and body to+be compliant with the HTTP protocol; otherwise, parsers will+reject your message.+-}+makeConnection ::+    -- | will be used as the @Host:@ header in the HTTP request.+    ByteString ->+    -- | an action to be called when the connection is terminated.+    IO () ->+    -- | write end of the HTTP client-server connection.+    OutputStream ByteString ->+    -- | read end of the HTTP client-server connection.+    InputStream ByteString ->+    IO Connection+makeConnection h c o1 i = do+    o2 <- Streams.builderStream o1+    return $! Connection h c o2 i++{- |+Given an @IO@ action producing a 'Connection', and a computation+that needs one, runs the computation, cleaning up the+@Connection@ afterwards.++>     x <- withConnection (openConnection "s3.example.com" 80) $ (\c -> do+>         let q = buildRequest1 $ do+>             http GET "/bucket42/object/149"+>         sendRequest c q emptyBody+>         ...+>         return "blah")++which can make the code making an HTTP request a lot more+straight-forward.++Wraps @Control.Exception@'s 'Control.Exception.bracket'.+-}+withConnection :: IO Connection -> (Connection -> IO γ) -> IO γ+withConnection mkC =+    bracket mkC closeConnection++{- |+In order to make a request you first establish the TCP+connection to the server over which to send it.++Ordinarily you would supply the host part of the URL here and it will+be used as the value of the HTTP 1.1 @Host:@ field. However, you can+specify any server name or IP addresss and set the @Host:@ value+later with 'Network.Http.Client.setHostname' when building the+request.++Usage is as follows:++>     c <- openConnection "localhost" 80+>     ...+>     closeConnection c++More likely, you'll use 'withConnection' to wrap the call in order+to ensure finalization.++HTTP pipelining is supported; you can reuse the connection to a+web server, but it's up to you to ensure you match the number of+requests sent to the number of responses read, and to process those+responses in order. This is all assuming that the /server/ supports+pipelining; be warned that not all do. Web browsers go to+extraordinary lengths to probe this; you probably only want to do+pipelining under controlled conditions. Otherwise just open a new+connection for subsequent requests.+-}+openConnection :: Hostname -> Port -> IO Connection+openConnection h1' p = do+    is <- getAddrInfo (Just hints) (Just h1) (Just $ show p)+    let addr = head is+    let a = addrAddress addr+    s <- socket (addrFamily addr) Stream defaultProtocol++    connect s a+    (i, o1) <- Streams.socketToStreams s++    o2 <- Streams.builderStream o1++    return+        Connection+            { cHost = h2'+            , cClose = close s+            , cOut = o2+            , cIn = i+            }+  where+    hints =+        defaultHints+            { addrFlags = [AI_NUMERICSERV]+            , addrSocketType = Stream+            }+    h2' =+        if p == 80+            then h1'+            else S.concat [h1', ":", S.pack $ show p]+    h1 = S.unpack h1'++{- |+Open a secure connection to a web server.++> import OpenSSL (withOpenSSL)+>+> main :: IO ()+> main = do+>     ctx <- baselineContextSSL+>     c <- openConnectionSSL ctx "api.github.com" 443+>     ...+>     closeConnection c++If you want to tune the parameters used in making SSL connections,+manually specify certificates, etc, then setup your own context:++> import OpenSSL.Session (SSLContext)+> import qualified OpenSSL.Session as SSL+>+>     ...+>     ctx <- SSL.context+>     ...++See "OpenSSL.Session".++Crypto is as provided by the system @openssl@ library, as wrapped+by the @HsOpenSSL@ package and @openssl-streams@.++/There is no longer a need to call @withOpenSSL@ explicitly; the+initialization is invoked once per process for you/+-}+openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection+openConnectionSSL ctx h1' p = withOpenSSL $ do+    is <- getAddrInfo Nothing (Just h1) (Just $ show p)++    let a = addrAddress $ head is+        f = addrFamily $ head is+    s <- socket f Stream defaultProtocol++    connect s a++    ssl <- SSL.connection ctx s+    SSL.setTlsextHostName ssl h1+    SSL.connect ssl++    (i, o1) <- Streams.sslToStreams ssl++    o2 <- Streams.builderStream o1++    return+        Connection+            { cHost = h2'+            , cClose = closeSSL s ssl+            , cOut = o2+            , cIn = i+            }+  where+    h2' :: ByteString+    h2' =+        if p == 443+            then h1'+            else S.concat [h1', ":", S.pack $ show p]+    h1 = S.unpack h1'++closeSSL :: Socket -> SSL -> IO ()+closeSSL s ssl = do+    SSL.shutdown ssl SSL.Unidirectional+    close s++{- |+Open a connection to a Unix domain socket.++> main :: IO ()+> main = do+>     c <- openConnectionUnix "/var/run/docker.sock"+>     ...+>     closeConnection c+-}+openConnectionUnix :: FilePath -> IO Connection+openConnectionUnix path = do+    let a = SockAddrUnix path+    s <- socket AF_UNIX Stream defaultProtocol++    connect s a+    (i, o1) <- Streams.socketToStreams s++    o2 <- Streams.builderStream o1++    return+        Connection+            { cHost = path'+            , cClose = close s+            , cOut = o2+            , cIn = i+            }+  where+    path' = S.pack path++{- |+Having composed a 'Request' object with the headers and metadata for+this connection, you can now send the request to the server, along+with the entity body, if there is one. For the rather common case of+HTTP requests like 'GET' that don't send data, use 'emptyBody' as the+output stream:++>     sendRequest c q emptyBody++For 'PUT' and 'POST' requests, you can use 'fileBody' or+'inputStreamBody' to send content to the server, or you can work with+the @io-streams@ API directly:++>     sendRequest c q (\o ->+>         Streams.write (Just (Builder.fromString "Hello World\n")) o)+-}++{-+    I would like to enforce the constraints on the Empty and Static+    cases shown here, but those functions take OutputStream ByteString,+    and we are of course working in OutputStream Builder by that point.+-}+sendRequest :: Connection -> Request -> (OutputStream Builder -> IO α) -> IO α+sendRequest c q handler = do+    -- write the headers++    Streams.write (Just msg) o2++    -- deal with the expect-continue mess++    e2 <- case t of+        Normal -> do+            return e+        Continue -> do+            Streams.write (Just Builder.flush) o2++            p <- readResponseHeader i++            case getStatusCode p of+                100 -> do+                    -- ok to send+                    return e+                _ -> do+                    -- put the response back+                    Streams.unRead (rsp p) i+                    return Empty++    -- write the body, if there is one++    x <- case e2 of+        Empty -> do+            o3 <- Streams.nullOutput+            y <- handler o3+            return y+        Chunking -> do+            o3 <- Streams.contramap Builder.chunkedTransferEncoding o2+            y <- handler o3+            Streams.write (Just Builder.chunkedTransferTerminator) o2+            return y+        (Static _) -> do+            -- o3 <- Streams.giveBytes (fromIntegral n :: Int64) o2+            y <- handler o2+            return y++    -- push the stream out by flushing the output buffers++    Streams.write (Just Builder.flush) o2++    return x+  where+    o2 = cOut c+    e = qBody q+    t = qExpect q+    msg = composeRequestBytes q h'+    h' = cHost c+    i = cIn c+    rsp p = Builder.toByteString $ composeResponseBytes p++{- |+Get the virtual hostname that will be used as the @Host:@ header in+the HTTP 1.1 request. Per RFC 2616 § 14.23, this will be of the form+@hostname:port@ if the port number is other than the default, ie 80+for HTTP.+-}+getHostname :: Connection -> Request -> ByteString+getHostname c q =+    case qHost q of+        Just h' -> h'+        Nothing -> cHost c++{-# DEPRECATED getRequestHeaders "use retrieveHeaders . getHeadersFull instead" #-}+getRequestHeaders :: Connection -> Request -> [(ByteString, ByteString)]+getRequestHeaders c q =+    ("Host", getHostname c q) : kvs+  where+    h = qHeaders q+    kvs = retrieveHeaders h++{- |+Get the headers that will be sent with this request. You likely won't+need this but there are some corner cases where people need to make+calculations based on all the headers before they go out over the wire.++If you'd like the request headers as an association list, import the header+functions:++> import Network.Http.Types++then use 'Network.Http.Types.retreiveHeaders' as follows:++>>> let kvs = retreiveHeaders $ getHeadersFull c q+>>> :t kvs+:: [(ByteString, ByteString)]+-}+getHeadersFull :: Connection -> Request -> Headers+getHeadersFull c q =+    h'+  where+    h = qHeaders q+    h' = updateHeader h "Host" (getHostname c q)++{- |+Handle the response coming back from the server. This function+hands control to a handler function you supply, passing you the+'Response' object with the response headers and an 'InputStream'+containing the entity body.++For example, if you just wanted to print the first chunk of the+content from the server:++>     receiveResponse c (\p i -> do+>         m <- Streams.read i+>         case m of+>             Just bytes -> putStr bytes+>             Nothing    -> return ())++Obviously, you can do more sophisticated things with the+'InputStream', which is the whole point of having an @io-streams@+based HTTP client library.++The final value from the handler function is the return value of+@receiveResponse@, if you need it.++Throws 'UnexpectedCompression' if it doesn't know how to handle the+compression format used in the response.+-}++{-+    The reponse body coming from the server MUST be fully read, even+    if (especially if) the users's handler doesn't consume it all.+    This is necessary to maintain the HTTP protocol invariants;+    otherwise pipelining would not work. It's not entirely clear+    *which* InputStream is being drained here; the underlying+    InputStream ByteString in Connection remains unconsumed beyond the+    threshold of the current response, which is exactly what we need.+-}+receiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β+receiveResponse c handler = do+    p <- readResponseHeader i+    i' <- readResponseBody p i++    x <- handler p i'++    Streams.skipToEof i'++    return x+  where+    i = cIn c++{- |+This is a specialized variant of 'receiveResponse' that /explicitly/ does+not handle the content encoding of the response body stream (it will not+decompress anything). Unless you really want the raw gzipped content coming+down from the server, use @receiveResponse@.+-}++{-+    See notes at receiveResponse.+-}+receiveResponseRaw :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β+receiveResponseRaw c handler = do+    p <- readResponseHeader i+    let p' =+            p+                { pContentEncoding = Identity+                }++    i' <- readResponseBody p' i++    x <- handler p i'++    Streams.skipToEof i'++    return x+  where+    i = cIn c++{- |+Handle the response coming back from the server. This function+is the same as receiveResponse, but it does not consume the body for+you after the handler is done.  This means that it can only be safely used+if the handler will fully consume the body, there is no body, or when+the connection is not being reused (no pipelining).+-}+unsafeReceiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β+unsafeReceiveResponse c handler = do+    p <- readResponseHeader i+    i' <- readResponseBody p i++    handler p i'+  where+    i = cIn c++{- |+Use this for the common case of the HTTP methods that only send+headers and which have no entity body, i.e. 'GET' requests.+-}+emptyBody :: OutputStream Builder -> IO ()+emptyBody _ = return ()++{- |+Sometimes you just want to send some bytes to the server as a the body of your+request. This is easy to use, but if you're doing anything massive use+'inputStreamBody'; if you're sending a file use 'fileBody'; if you have an+object that needs to be sent as JSON use 'jsonBody'+-}+simpleBody :: ByteString -> OutputStream Builder -> IO ()+simpleBody x' o = do+    let b = Builder.fromByteString x'+    Streams.write (Just b) o++{- |+Specify a local file to be sent to the server as the body of the+request.++You use this partially applied:++>     sendRequest c q (fileBody "/etc/passwd")++Note that the type of @(fileBody \"\/path\/to\/file\")@ is just what+you need for the third argument to 'sendRequest', namely++>>> :t filePath "hello.txt"+:: OutputStream Builder -> IO ()+-}++{-+    Relies on Streams.withFileAsInput generating (very) large chunks [which it+    does]. A more efficient way to do this would be interesting.+-}+fileBody :: FilePath -> OutputStream Builder -> IO ()+fileBody p o = do+    Streams.withFileAsInput p (\i -> inputStreamBody i o)++{- |+Read from a pre-existing 'InputStream' and pipe that through to the+connection to the server. This is useful in the general case where+something else has handed you stream to read from and you want to use+it as the entity body for the request.++You use this partially applied:++>     i <- getStreamFromVault                    -- magic, clearly+>     sendRequest c q (inputStreamBody i)++This function maps "Builder.fromByteString" over the input, which will+be efficient if the ByteString chunks are large.+-}++{-+    Note that this has to be 'supply' and not 'connect' as we do not+    want the end of stream to prematurely terminate the chunked encoding+    pipeline!+-}+inputStreamBody :: InputStream ByteString -> OutputStream Builder -> IO ()+inputStreamBody i1 o = do+    i2 <- Streams.map Builder.fromByteString i1+    Streams.supply i2 o++{- |+Print the response headers and response body to @stdout@. You can+use this with 'receiveResponse' or one of the convenience functions+when testing. For example, doing:++>     c <- openConnection "kernel.operationaldynamics.com" 58080+>+>     let q = buildRequest1 $ do+>                 http GET "/time"+>+>     sendRequest c q emptyBody+>+>     receiveResponse c debugHandler++would print out:++> HTTP/1.1 200 OK+> Transfer-Encoding: chunked+> Content-Type: text/plain+> Vary: Accept-Encoding+> Server: Snap/0.9.2.4+> Content-Encoding: gzip+> Date: Mon, 21 Jan 2013 06:13:37 GMT+>+> Mon 21 Jan 13, 06:13:37.303Z++or thereabouts.+-}+debugHandler :: Response -> InputStream ByteString -> IO ()+debugHandler p i = do+    S.putStr $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p+    Streams.connect i stdout++{- |+Sometimes you just want the entire response body as a single blob.+This function concatonates all the bytes from the response into a+ByteString. If using the main @http-streams@ API, you would use it+as follows:++>    ...+>    x' <- receiveResponse c simpleHandler+>    ...++The methods in the convenience API all take a function to handle the+response; this function is passed directly to the 'receiveResponse'+call underlying the request. Thus this utility function can be used+for 'get' as well:++>    x' <- get "http://www.example.com/document.txt" simpleHandler++Either way, the usual caveats about allocating a+single object from streaming I/O apply: do not use this if you are+not absolutely certain that the response body will fit in a+reasonable amount of memory.++Note that this function makes no discrimination based on the+response's HTTP status code. You're almost certainly better off+writing your own handler function.+-}+simpleHandler :: Response -> InputStream ByteString -> IO ByteString+simpleHandler _ i1 = do+    i2 <- Streams.map Builder.fromByteString i1+    x <- Streams.fold mappend mempty i2+    return $ Builder.toByteString x++concatHandler :: Response -> InputStream ByteString -> IO ByteString+concatHandler = simpleHandler+{-# DEPRECATED concatHandler "Use simpleHandler instead" #-}++{- |+Shutdown the connection. You need to call this release the+underlying socket file descriptor and related network resources. To+do so reliably, use this in conjunction with 'openConnection' in a+call to 'Control.Exception.bracket':++> --+> -- Make connection, cleaning up afterward+> --+>+> foo :: IO ByteString+> foo = bracket+>    (openConnection "localhost" 80)+>    (closeConnection)+>    (doStuff)+>+> --+> -- Actually use Connection to send Request and receive Response+> --+>+> doStuff :: Connection -> IO ByteString++or, just use 'withConnection'.++While returning a ByteString is probably the most common use case,+you could conceivably do more processing of the response in 'doStuff'+and have it and 'foo' return a different type.+-}+closeConnection :: Connection -> IO ()+closeConnection c = cClose c
+ lib/Network/Http/Inconvenience.hs view
@@ -0,0 +1,753 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2021 Athae Eredh Siniath and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the BSD licence.+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide, not-home #-}++module Network.Http.Inconvenience (+    URL,+    modifyContextSSL,+    establishConnection,+    get,+    post,+    postForm,+    encodedFormBody,+    multipartFormBody,+    Part,+    simplePart,+    filePart,+    inputStreamPart,+    put,+    baselineContextSSL,+    simpleHandler',+    concatHandler',+    jsonBody,+    jsonHandler,+    TooManyRedirects (..),+    HttpClientError (..),+    -- for testing+    splitURI,+    parseURL,+) where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (+    fromByteString,+    fromLazyByteString,+    fromWord8,+    toByteString,+ )+import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString)+import Control.Exception (Exception, bracket, throw)+import Data.Aeson (FromJSON, Result (..), ToJSON, encode, fromJSON)+import Data.Aeson.Parser (json')+import Data.Bits (Bits (..))+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.ByteString.Internal (c2w, w2c)+import Data.Char (intToDigit)+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.List (intersperse)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Typeable (Typeable)+import Data.Word (Word16)+import GHC.Exts+import GHC.Word (Word8 (..))+import Network.URI (+    URI (..),+    URIAuth (..),+    escapeURIString,+    isAbsoluteURI,+    isAllowedInURI,+    parseRelativeReference,+    parseURI,+    uriToString,+ )+import OpenSSL (withOpenSSL)+import OpenSSL.Session (SSLContext)+import qualified OpenSSL.Session as SSL+import System.FilePath.Posix (takeFileName)+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Streams+import qualified System.IO.Streams.Attoparsec as Streams+import System.IO.Unsafe (unsafePerformIO)++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid (..), mappend)+#endif++import Network.Http.Connection+import Network.Http.Internal+import Network.Http.RequestBuilder++-- (see also http://downloads.haskell.org/~ghc/8.4.2/docs/html/users_guide/phases.html#standard-cpp-macros+-- for a list of predefined CPP macros provided by GHC and/or Cabal; see also the cabal user's guide)+#if defined(linux_HOST_OS) || defined(freebsd_HOST_OS)+import System.Directory (doesDirectoryExist)+#endif++type URL = ByteString++------------------------------------------------------------------------------++{- |+URL-escapes a string (see+<http://tools.ietf.org/html/rfc2396.html#section-2.4>)+-}+urlEncode :: ByteString -> URL+urlEncode = Builder.toByteString . urlEncodeBuilder+{-# INLINE urlEncode #-}++{- |+URL-escapes a string (see+<http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.+-}+urlEncodeBuilder :: ByteString -> Builder+urlEncodeBuilder = go mempty+  where+    go !b !s = maybe b' esc (S.uncons y)+      where+        (x, y) = S.span (flip HashSet.member urlEncodeTable) s+        b' = b `mappend` Builder.fromByteString x+        esc (c, r) =+            let b'' =+                    if c == ' '+                        then b' `mappend` Builder.fromWord8 (c2w '+')+                        else b' `mappend` hexd c+             in go b'' r++hexd :: Char -> Builder+hexd c0 =+    Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi+        `mappend` Builder.fromWord8 low+  where+    !c = c2w c0+    toDigit = c2w . intToDigit+    !low = toDigit $ fromEnum $ c .&. 0xf+    !hi = toDigit $ (c .&. 0xf0) `shiftr` 4++    shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL'# a# b#))+#if MIN_VERSION_base(4,16,0)+    uncheckedShiftRL'# a# b# = word8ToWord# (uncheckedShiftRLWord8# a# b#)+#else+    uncheckedShiftRL'# = uncheckedShiftRL#+#endif++urlEncodeTable :: HashSet Char+urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0 .. 255]+  where+    f c+        | c >= 'A' && c <= 'Z' = True+        | c >= 'a' && c <= 'z' = True+        | c >= '0' && c <= '9' = True+    f c = c `elem` ("$-_.!~*'()," :: String)++------------------------------------------------------------------------------++{-+    The default SSLContext used by the convenience APIs in the http-streams+    library. This is a kludge, unsafe bad yada yada. The technique, however,+    was described on a Haskell Wiki page, so that makes it an officially+    supported kludge. The justification for doing this is a) the functions+    accessing this IORef are themselves all in the IO monad, and b) these+    contortions are necessary to allow the library to be used for https:// URLs+    *without* requiring the developer to do 'withOpenSSL'.+-}+global :: IORef SSLContext+global = unsafePerformIO $ do+    ctx <- baselineContextSSL+    newIORef ctx+{-# NOINLINE global #-}++{- |+Modify the context being used to configure the SSL tunnel used by+the convenience API functions to make @https://@ connections. The+default is that setup by 'baselineContextSSL'.+-}+modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO ()+modifyContextSSL f = do+    ctx <- readIORef global+    ctx' <- f ctx+    writeIORef global ctx'++{- |+Given a URL, work out whether it is normal, secure, or unix domain,+and then open the connection to the webserver including setting the+appropriate default port if one was not specified in the URL. This+is what powers the convenience API, but you may find it useful in+composing your own similar functions.++For example (on the assumption that your server behaves when given+an absolute URI as the request path), this will open a connection+to server @www.example.com@ port @443@ and request @/photo.jpg@:++>     let url = "https://www.example.com/photo.jpg"+>+>     c <- establishConnection url+>     let q = buildRequest1 $ do+>                 http GET url+>     ...+-}+establishConnection :: URL -> IO (Connection)+establishConnection r' = do+    establish u+  where+    u = parseURL r'+{-# INLINE establishConnection #-}++establish :: URI -> IO (Connection)+establish u =+    case scheme of+        "http:" -> do+            openConnection host port+        "https:" -> do+            ctx <- readIORef global+            openConnectionSSL ctx host ports+        "unix:" -> do+            openConnectionUnix $ uriPath u+        _ -> error ("Unknown URI scheme " ++ scheme)+  where+    scheme = uriScheme u++    auth = case uriAuthority u of+        Just x -> x+        Nothing -> URIAuth "" "localhost" ""++    host = S.pack (uriRegName auth)+    port = case uriPort auth of+        "" -> 80+        _ -> read $ tail $ uriPort auth :: Word16+    ports = case uriPort auth of+        "" -> 443+        _ -> read $ tail $ uriPort auth :: Word16++{- |+Creates a basic SSL context. This is the SSL context used if you make an+@\"https:\/\/\"@ request using one of the convenience functions. It+configures OpenSSL to use the default set of ciphers.++On Linux, OpenBSD and FreeBSD systems, this function also configures+OpenSSL to verify certificates using the system/distribution supplied+certificate authorities' certificates++On other systems, /no certificate validation is performed/ by the+generated 'SSLContext' because there is no canonical place to find+the set of system certificates. When using this library on such system,+you are encouraged to install the system+certificates somewhere and create your own 'SSLContext'.+-}++{-+    We would like to turn certificate verification on for everyone, but+    this has proved contingent on leveraging platform specific mechanisms+    to reach the certificate store. That logic should probably be in+    hsopenssl, but feel free to change this as appropriate for your OS.+-}+baselineContextSSL :: IO SSLContext+baselineContextSSL = withOpenSSL $ do+    ctx <- SSL.context+    SSL.contextSetDefaultCiphers ctx+#if defined(darwin_HOST_OS)+    SSL.contextSetVerificationMode ctx SSL.VerifyNone+#elif defined(mingw32_HOST_OS)+    SSL.contextSetVerificationMode ctx SSL.VerifyNone+#elif defined(freebsd_HOST_OS)+    SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem"+    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing+#elif defined(openbsd_HOST_OS)+    SSL.contextSetCAFile ctx "/etc/ssl/cert.pem"+    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing+#else+    fedora <- doesDirectoryExist "/etc/pki/tls"+    if fedora+        then do+            SSL.contextSetCAFile ctx "/etc/pki/tls/certs/ca-bundle.crt"+        else do+            SSL.contextSetCADirectory ctx "/etc/ssl/certs"+    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing+#endif+    return ctx++parseURL :: URL -> URI+parseURL r' =+    case parseURI r of+        Just u -> u+        Nothing -> error ("Can't parse URI " ++ r)+  where+    r = escapeURIString isAllowedInURI $ T.unpack $ T.decodeUtf8 r'++------------------------------------------------------------------------------++{-+    Account for bug where "http://www.example.com" is parsed with no+    path element, resulting in an illegal HTTP request line.+-}++pathFrom :: URI -> ByteString+pathFrom u = case url of+    "" -> "/"+    _ -> url+  where+    url =+        T.encodeUtf8 $! T.pack+            $! concat [uriPath u, uriQuery u, uriFragment u]++------------------------------------------------------------------------------++{- |+Issue an HTTP GET request and pass the resultant response to the+supplied handler function. This code will silently follow redirects,+to a maximum depth of 5 hops.++The handler function is as for 'receiveResponse', so you can use one+of the supplied convenience handlers if you're in a hurry:++>     x' <- get "http://www.bbc.co.uk/news/" concatHandler++But as ever the disadvantage of doing this is that you're not doing+anything intelligent with the HTTP response status code. If you want+an exception raised in the event of a non @2xx@ response, you can use:++>     x' <- get "http://www.bbc.co.uk/news/" concatHandler'++but for anything more refined you'll find it easy to simply write+your own handler function.++Throws 'TooManyRedirects' if more than 5 redirects are thrown.+-}+get ::+    -- | Resource to GET from.+    URL ->+    -- | Handler function to receive the response from the server.+    (Response -> InputStream ByteString -> IO β) ->+    IO β+get r' handler = getN 0 r' handler++getN n r' handler = do+    bracket+        (establish u)+        (teardown)+        (process)+  where+    teardown = closeConnection++    u = parseURL r'++    q = buildRequest1 $ do+        http GET (pathFrom u)+        setAccept "*/*"++    process c = do+        sendRequest c q emptyBody++        receiveResponse c (wrapRedirect u n handler)++{-+    This is fairly simple-minded. Improvements could include reusing+    the Connection if the redirect is to the same host, and closing+    the original Connection if it is not. These are both things that+    can be done manually if using the full API, so not worried about+    it for now.+-}++wrapRedirect ::+    URI ->+    Int ->+    (Response -> InputStream ByteString -> IO β) ->+    Response ->+    InputStream ByteString ->+    IO β+wrapRedirect u n handler p i = do+    if (s == 301 || s == 302 || s == 303 || s == 307)+        then case lm of+            Just l -> getN n' (splitURI u l) handler+            Nothing -> handler p i+        else handler p i+  where+    s = getStatusCode p+    lm = getHeader p "Location"+    !n' =+        if n < 5+            then n + 1+            else throw $! TooManyRedirects n++splitURI :: URI -> URL -> URL+splitURI old new' =+    let new = S.unpack new'+     in if isAbsoluteURI new+            then new'+            else+                let rel = parseRelativeReference new+                 in case rel of+                        Nothing -> new'+                        Just x ->+                            S.pack $+                                uriToString+                                    id+                                    old+                                        { uriPath = uriPath x+                                        , uriQuery = uriQuery x+                                        , uriFragment = uriFragment x+                                        }+                                    ""++data TooManyRedirects = TooManyRedirects Int+    deriving (Typeable, Show, Eq)++instance Exception TooManyRedirects++{- |+Send content to a server via an HTTP POST request. Use this+function if you have an 'OutputStream' with the body content.+-}+post ::+    -- | Resource to POST to.+    URL ->+    -- | MIME type of the request body being sent.+    ContentType ->+    -- | Handler function to write content to server.+    (OutputStream Builder -> IO α) ->+    -- | Handler function to receive the response from the server.+    (Response -> InputStream ByteString -> IO β) ->+    IO β+post r' t body handler = do+    bracket+        (establish u)+        (teardown)+        (process)+  where+    teardown = closeConnection++    u = parseURL r'++    q = buildRequest1 $ do+        http POST (pathFrom u)+        setAccept "*/*"+        setContentType t++    process c = do+        _ <- sendRequest c q body++        x <- receiveResponse c handler+        return x++{- |+Send form data to a server via an HTTP POST request. This is the+usual use case; most services expect the body to be MIME type+@application/x-www-form-urlencoded@ as this is what conventional+web browsers send on form submission. If you want to POST to a URL+with an arbitrary Content-Type, use 'post'.+-}+postForm ::+    -- | Resource to POST to.+    URL ->+    -- | List of name=value pairs. Will be sent URL-encoded.+    [(ByteString, ByteString)] ->+    -- | Handler function to receive the response from the server.+    (Response -> InputStream ByteString -> IO β) ->+    IO β+postForm r' nvs handler = do+    bracket+        (establish u)+        (teardown)+        (process)+  where+    teardown = closeConnection++    u = parseURL r'++    q = buildRequest1 $ do+        http POST (pathFrom u)+        setAccept "*/*"+        setContentType "application/x-www-form-urlencoded"++    process c = do+        _ <- sendRequest c q (encodedFormBody nvs)++        x <- receiveResponse c handler+        return x++{- |+Specify name/value pairs to be sent to the server in the manner+used by web browsers when submitting a form via a POST request.+Parameters will be URL encoded per RFC 2396 and combined into a+single string which will be sent as the body of your request.++You use this partially applied:++>     let nvs = [("name","Kermit"),+>                ("type","frog")]+>                ("role","stagehand")]+>+>     sendRequest c q (encodedFormBody nvs)++Note that it's going to be up to you to call 'setContentType' with+a value of @\"application/x-www-form-urlencoded\"@ when building the+Request object; the 'postForm' convenience (which uses this+@encodedFormBody@ function) takes care of this for you, obviously.+-}+encodedFormBody :: [(ByteString, ByteString)] -> OutputStream Builder -> IO ()+encodedFormBody nvs o = do+    Streams.write (Just b) o+  where+    b = mconcat $ intersperse (Builder.fromString "&") $ map combine nvs++    combine :: (ByteString, ByteString) -> Builder+    combine (n', v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", urlEncodeBuilder v']++{- |+Build a list of parts into an upload body.++You use this partially applied:++>     boundary <- randomBoundary+>+>     let q = buildRequest1 $ do+>           http POST "/api/v1/upload"+>           setContentMultipart boundary+>+>     let parts =+>             [ simplePart "metadata" Nothing metadata+>             , filePart "submission" (Just "audio/wav") filepath+>             ]+>+>     sendRequest c q (multipartFormBody boundary parts)++You /must/ have called 'setContentMultipart' when forming the request or the+request body you are sending will be invalid and (obviously) you must pass in+that same 'Boundary' value when calling this function.+-}+multipartFormBody :: Boundary -> [Part] -> OutputStream Builder -> IO ()+multipartFormBody boundary parts o = do+    mapM_ handlePart parts+    handleEnding+  where+    handlePart :: Part -> IO ()+    handlePart (Part field possibleContentType possibleFilename action) = do+        let h' = composeMultipartBytes boundary field possibleFilename possibleContentType+        Streams.write (Just h') o+        action o++    handleEnding :: IO ()+    handleEnding = do+        Streams.write (Just (composeMultipartEnding boundary)) o++{- |+Information about each of the parts of a @multipart/form-data@ form upload.+Build these with 'simplePart', 'filePart', or 'inputStreamPart'.+-}+data Part = Part+    { partFieldName :: FieldName+    , partContentType :: Maybe ContentType+    , partFilename :: Maybe FilePath+    , partDataHandler :: OutputStream Builder -> IO ()+    }++{- |+Given a simple static set of bytes, send them as a part in a multipart form+upload. You need to specify the name of the field for the form, and optionally+can supply a MIME content-type.+-}+simplePart :: FieldName -> Maybe ContentType -> ByteString -> Part+simplePart name possibleContentType x' =+    let action o = do+            i1 <- Streams.fromByteString x'+            i2 <- Streams.map Builder.fromByteString i1+            Streams.supply i2 o+     in Part name possibleContentType Nothing action++{- |+The most common case in using multipart form data is to upload a file. Specify+the name of the field, optionally a MIME content-type, and then the path to+the file to be transmitted. The filename (without directory) will be used to+name the file to the server.+-}+filePart :: FieldName -> Maybe ContentType -> FilePath -> Part+filePart name possibleContentType path =+    let action o = do+            Streams.withFileAsInput+                path+                ( \i1 -> do+                    i2 <- Streams.map Builder.fromByteString i1+                    Streams.supply i2 o+                )++        filename = takeFileName path+     in Part name possibleContentType (Just filename) action++{- |+Build a piece of a multipart submission from an 'InputStream'. You need to+specify a field name for this piece of the submission, and can optionally+indicate the MIME type and a filename (if what you are sending is going to be+interpreted as a file).+-}+inputStreamPart :: FieldName -> Maybe ContentType -> Maybe FilePath -> InputStream ByteString -> Part+inputStreamPart name possibleContentType possilbeFilename i1 =+    let action o = do+            i2 <- Streams.map Builder.fromByteString i1+            Streams.supply i2 o+     in Part name possibleContentType possilbeFilename action++{- |+Place content on the server at the given URL via an HTTP PUT+request, specifying the content type and a function to write the+content to the supplied 'OutputStream'. You might see:++>     put "http://s3.example.com/bucket42/object149" "text/plain"+>         (fileBody "hello.txt") (\p i -> do+>             putStr $ show p+>             Streams.connect i stdout)+-}+put ::+    -- | Resource to PUT to.+    URL ->+    -- | MIME type of the request body being sent.+    ContentType ->+    -- | Handler function to write content to server.+    (OutputStream Builder -> IO α) ->+    -- | Handler function to receive the response from the server.+    (Response -> InputStream ByteString -> IO β) ->+    IO β+put r' t body handler = do+    bracket+        (establish u)+        (teardown)+        (process)+  where+    teardown = closeConnection++    u = parseURL r'++    q = buildRequest1 $ do+        http PUT (pathFrom u)+        setAccept "*/*"+        setHeader "Content-Type" t++    process c = do+        _ <- sendRequest c q body++        x <- receiveResponse c handler+        return x++{- |+A special case of 'concatHandler', this function will return the+entire response body as a single ByteString, but will throw+'HttpClientError' if the response status code was other than @2xx@.+-}+simpleHandler' :: Response -> InputStream ByteString -> IO ByteString+simpleHandler' p i =+    if s >= 300+        then throw (HttpClientError s m)+        else simpleHandler p i+  where+    s = getStatusCode p+    m = getStatusMessage p++concatHandler' :: Response -> InputStream ByteString -> IO ByteString+concatHandler' = simpleHandler'++data HttpClientError = HttpClientError Int ByteString+    deriving (Typeable)++instance Exception HttpClientError++instance Show HttpClientError where+    show (HttpClientError s msg) = Prelude.show s ++ " " ++ S.unpack msg++{-+    There should probably also be HttpServerError and maybe even+    HttpRedirectError, but as these names don't seem to show up+    in the runtime when raised, not sure it's worth the bother. It's+    not like we'd want anything different in their Show instances.+-}++{- |+If you've got an object of a type with a 'ToJSON' instance and you need to+send that object as JSON up to a web service API, this can help.++You use this partially applied:++>    sendRequest c q (jsonBody thing)+-}+jsonBody :: ToJSON a => a -> OutputStream Builder -> IO ()+jsonBody thing o = do+    let b = Builder.fromLazyByteString (encode thing)+    Streams.write (Just b) o++{- |+If you're working with a data stream that is in @application/json@,+then chances are you're using @aeson@ to handle the JSON to Haskell+decoding. If so, then this helper function might be of use.++>     v <- get "http://api.example.com/v1/" jsonHandler++This function feeds the input body to the 'Data.Aeson.Parser.json''+@attoparsec@ Parser in order to get the aeson Value type. This is then+marshalled to your type represeting the source data, via the FromJSON+typeclass.++The above example was actually insufficient; when working with+@aeson@ you need to fix the type so it knows what FromJSON instance+to use. Let's say you're getting Person objects, then it would be++>     v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person++assuming your Person type had a FromJSON instance, of course.++/Note/++This function parses a single top level JSON object or array, which+is all you're supposed to get if it's a valid document. People do+all kinds of crazy things though, so beware. Also, this function (like the+"concatHander" convenience) loads the entire response into memory; it's+not /streaming/; if you're receiving a document which is (say) a very+long array of objects then you may want to implement your own+handler function, perhaps using "Streams.parserToInputStream" and+the 'Data.Aeson.Parser' combinators directly — with a result type of+InputStream Value, perhaps — by which you could then iterate over+the Values one at a time in constant space.+-}++{-+    This looks simple. It wasn't. The types involved are rediculous to+    disentangle. The biggest problem is that the Parser type used in+    [aeson] is *NOT* the Parser type from [attoparsec]. But the parsing+    function `json` and `json` from Aeson use the attoparsec Parser even+    though the rest of the top level page is all about Aeson's parser as+    used in FromJSON!++    Anyway, `json` and `json'` are [attoparsec] Parser [aeson] Value; we+    run that using the [io-streams] convenience function+    `parseFromStream` which gets us a Value which is the intermediate+    abstract syntax tree for a  JSON document. Then (and this was hard+    to find) to work with that in terms of the FromJSON typeclass, you+    use the `fromJSON` function which has type (FromJSON α => Value ->+    Result α). Then finally, pull the result out of it. Why in Bog's+    name this wasn't just Either I'll never know.+-}+jsonHandler ::+    (FromJSON α) =>+    Response ->+    InputStream ByteString ->+    IO α+jsonHandler _ i = do+    v <- Streams.parseFromStream json' i -- Value+    let r = fromJSON v -- Result+    case r of+        (Success a) -> return a+        (Error str) -> error str
+ lib/Network/Http/ResponseParser.hs view
@@ -0,0 +1,273 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2021 Athae Eredh Siniath and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the BSD licence.+--+-- Significant portions of this file were written while studying+-- the HTTP request parser implementation in the Snap Framework;+-- snap-core's src/Snap/Internal/Parsing.hs and snap-server's+-- src/Snap/Internal/Http/Parser.hs, and various utility functions+-- have been cloned from there.+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide, not-home #-}++module Network.Http.ResponseParser (+    readResponseHeader,+    readResponseBody,+    UnexpectedCompression (..),+    -- for testing+    readDecimal,+) where++import Prelude hiding (take, takeWhile)++import Control.Exception (Exception, throwIO)+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Data.Attoparsec.ByteString.Char8+import Data.Bits (Bits (..))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.CaseInsensitive (mk)+import Data.Char (ord)+import Data.Int (Int64)+import Data.Typeable (Typeable)+import System.IO.Streams (Generator, InputStream)+import qualified System.IO.Streams as Streams+import qualified System.IO.Streams.Attoparsec as Streams++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import Network.Http.Internal+import Network.Http.Utilities++{-+    The chunk size coming down from the server is somewhat arbitrary;+    it's really just an indication of how many bytes need to be read+    before the next size marker or end marker - neither of which has+    anything to do with streaming on our side. Instead, we'll feed+    bytes into our InputStream at an appropriate intermediate size.+-}+__BITE_SIZE__ :: Int+__BITE_SIZE__ = 32 * 1024++{-+    Process the reply from the server up to the end of the headers as+    deliniated by a blank line.+-}+readResponseHeader :: InputStream ByteString -> IO Response+readResponseHeader i = do+    (sc, sm) <- Streams.parseFromStream parseStatusLine i++    hs <- readHeaderFields i++    let h = buildHeaders hs+    let te = case lookupHeader h "Transfer-Encoding" of+            Just x' ->+                if mk x' == "chunked"+                    then Chunked+                    else None+            Nothing -> None++    let ce = case lookupHeader h "Content-Encoding" of+            Just x' ->+                if mk x' == "gzip"+                    then Gzip+                    else Identity+            Nothing -> Identity++    let nm = case lookupHeader h "Content-Length" of+            Just x' -> Just (readDecimal x' :: Int64)+            Nothing -> case sc of+                204 -> Just 0+                304 -> Just 0+                100 -> Just 0+                _ -> Nothing++    return+        Response+            { pStatusCode = sc+            , pStatusMsg = sm+            , pTransferEncoding = te+            , pContentEncoding = ce+            , pContentLength = nm+            , pHeaders = h+            }++parseStatusLine :: Parser (Int, ByteString)+parseStatusLine = do+    sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' '+    sm <- takeTill (== '\r') <* crlf+    return (sc, sm)+  where+    version c = c == '1' || c == '0'++crlf :: Parser ByteString+crlf = string "\r\n"++---------------------------------------------------------------------++{-+    Switch on the encoding and compression headers, wrapping the raw+    InputStream to present the entity body's actual bytes.+-}+readResponseBody :: Response -> InputStream ByteString -> IO (InputStream ByteString)+readResponseBody p i1 = do+    i2 <- case t of+        None -> case l of+            Just n -> readFixedLengthBody i1 n+            Nothing -> readUnlimitedBody i1+        Chunked -> readChunkedBody i1++    i3 <- case c of+        Identity -> return i2+        Gzip -> readCompressedBody i2+        Deflate -> throwIO (UnexpectedCompression $ show c)++    return i3+  where+    t = pTransferEncoding p+    c = pContentEncoding p+    l = pContentLength p++readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α+readDecimal str' =+    S.foldl' f 0 x'+  where+    f !cnt !i = cnt * 10 + digitToInt i++    x' = head $ S.words str'++    {-# INLINE digitToInt #-}+    digitToInt :: (Enum α, Num α, Bits α) => Char -> α+    digitToInt c+        | c >= '0' && c <= '9' = toEnum $! ord c - ord '0'+        | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit"+{-# INLINE readDecimal #-}++data UnexpectedCompression = UnexpectedCompression String+    deriving (Typeable, Show)++instance Exception UnexpectedCompression++---------------------------------------------------------------------++{-+    Process a response body in chunked transfer encoding, taking the+    resultant bytes and reproducing them as an InputStream+-}+readChunkedBody :: InputStream ByteString -> IO (InputStream ByteString)+readChunkedBody i1 = do+    i2 <- Streams.fromGenerator (consumeChunks i1)+    return i2++{-+    For a response body in chunked transfer encoding, iterate over+    the individual chunks, reading the size parameter, then+    looping over that chunk in bites of at most __BYTE_SIZE__,+    yielding them to the receiveResponse InputStream accordingly.+-}+consumeChunks :: InputStream ByteString -> Generator ByteString ()+consumeChunks i1 = do+    !n <- parseSize++    if n > 0+        then do+            -- read one or more bites, then loop to next chunk+            go n+            skipCRLF+            consumeChunks i1+        else do+            -- skip "trailers" and consume final CRLF+            skipEnd+  where+    go 0 = return ()+    go !n = do+        (!x', !r) <- liftIO $ readN n i1+        Streams.yield x'+        go r++    parseSize = do+        n <- liftIO $ Streams.parseFromStream transferChunkSize i1+        return n++    skipEnd = do+        liftIO $ do+            _ <- readHeaderFields i1+            return ()++    skipCRLF = do+        liftIO $ do+            _ <- Streams.parseFromStream crlf i1+            return ()++{-+    Read the specified number of bytes up to a maximum of __BITE_SIZE__,+    returning a resultant ByteString and the number of bytes remaining.+-}++readN :: Int -> InputStream ByteString -> IO (ByteString, Int)+readN n i1 = do+    !x' <- Streams.readExactly p i1+    return (x', r)+  where+    !d = n - size++    !p =+        if d > 0+            then size+            else n++    !r =+        if d > 0+            then d+            else 0++    size = __BITE_SIZE__++transferChunkSize :: Parser (Int)+transferChunkSize = do+    !n <- hexadecimal+    void (takeTill (== '\r'))+    void crlf+    return n++---------------------------------------------------------------------++{-+    This has the rather crucial side effect of terminating the stream+    after the requested number of bytes. Otherwise, code handling+    responses waits on more input until an HTTP timeout occurs.+-}+readFixedLengthBody :: InputStream ByteString -> Int64 -> IO (InputStream ByteString)+readFixedLengthBody i1 n = do+    i2 <- Streams.takeBytes n i1+    return i2++{-+    On the other hand, there is the (predominently HTTP/1.0) case+    where there is no content length sent and no chunking, with the+    result that only the connection closing marks the end of the+    response body.+-}+readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString)+readUnlimitedBody i1 = do+    return i1++---------------------------------------------------------------------++readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString)+readCompressedBody i1 = do+    i2 <- Streams.gunzip i1+    return i2
+ lib/Network/Http/Utilities.hs view
@@ -0,0 +1,269 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2021 Athae Eredh Siniath and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the BSD licence.+--+-- This file is essentially a clone of Snap.Internal.Parsing,+-- the HTTP request parser implementation in the Snap Framework;+-- snap-core's src/Snap/Internal/Parsing.hs and snap-server's+-- src/Snap/Internal/Http/Parser.hs, copied here to specialize+-- it to Response parsing. This code replaces the attoparsec+-- based implementation formerly in ResponseParser, but is+-- kept separate to aid syncing changes from snap-core as they+-- become available.+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide, not-home #-}++module Network.Http.Utilities (+    readResponseLine,+    readHeaderFields,+) where++------------------------------------------------------------------------------+import Control.Exception (throwIO)+import Control.Monad (when)+import Data.Bits+import qualified Data.ByteString.Char8 as S+import Data.ByteString.Internal (ByteString, w2c)+import qualified Data.ByteString.Unsafe as S+import Data.Char hiding (digitToInt, isDigit, isSpace)+import GHC.Exts (Int (..), Int#, (+#))+import System.IO.Streams (InputStream)+import qualified System.IO.Streams as Streams+import Prelude hiding (head, take, takeWhile)++----------------------------------------------------------------------------++import Network.Http.Types++------------------------------------------------------------------------------++{-+    This is vestigial; originally it was the Request parsing+    code in Snap. Keeping it here until we can use if for+    response parsing.+-}+parseRequest :: InputStream ByteString -> IO (Maybe Request)+parseRequest input = do+    eof <- Streams.atEOF input+    if eof+        then return Nothing+        else do+            line <- readResponseLine input+            let (!mStr, !s) = bSp line+            let (!uri, !vStr) = bSp s+            let !version = pVer vStr :: (Int, Int)++            --      hdrs    <- readHeaderFields input+            return $! Nothing+  where+    pVer s =+        if "HTTP/" `S.isPrefixOf` s+            then pVers (S.unsafeDrop 5 s)+            else (1, 0)++    bSp = splitCh ' '++    pVers s = (c, d)+      where+        (!a, !b) = splitCh '.' s+        !c = unsafeFromNat a+        !d = unsafeFromNat b++{-+    Read a single line of an HTTP response.+-}+readResponseLine :: InputStream ByteString -> IO ByteString+readResponseLine input = go []+  where+    throwNoCRLF =+        throwIO $+            HttpParseException "parse error: expected line ending in crlf"++    throwBadCRLF =+        throwIO $+            HttpParseException "parse error: got cr without subsequent lf"++    go !l = do+        !mb <- Streams.read input+        !s <- maybe throwNoCRLF return mb++        case findCRLF s of+            FoundCRLF idx# -> foundCRLF l s idx#+            NoCR -> noCRLF l s+            LastIsCR idx# -> lastIsCR l s idx#+            _ -> throwBadCRLF++    foundCRLF l s idx# = do+        let !i1 = (I# idx#)+        let !i2 = (I# (idx# +# 2#))+        let !a = S.unsafeTake i1 s+        when (i2 < S.length s) $ do+            let !b = S.unsafeDrop i2 s+            Streams.unRead b input++        -- Optimize for the common case: dl is almost always "id"+        let !out = if null l then a else S.concat (reverse (a : l))+        return out++    noCRLF l s = go (s : l)++    lastIsCR l s idx# = do+        !t <- Streams.read input >>= maybe throwNoCRLF return+        if S.null t+            then lastIsCR l s idx#+            else do+                let !c = S.unsafeHead t+                if c /= 10+                    then throwBadCRLF+                    else do+                        let !a = S.unsafeTake (I# idx#) s+                        let !b = S.unsafeDrop 1 t+                        when (not $ S.null b) $ Streams.unRead b input+                        let !out = if null l then a else S.concat (reverse (a : l))+                        return out++------------------------------------------------------------------------------+data CS+    = FoundCRLF !Int#+    | NoCR+    | LastIsCR !Int#+    | BadCR++------------------------------------------------------------------------------+findCRLF :: ByteString -> CS+findCRLF b =+    case S.elemIndex '\r' b of+        Nothing -> NoCR+        Just !i@(I# i#) ->+            let !i' = i + 1+             in if i' < S.length b+                    then+                        if S.unsafeIndex b i' == 10+                            then FoundCRLF i#+                            else BadCR+                    else LastIsCR i#+{-# INLINE findCRLF #-}++------------------------------------------------------------------------------+splitCh :: Char -> ByteString -> (ByteString, ByteString)+splitCh !c !s = maybe (s, S.empty) f (S.elemIndex c s)+  where+    f !i =+        let !a = S.unsafeTake i s+            !b = S.unsafeDrop (i + 1) s+         in (a, b)+{-# INLINE splitCh #-}++------------------------------------------------------------------------------+breakCh :: Char -> ByteString -> (ByteString, ByteString)+breakCh !c !s = maybe (s, S.empty) f (S.elemIndex c s)+  where+    f !i =+        let !a = S.unsafeTake i s+            !b = S.unsafeDrop i s+         in (a, b)+{-# INLINE breakCh #-}++------------------------------------------------------------------------------+splitHeader :: ByteString -> (ByteString, ByteString)+splitHeader !s = maybe (s, S.empty) f (S.elemIndex ':' s)+  where+    l = S.length s++    f i =+        let !a = S.unsafeTake i s+         in (a, skipSp (i + 1))++    skipSp !i+        | i >= l = S.empty+        | otherwise =+            let c = S.unsafeIndex s i+             in if isLWS $ w2c c+                    then skipSp $ i + 1+                    else S.unsafeDrop i s+{-# INLINE splitHeader #-}++------------------------------------------------------------------------------+isLWS :: Char -> Bool+isLWS c = c == ' ' || c == '\t'+{-# INLINE isLWS #-}++------------------------------------------------------------------------------++{-+    Read the remainder of the response message's header section,+    parsing into key/value pairs. Note that this function terminates+    when it hits the "blank" line (ie, CRLF CRLF pair), which it+    consumes.+-}+readHeaderFields :: InputStream ByteString -> IO [(ByteString, ByteString)]+readHeaderFields input = do+    f <- go id+    return $! f []+  where+    go !dlistSoFar = do+        line <- readResponseLine input+        if S.null line+            then return dlistSoFar+            else do+                let (!k, !v) = splitHeader line+                vf <- pCont id+                let vs = vf []+                let !v' = if null vs then v else S.concat (v : vs)+                let !t = (k, v')+                go (dlistSoFar . (t :))+      where+        trimBegin = S.dropWhile isLWS++        pCont !dlist = do+            mbS <- Streams.peek input+            maybe+                (return dlist)+                ( \s ->+                    if S.null s+                        then Streams.read input >> pCont dlist+                        else+                            if isLWS $ w2c $ S.unsafeHead s+                                then procCont dlist+                                else return dlist+                )+                mbS++        procCont !dlist = do+            line <- readResponseLine input+            let !t = trimBegin line+            pCont (dlist . (" " :) . (t :))++-----------------------+-- utility functions --+-----------------------++------------------------------------------------------------------------------++-- | Note: only works for nonnegative naturals+unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a+unsafeFromNat = S.foldl' f 0+  where+    zero = ord '0'+    f !cnt !i = cnt * 10 + toEnum (digitToInt i)++    digitToInt c =+        if d >= 0 && d <= 9+            then d+            else error $ "bad digit: '" ++ [c] ++ "'"+      where+        !d = ord c - zero+{-# INLINE unsafeFromNat #-}
− src/Network/Http/Client.hs 
@@ -1,176 +0,0 @@------ HTTP client for use with io-streams------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is--- made available to you by its authors as open source software:--- you can redistribute it and/or modify it under the terms of--- the BSD licence.-----{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS -fno-warn-orphans #-}---- |--- Maintainer: Andrew Cowie--- Stability: Experimental------ /Overview/------ A simple HTTP client library, using the Snap Framework's @io-streams@--- library to handle the streaming I\/O. The @http-streams@ API is designed--- for ease of use when querying web services and dealing with the result.------ Given:------ > {-# LANGUAGE OverloadedStrings #-}--- >--- > import System.IO.Streams (InputStream, OutputStream, stdout)--- > import qualified System.IO.Streams as Streams--- > import qualified Data.ByteString as S------ and this library:------ > import Network.Http.Client------ the underlying API is straight-forward. In particular, constructing the--- 'Request' to send is quick and to the point:------ @--- main :: IO ()--- main = do--- \    c <- 'openConnection' \"www.example.com\" 80------ \     q <- 'buildRequest' $ do---         'http' GET \"\/\"---         'setAccept' \"text/html\"------ \     'sendRequest' c q 'emptyBody'------ \     `receiveResponse` c (\\p i -> do---         xm <- Streams.read i---         case xm of---             Just x    -> S.putStr x---             Nothing   -> \"\")------ \     'closeConnection' c--- @------ which would print the first chunk of the response back from the--- server. Obviously in real usage you'll do something more interesting--- with the 'Response' in the handler function, and consume the entire--- response body from the InputStream ByteString.------ Because this is all happening in 'IO' (the defining feature of--- @io-streams@!), you can ensure resource cleanup on normal or--- abnormal termination by using @Control.Exception@'s standard--- 'Control.Exception.bracket' function; see 'closeConnection' for an--- example. For the common case we have a utility function which--- wraps @bracket@ for you:------ @--- foo :: IO ByteString--- foo = 'withConnection' ('openConnection' \"www.example.com\" 80) doStuff------ \ doStuff :: Connection -> IO ByteString--- @------ There are also a set of convenience APIs that do just that, along with--- the tedious bits like parsing URLs. For example, to do an HTTP GET and--- stream the response body to stdout, you can simply do:------ @---     'get' \"http:\/\/www.example.com\/file.txt\" (\\p i -> Streams.connect i stdout)--- @------ which on the one hand is \"easy\" while on the other exposes the the--- 'Response' and InputStream for you to read from. Of course, messing--- around with URLs is all a bit inefficient, so if you already have e.g.--- hostname and path, or if you need more control over the request being--- created, then the underlying @http-streams@ API is simple enough to use--- directly.----module Network.Http.Client (-    -- * Connecting to server-    Hostname,-    Port,-    Connection,-    openConnection,--    -- * Building Requests-    -- | You setup a request using the RequestBuilder monad, and-    -- get the resultant Request object by running 'buildRequest'. The-    -- first call doesn't have to be to 'http', but it looks better when-    -- it is, don't you think?-    Method(..),-    RequestBuilder,-    buildRequest,-    http,-    setHostname,-    setAccept,-    setAccept',-    setAuthorizationBasic,-    ContentType,-    setContentType,-    setContentLength,-    setExpectContinue,-    setHeader,--    -- * Sending HTTP request-    Request,-    Response,-    Headers,-    getHostname,-    sendRequest,-    emptyBody,-    fileBody,-    inputStreamBody,-    encodedFormBody,--    -- * Processing HTTP response-    receiveResponse,-    receiveResponseRaw,-    StatusCode,-    getStatusCode,-    getStatusMessage,-    getHeader,-    debugHandler,-    concatHandler,-    concatHandler',-    jsonHandler,--    -- * Resource cleanup-    closeConnection,-    withConnection,--    -- * Convenience APIs-    -- | Some simple functions for making requests with useful defaults.-    -- There's no @head@ function for the usual reason of needing to-    -- avoid collision with @Prelude@.-    ---    -- These convenience functions work with @http@ and @https@, but-    --  note that if you retrieve an @https@ URL, you /must/ wrap your-    -- @main@ function with 'OpenSSL.withOpenSSL' to initialize the-    -- native openssl library code.-    ---    URL,-    get,-    post,-    postForm,-    put,--    -- * Secure connections-    openConnectionSSL,-    baselineContextSSL,-    modifyContextSSL,-    establishConnection,--    -- * Testing support-    makeConnection-) where--import Network.Http.Connection-import Network.Http.Inconvenience-import Network.Http.RequestBuilder-import Network.Http.Types
− src/Network/Http/Connection.hs 
@@ -1,585 +0,0 @@------ HTTP client for use with io-streams------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is--- made available to you by its authors as open source software:--- you can redistribute it and/or modify it under the terms of--- the BSD licence.-----{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DoAndIfThenElse    #-}-{-# LANGUAGE OverloadedStrings  #-}--module Network.Http.Connection (-    Hostname,-    Port,-    Connection(..),-        -- constructors only for testing-    makeConnection,-    withConnection,-    openConnection,-    openConnectionSSL,-    closeConnection,-    getHostname,-    sendRequest,-    receiveResponse,-    receiveResponseRaw,-    emptyBody,-    fileBody,-    inputStreamBody,-    debugHandler,-    concatHandler-) where--import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (flush, fromByteString,-                                                      toByteString)-import qualified Blaze.ByteString.Builder.HTTP as Builder (chunkedTransferEncoding, chunkedTransferTerminator)-import Control.Exception (bracket)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.Monoid (mappend, mempty)-import Data.Word (Word16)-import Network.Socket-import OpenSSL.Session (SSL, SSLContext)-import qualified OpenSSL.Session as SSL-import System.IO.Streams (InputStream, OutputStream, stdout)-import qualified System.IO.Streams as Streams-import qualified System.IO.Streams.SSL as Streams hiding (connect)--import Network.Http.ResponseParser-import Network.Http.Types--{--    This is a String because that's what the uri package works in. There-    was a fairly detailed disucssion on haskell-cafe about this, with-    the conclusion that URLs are composed of characters, not octets.--}--type Hostname = ByteString--type Port = Word16---- | A connection to a web server.----data Connection-    = Connection {-        cHost  :: ByteString,-            -- ^ will be used as the Host: header in the HTTP request.-        cClose :: IO (),-            -- ^ called when the connection should be closed.-        cOut   :: OutputStream Builder,-        cIn    :: InputStream ByteString-    }--instance Show Connection where-    show c =    {-# SCC "Connection.show" #-}-        concat-           ["Host: ",-             S.unpack $ cHost c,-             "\n"]-------- | Create a raw Connection object from the given parts. This is--- primarily of use when teseting, for example:------ > fakeConnection :: IO Connection--- > fakeConnection = do--- >     o  <- Streams.nullOutput--- >     i  <- Streams.nullInput--- >     c  <- makeConnection "www.example.com" (return()) o i--- >     return c------ is an idiom we use frequently in testing and benchmarking, usually--- replacing the InputStream with something like:------ >     x' <- S.readFile "properly-formatted-response.txt"--- >     i  <- Streams.fromByteString x'------ If you're going to do that, keep in mind that you /must/ have CR-LF--- pairs after each header line and between the header and body to--- be compliant with the HTTP protocol; otherwise, parsers will--- reject your message.----makeConnection-    :: ByteString-    -- ^ will be used as the @Host:@ header in the HTTP request.-    -> IO ()-    -- ^ an action to be called when the connection is terminated.-    -> OutputStream ByteString-    -- ^ write end of the HTTP client-server connection.-    -> InputStream ByteString-    -- ^ read end of the HTTP client-server connection.-    -> IO Connection-makeConnection h c o1 i = do-    o2 <- Streams.builderStream o1-    return $! Connection h c o2 i-------- | Given an @IO@ action producing a 'Connection', and a computation--- that needs one, runs the computation, cleaning up the--- @Connection@ afterwards.------ >     x <- withConnection (openConnection "s3.example.com" 80) $ (\c -> do--- >         q <- buildRequest $ do--- >             http GET "/bucket42/object/149"--- >         sendRequest c q emptyBody--- >         ...--- >         return "blah")------ which can make the code making an HTTP request a lot more--- straight-forward.------ Wraps @Control.Exception@'s 'Control.Exception.bracket'.----withConnection :: IO Connection -> (Connection -> IO γ) -> IO γ-withConnection mkC =-    bracket mkC closeConnection-------- | In order to make a request you first establish the TCP--- connection to the server over which to send it.------ Ordinarily you would supply the host part of the URL here and it will--- be used as the value of the HTTP 1.1 @Host:@ field. However, you can--- specify any server name or IP addresss and set the @Host:@ value--- later with 'Network.Http.Client.setHostname' when building the--- request.------ Usage is as follows:------ >     c <- openConnection "localhost" 80--- >     ...--- >     closeConnection c------ More likely, you'll use 'withConnection' to wrap the call in order--- to ensure finalization.------ HTTP pipelining is supported; you can reuse the connection to a--- web server, but it's up to you to ensure you match the number of--- requests sent to the number of responses read, and to process those--- responses in order. This is all assuming that the /server/ supports--- pipelining; be warned that not all do. Web browsers go to--- extraordinary lengths to probe this; you probably only want to do--- pipelining under controlled conditions. Otherwise just open a new--- connection for subsequent requests.----openConnection :: Hostname -> Port -> IO Connection-openConnection h1' p = do-    is <- getAddrInfo (Just hints) (Just h1) (Just $ show p)-    let addr = head is-    let a = addrAddress addr-    s <- socket (addrFamily addr) Stream defaultProtocol--    connect s a-    (i,o1) <- Streams.socketToStreams s--    o2 <- Streams.builderStream o1--    return Connection {-        cHost  = h2',-        cClose = close s,-        cOut   = o2,-        cIn    = i-    }-  where-    hints = defaultHints {addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV]}-    h2' = if p == 80-        then h1'-        else S.concat [ h1', ":", S.pack $ show p ]-    h1  = S.unpack h1'------- | Open a secure connection to a web server.------ You need to wrap this (and subsequent code using this connection)--- within a call to 'OpenSSL.withOpenSSL':------ > import OpenSSL (withOpenSSL)--- >--- > main :: IO ()--- > main = withOpenSSL $ do--- >     ctx <- baselineContextSSL--- >     c <- openConnectionSSL ctx "api.github.com" 443--- >     ...--- >     closeConnection c------ If you want to tune the parameters used in making SSL connections,--- manually specify certificates, etc, then setup your own context:------ > import OpenSSL.Session (SSLContext)--- > import qualified OpenSSL.Session as SSL--- >--- >     ...--- >     ctx <- SSL.context--- >     ...------ See "OpenSSL.Session".------ Crypto is as provided by the system @openssl@ library, as wrapped--- by the @HsOpenSSL@ package and @openssl-streams@.----openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection-openConnectionSSL ctx h1' p = do-    is <- getAddrInfo Nothing (Just h1) (Just $ show p)--    let a = addrAddress $ head is-        f = addrFamily $ head is-    s <- socket f Stream defaultProtocol--    connect s a--    ssl <- SSL.connection ctx s-    SSL.connect ssl--    (i,o1) <- Streams.sslToStreams ssl--    o2 <- Streams.builderStream o1--    return Connection {-        cHost  = h2',-        cClose = closeSSL s ssl,-        cOut   = o2,-        cIn    = i-    }-  where-    h2' :: ByteString-    h2' = if p == 443-        then h1'-        else S.concat [ h1', ":", S.pack $ show p ]-    h1  = S.unpack h1'--closeSSL :: Socket -> SSL -> IO ()-closeSSL s ssl = do-    SSL.shutdown ssl SSL.Unidirectional-    close s------- | Having composed a 'Request' object with the headers and metadata for--- this connection, you can now send the request to the server, along--- with the entity body, if there is one. For the rather common case of--- HTTP requests like 'GET' that don't send data, use 'emptyBody' as the--- output stream:------ >     sendRequest c q emptyBody------ For 'PUT' and 'POST' requests, you can use 'fileBody' or--- 'inputStreamBody' to send content to the server, or you can work with--- the @io-streams@ API directly:------ >     sendRequest c q (\o ->--- >         Streams.write (Just (Builder.fromString "Hello World\n")) o)----{--    I would like to enforce the constraints on the Empty and Static-    cases shown here, but those functions take OutputStream ByteString,-    and we are of course working in OutputStream Builder by that point.--}-sendRequest :: Connection -> Request -> (OutputStream Builder -> IO α) -> IO α-sendRequest c q handler = do-    -- write the headers--    Streams.write (Just msg) o2--    -- deal with the expect-continue mess--    e2 <- case t of-        Normal -> do-            return e--        Continue -> do-            Streams.write (Just Builder.flush) o2--            p  <- readResponseHeader i--            case getStatusCode p of-                100 -> do-                        -- ok to send-                        return e-                _   -> do-                        -- put the response back-                        Streams.unRead (rsp p) i-                        return Empty--    -- write the body, if there is one--    x <- case e2 of-        Empty -> do-            o3 <- Streams.nullOutput-            y <- handler o3-            return y--        Chunking    -> do-            o3 <- Streams.contramap Builder.chunkedTransferEncoding o2-            y  <- handler o3-            Streams.write (Just Builder.chunkedTransferTerminator) o2-            return y--        (Static _) -> do---          o3 <- Streams.giveBytes (fromIntegral n :: Int64) o2-            y  <- handler o2-            return y---    -- push the stream out by flushing the output buffers--    Streams.write (Just Builder.flush) o2--    return x--  where-    o2 = cOut c-    e = qBody q-    t = qExpect q-    msg = composeRequestBytes q h'-    h' = cHost c-    i = cIn c-    rsp p = Builder.toByteString $ composeResponseBytes p-------- | Get the virtual hostname that will be used as the @Host:@ header in--- the HTTP 1.1 request. Per RFC 2616 § 14.23, this will be of the form--- @hostname:port@ if the port number is other than the default, ie 80--- for HTTP.----getHostname :: Connection -> Request -> ByteString-getHostname c q =-    case qHost q of-        Just h' -> h'-        Nothing -> cHost c-------- | Handle the response coming back from the server. This function--- hands control to a handler function you supply, passing you the--- 'Response' object with the response headers and an 'InputStream'--- containing the entity body.------ For example, if you just wanted to print the first chunk of the--- content from the server:------ >     receiveResponse c (\p i -> do--- >         m <- Streams.read i--- >         case m of--- >             Just bytes -> putStr bytes--- >             Nothing    -> return ())------ Obviously, you can do more sophisticated things with the--- 'InputStream', which is the whole point of having an @io-streams@--- based HTTP client library.------ The final value from the handler function is the return value of--- @receiveResponse@, if you need it.----{--    The reponse body coming from the server MUST be fully read, even-    if (especially if) the users's handler doesn't consume it all.-    This is necessary to maintain the HTTP protocol invariants;-    otherwise pipelining would not work. It's not entirely clear-    *which* InputStream is being drained here; the underlying-    InputStream ByteString in Connection remains unconsumed beyond the-    threshold of the current response, which is exactly what we need.--}-receiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β-receiveResponse c handler = do-    p  <- readResponseHeader i-    i' <- readResponseBody p i--    x  <- handler p i'--    Streams.skipToEof i'--    return x-  where-    i = cIn c------- | This is a specialized variant of 'receiveResponse' that /explicitly/ does--- not handle the content encoding of the response body stream (it will not--- decompress anything). Unless you really want the raw gzipped content coming--- down from the server, use @receiveResponse@.----{--    See notes at receiveResponse.--}-receiveResponseRaw :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β-receiveResponseRaw c handler = do-    p  <- readResponseHeader i-    let p' = p {-        pContentEncoding = Identity-    }--    i' <- readResponseBody p' i--    x  <- handler p i'--    Streams.skipToEof i'--    return x-  where-    i = cIn c-------- | Use this for the common case of the HTTP methods that only send--- headers and which have no entity body, i.e. 'GET' requests.----emptyBody :: OutputStream Builder -> IO ()-emptyBody _ = return ()-------- | Specify a local file to be sent to the server as the body of the--- request.------ You use this partially applied:------ >     sendRequest c q (fileBody "/etc/passwd")------ Note that the type of @(fileBody \"\/path\/to\/file\")@ is just what--- you need for the third argument to 'sendRequest', namely------ >>> :t filePath "hello.txt"--- :: OutputStream Builder -> IO ()----{--    Relies on Streams.withFileAsInput generating (very) large chunks [which it-    does]. A more efficient way to do this would be interesting.--}-fileBody :: FilePath -> OutputStream Builder -> IO ()-fileBody p o = do-    Streams.withFileAsInput p (\i -> inputStreamBody i o)-------- | Read from a pre-existing 'InputStream' and pipe that through to the--- connection to the server. This is useful in the general case where--- something else has handed you stream to read from and you want to use--- it as the entity body for the request.------ You use this partially applied:------ >     i <- getStreamFromVault                    -- magic, clearly--- >     sendRequest c q (inputStreamBody i)------ This function maps "Builder.fromByteString" over the input, which will--- be efficient if the ByteString chunks are large.----{--    Note that this has to be 'supply' and not 'connect' as we do not-    want the end of stream to prematurely terminate the chunked encoding-    pipeline!--}-inputStreamBody :: InputStream ByteString -> OutputStream Builder -> IO ()-inputStreamBody i1 o = do-    i2 <- Streams.map Builder.fromByteString i1-    Streams.supply i2 o-------- | Print the response headers and response body to @stdout@. You can--- use this with 'receiveResponse' or one of the convenience functions--- when testing. For example, doing:------ >     c <- openConnection "kernel.operationaldynamics.com" 58080--- >--- >     q <- buildRequest $ do--- >         http GET "/time"--- >--- >     sendRequest c q emptyBody--- >--- >     receiveResponse c debugHandler------ would print out:------ > HTTP/1.1 200 OK--- > Transfer-Encoding: chunked--- > Content-Type: text/plain--- > Vary: Accept-Encoding--- > Server: Snap/0.9.2.4--- > Content-Encoding: gzip--- > Date: Mon, 21 Jan 2013 06:13:37 GMT--- >--- > Mon 21 Jan 13, 06:13:37.303Z------ or thereabouts.----debugHandler :: Response -> InputStream ByteString -> IO ()-debugHandler p i = do-    S.putStr $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p-    Streams.connect i stdout-------- | Sometimes you just want the entire response body as a single blob.--- This function concatonates all the bytes from the response into a--- ByteString. If using the main @http-streams@ API, you would use it--- as follows:------ >    ...--- >    x' <- receiveResponse c concatHandler--- >    ...------ The methods in the convenience API all take a function to handle the--- response; this function is passed directly to the 'receiveResponse'--- call underlying the request. Thus this utility function can be used--- for 'get' as well:------ >    x' <- get "http://www.example.com/document.txt" concatHandler------ Either way, the usual caveats about allocating a--- single object from streaming I/O apply: do not use this if you are--- not absolutely certain that the response body will fit in a--- reasonable amount of memory.------ Note that this function makes no discrimination based on the--- response's HTTP status code. You're almost certainly better off--- writing your own handler function.----{--    I'd welcome a better name for this function.--}-concatHandler :: Response -> InputStream ByteString -> IO ByteString-concatHandler _ i1 = do-    i2 <- Streams.map Builder.fromByteString i1-    x <- Streams.fold mappend mempty i2-    return $ Builder.toByteString x-------- | Shutdown the connection. You need to call this release the--- underlying socket file descriptor and related network resources. To--- do so reliably, use this in conjunction with 'openConnection' in a--- call to 'Control.Exception.bracket':------ > ----- > -- Make connection, cleaning up afterward--- > ----- >--- > foo :: IO ByteString--- > foo = bracket--- >    (openConnection "localhost" 80)--- >    (closeConnection)--- >    (doStuff)--- >--- > ----- > -- Actually use Connection to send Request and receive Response--- > ----- >--- > doStuff :: Connection -> IO ByteString------ or, just use 'withConnection'.------ While returning a ByteString is probably the most common use case,--- you could conceivably do more processing of the response in 'doStuff'--- and have it and 'foo' return a different type.----closeConnection :: Connection -> IO ()-closeConnection c = cClose c
− src/Network/Http/Inconvenience.hs 
@@ -1,573 +0,0 @@------ HTTP client for use with io-streams------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is--- made available to you by its authors as open source software:--- you can redistribute it and/or modify it under the terms of--- the BSD licence.-----{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MagicHash          #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# OPTIONS -fno-warn-orphans  #-}--module Network.Http.Inconvenience (-    URL,-    modifyContextSSL,-    establishConnection,-    get,-    post,-    postForm,-    encodedFormBody,-    put,-    baselineContextSSL,-    concatHandler',-    jsonHandler,--    -- for testing-    TooManyRedirects(..),-    HttpClientError(..)-) where--import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (fromByteString,-                                                      fromWord8, toByteString)-import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString)-import Control.Exception (Exception, bracket, throw)-import Data.Aeson (FromJSON, Result (..), fromJSON, json')-import Data.Bits (Bits (..))-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.ByteString.Internal (c2w, w2c)-import Data.Char (intToDigit, isAlphaNum)-import Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.List (intersperse)-import Data.Monoid (Monoid (..), mappend)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Typeable (Typeable)-import Data.Word (Word16)-import GHC.Exts-import GHC.Word (Word8 (..))-import Network.URI (URI (..), URIAuth (..), parseURI)-import OpenSSL.Session (SSLContext)-import qualified OpenSSL.Session as SSL-import System.IO.Streams (InputStream, OutputStream)-import qualified System.IO.Streams as Streams-import qualified System.IO.Streams.Attoparsec as Streams-import System.IO.Unsafe (unsafePerformIO)--import Network.Http.Connection-import Network.Http.RequestBuilder-import Network.Http.Types--#include "config.h"--type URL = ByteString--------------------------------------------------------------------------------------- | URL-escapes a string (see--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)----urlEncode :: ByteString -> URL-urlEncode = Builder.toByteString . urlEncodeBuilder-{-# INLINE urlEncode #-}-------- | URL-escapes a string (see--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.----urlEncodeBuilder :: ByteString -> Builder-urlEncodeBuilder = go mempty-  where-    go !b !s = maybe b' esc (S.uncons y)-      where-        (x,y)     = S.span (flip HashSet.member urlEncodeTable) s-        b'        = b `mappend` Builder.fromByteString x-        esc (c,r) = let b'' = if c == ' '-                                then b' `mappend` Builder.fromWord8 (c2w '+')-                                else b' `mappend` hexd c-                    in go b'' r---hexd :: Char -> Builder-hexd c0 = Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi-                                      `mappend` Builder.fromWord8 low-  where-    !c        = c2w c0-    toDigit   = c2w . intToDigit-    !low      = toDigit $ fromEnum $ c .&. 0xf-    !hi       = toDigit $ (c .&. 0xf0) `shiftr` 4--    shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#))---urlEncodeTable :: HashSet Char-urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0..255]-  where-    f c = isAlphaNum c || elem c "$-.!*'(),"-----------------------------------------------------------------------------------{--    The default SSLContext used by the convenience APIs in the http-streams-    library. This is a kludge, unsafe bad yada yada. The technique, however,-    was described on a Haskell Wiki page, so that makes it an officially-    supported kludge. The justification for doing this is a) the functions-    accessing this IORef are themselves all in the IO monad, and b) these-    contortions are necessary to allow the library to be used for http:// URLs-    *without* requiring the developer to do 'withOpenSSL'.--}-global :: IORef SSLContext-global = unsafePerformIO $ do-    ctx <- baselineContextSSL-    newIORef ctx-{-# NOINLINE global #-}------- | Modify the context being used to configure the SSL tunnel used by--- the convenience API functions to make @https://@ connections. The--- default is that setup by 'baselineContextSSL'.----modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO ()-modifyContextSSL f = do-    ctx <- readIORef global-    ctx' <- f ctx-    writeIORef global ctx'------- | Given a URL, work out whether it is normal or secure, and then--- open the connection to the webserver including setting the--- appropriate default port if one was not specified in the URL. This--- is what powers the convenience API, but you may find it useful in--- composing your own similar functions.------ For example (on the assumption that your server behaves when given--- an absolute URI as the request path), this will open a connection--- to server @www.example.com@ port @443@ and request @/photo.jpg@:------ >     let url = "https://www.example.com/photo.jpg"--- >--- >     c <- establishConnection url--- >     q <- buildRequest $ do--- >         http GET url--- >     ...----establishConnection :: URL -> IO (Connection)-establishConnection r' = do-    establish u-  where-    u = parseURL r'-{-# INLINE establishConnection #-}--establish :: URI -> IO (Connection)-establish u =-    case scheme of-        "http:"  -> do-                        openConnection host port-        "https:" -> do-                        ctx <- readIORef global-                        openConnectionSSL ctx host ports-        _        -> error ("Unknown URI scheme " ++ scheme)-  where-    scheme = uriScheme u--    auth = case uriAuthority u of-        Just x  -> x-        Nothing -> URIAuth "" "localhost" ""--    host = S.pack (uriRegName auth)-    port = case uriPort auth of-        ""  -> 80-        _   -> read $ tail $ uriPort auth :: Word16-    ports = case uriPort auth of-        ""  -> 443-        _   -> read $ tail $ uriPort auth :: Word16-------- | Creates a basic SSL context. This is the SSL context used if you make an--- @\"https:\/\/\"@ request using one of the convenience functions. It--- configures OpenSSL to use the default set of ciphers.------ On Linux systems, this function also configures OpenSSL to verify--- certificates using the system certificates stored in @\/etc\/ssl\/certs@.------ On other systems, /no certificate validation is performed/ by the--- generated 'SSLContext' because there is no canonical place to find--- the set of system certificates. When using this library on a--- non-Linux system, you are encouraged to install the system--- certificates somewhere and create your own 'SSLContext'.----{--    We would like to turn certificate verification on for everyone, but-    this has proved contingent on leveraging platform specific mechanisms-    to reach the certificate store. That logic should probably be in-    hsopenssl, but feel free to change this as appropriate for your OS.--}-baselineContextSSL :: IO SSLContext-baselineContextSSL = do-    ctx <- SSL.context-    SSL.contextSetDefaultCiphers ctx-#if defined __MACOSX__-    SSL.contextSetVerificationMode ctx SSL.VerifyNone-#elif defined __WINDOWS__-    SSL.contextSetVerificationMode ctx SSL.VerifyNone-#else-    SSL.contextSetCADirectory ctx "/etc/ssl/certs"-    SSL.contextSetVerificationMode ctx $-        SSL.VerifyPeer True True Nothing-#endif-    return ctx---parseURL :: URL -> URI-parseURL r' =-    case parseURI r of-        Just u  -> u-        Nothing -> error ("Can't parse URI " ++ r)-  where-    r = T.unpack $ T.decodeUtf8 r'----------------------------------------------------------------------------------{--    Account for bug where "http://www.example.com" is parsed with no-    path element, resulting in an illegal HTTP request line.--}--path :: URI -> ByteString-path u = case url of-            ""  -> "/"-            _   -> url-  where-    url = T.encodeUtf8 $! T.pack-                      $! concat [uriPath u, uriQuery u, uriFragment u]---------------------------------------------------------------------------------------- | Issue an HTTP GET request and pass the resultant response to the--- supplied handler function. This code will silently follow redirects,--- to a maximum depth of 5 hops.------ The handler function is as for 'receiveResponse', so you can use one--- of the supplied convenience handlers if you're in a hurry:------ >     x' <- get "http://www.bbc.co.uk/news/" concatHandler------ But as ever the disadvantage of doing this is that you're not doing--- anything intelligent with the HTTP response status code. If you want--- an exception raised in the event of a non @2xx@ response, you can use:------ >     x' <- get "http://www.bbc.co.uk/news/" concatHandler'------ but for anything more refined you'll find it easy to simply write--- your own handler function.----get :: URL-    -- ^ Resource to GET from.-    -> (Response -> InputStream ByteString -> IO β)-    -- ^ Handler function to receive the response from the server.-    -> IO β-get r' handler = getN 0 r' handler--getN n r' handler = do-    bracket-        (establish u)-        (teardown)-        (process)--  where-    teardown = closeConnection--    u = parseURL r'--    process c = do-        q <- buildRequest $ do-            http GET (path u)-            setAccept "*/*"--        sendRequest c q emptyBody--        receiveResponse c (wrapRedirect n handler)---{--    This is fairly simple-minded. Improvements could include reusing-    the Connection if the redirect is to the same host, and closing-    the original Connection if it is not. These are both things that-    can be done manually if using the full API, so not worried about-    it for now.--}--wrapRedirect-    :: Int-    -> (Response -> InputStream ByteString -> IO β)-    -> Response-    -> InputStream ByteString-    -> IO β-wrapRedirect n handler p i = do-    if (s == 301 || s == 302 || s == 303 || s == 307)-        then case lm of-                Just l  -> getN n' l handler-                Nothing -> handler p i-        else handler p i-  where-    s  = getStatusCode p-    lm = getHeader p "Location"-    !n' = if n < 5-            then n + 1-            else throw $! TooManyRedirects n--data TooManyRedirects = TooManyRedirects Int-        deriving (Typeable, Show, Eq)--instance Exception TooManyRedirects-------- | Send content to a server via an HTTP POST request. Use this--- function if you have an 'OutputStream' with the body content.----post :: URL-    -- ^ Resource to POST to.-    -> ContentType-    -- ^ MIME type of the request body being sent.-    -> (OutputStream Builder -> IO α)-    -- ^ Handler function to write content to server.-    -> (Response -> InputStream ByteString -> IO β)-    -- ^ Handler function to receive the response from the server.-    -> IO β-post r' t body handler = do-    bracket-        (establish u)-        (teardown)-        (process)-  where-    teardown = closeConnection--    u = parseURL r'--    process c = do-        q <- buildRequest $ do-            http POST (path u)-            setAccept "*/*"-            setContentType t--        _ <- sendRequest c q body--        x <- receiveResponse c handler-        return x-------- | Send form data to a server via an HTTP POST request. This is the--- usual use case; most services expect the body to be MIME type--- @application/x-www-form-urlencoded@ as this is what conventional--- web browsers send on form submission. If you want to POST to a URL--- with an arbitrary Content-Type, use 'post'.----postForm-    :: URL-    -- ^ Resource to POST to.-    -> [(ByteString, ByteString)]-    -- ^ List of name=value pairs. Will be sent URL-encoded.-    -> (Response -> InputStream ByteString -> IO β)-    -- ^ Handler function to receive the response from the server.-    -> IO β-postForm r' nvs handler = do-    bracket-        (establish u)-        (teardown)-        (process)-  where-    teardown = closeConnection--    u = parseURL r'--    process c = do-        q <- buildRequest $ do-            http POST (path u)-            setAccept "*/*"-            setContentType "application/x-www-form-urlencoded"--        _ <- sendRequest c q (encodedFormBody nvs)--        x <- receiveResponse c handler-        return x-------- | Specify name/value pairs to be sent to the server in the manner--- used by web browsers when submitting a form via a POST request.--- Parameters will be URL encoded per RFC 2396 and combined into a--- single string which will be sent as the body of your request.------ You use this partially applied:------ >     let nvs = [("name","Kermit"),--- >                ("type","frog")]--- >                ("role","stagehand")]--- >--- >     sendRequest c q (encodedFormBody nvs)------ Note that it's going to be up to you to call 'setContentType' with--- a value of @\"application/x-www-form-urlencoded\"@ when building the--- Request object; the 'postForm' convenience (which uses this--- @encodedFormBody@ function) takes care of this for you, obviously.----encodedFormBody :: [(ByteString,ByteString)] -> OutputStream Builder -> IO ()-encodedFormBody nvs o = do-    Streams.write (Just b) o-  where-    b = mconcat $ intersperse (Builder.fromString "&") $ map combine nvs--    combine :: (ByteString,ByteString) -> Builder-    combine (n',v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", urlEncodeBuilder v']-------- | Place content on the server at the given URL via an HTTP PUT--- request, specifying the content type and a function to write the--- content to the supplied 'OutputStream'. You might see:------ >     put "http://s3.example.com/bucket42/object149" "text/plain"--- >         (fileBody "hello.txt") (\p i -> do--- >             putStr $ show p--- >             Streams.connect i stdout)----put :: URL-    -- ^ Resource to PUT to.-    -> ContentType-    -- ^ MIME type of the request body being sent.-    -> (OutputStream Builder -> IO α)-    -- ^ Handler function to write content to server.-    -> (Response -> InputStream ByteString -> IO β)-    -- ^ Handler function to receive the response from the server.-    -> IO β-put r' t body handler = do-    bracket-        (establish u)-        (teardown)-        (process)-  where-    teardown = closeConnection--    u = parseURL r'--    process c = do-        q <- buildRequest $ do-            http PUT (path u)-            setAccept "*/*"-            setHeader "Content-Type" t--        _ <- sendRequest c q body--        x <- receiveResponse c handler-        return x-------- | A special case of 'concatHandler', this function will return the--- entire response body as a single ByteString, but will throw an--- exception if the response status code was other than @2xx@.----concatHandler' :: Response -> InputStream ByteString -> IO ByteString-concatHandler' p i =-    if s >= 300-        then throw (HttpClientError s m)-        else concatHandler p i-  where-    s = getStatusCode p-    m = getStatusMessage p--data HttpClientError = HttpClientError Int ByteString-        deriving (Typeable)--instance Exception HttpClientError--instance Show HttpClientError where-    show (HttpClientError s msg) = Prelude.show s ++ " " ++ S.unpack msg--{--    There should probably also be HttpServerError and maybe even-    HttpRedirectError, but as these names don't seem to show up-    in the runtime when raised, not sure it's worth the bother. It's-    not like we'd want anything different in their Show instances.--}------- | If you're working with a data stream that is in @application/json@,--- then chances are you're using @aeson@ to handle the JSON to Haskell--- decoding. If so, then this helper function might be of use.------ >     v <- get "http://api.example.com/v1/" jsonHandler------ This function feeds the input body to the 'Data.Aeson.Parser.json''--- @attoparsec@ Parser in order to get the aeson Value type. This is then--- marshalled to your type represeting the source data, via the FromJSON--- typeclass.------ The above example was actually insufficient; when working with--- @aeson@ you need to fix the type so it knows what FromJSON instance--- to use. Let's say you're getting Person objects, then it would be------ >     v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person------ assuming your Person type had a FromJSON instance, of course.------ /Note/------ This function parses a single top level JSON object or array, which--- is all you're supposed to get if it's a valid document. People do--- all kinds of crazy things though, so beware. Also, this function (like the--- "concatHander" convenience) loads the entire response into memory; it's--- not /streaming/; if you're receiving a document which is (say) a very--- long array of objects then you may want to implement your own--- handler function, perhaps using "Streams.parserToInputStream" and--- the 'Data.Aeson.Parser' combinators directly — with a result type of--- InputStream Value, perhaps — by which you could then iterate over--- the Values one at a time in constant space.----{--    This looks simple. It wasn't. The types involved are rediculous to-    disentangle. The biggest problem is that the Parser type used in-    [aeson] is *NOT* the Parser type from [attoparsec]. But the parsing-    function `json` and `json` from Aeson use the attoparsec Parser even-    though the rest of the top level page is all about Aeson's parser as-    used in FromJSON!--    Anyway, `json` and `json'` are [attoparsec] Parser [aeson] Value; we-    run that using the [io-streams] convenience function-    `parseFromStream` which gets us a Value which is the intermediate-    abstract syntax tree for a  JSON document. Then (and this was hard-    to find) to work with that in terms of the FromJSON typeclass, you-    use the `fromJSON` function which has type (FromJSON α => Value ->-    Result α). Then finally, pull the result out of it. Why in Bog's-    name this wasn't just Either I'll never know.--}-jsonHandler-    :: (FromJSON α)-    => Response-    -> InputStream ByteString-    -> IO α-jsonHandler _ i = do-    v <- Streams.parseFromStream json' i        -- Value-    let r = fromJSON v                          -- Result-    case r of-        (Success a) ->  return a-        (Error str) ->  error str-
− src/Network/Http/RequestBuilder.hs 
@@ -1,300 +0,0 @@------ HTTP client for use with io-streams------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is--- made available to you by its authors as open source software:--- you can redistribute it and/or modify it under the terms of--- the BSD licence.-----{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}--module Network.Http.RequestBuilder (-    RequestBuilder,-    buildRequest,-    http,-    setHostname,-    setAccept,-    setAccept',-    setAuthorizationBasic,-    ContentType,-    setContentType,-    setContentLength,-    setExpectContinue,-    setHeader-) where--import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (fromByteString,-                                                      toByteString)-import qualified Blaze.ByteString.Builder.Char8 as Builder (fromShow,-                                                            fromString)-import Control.Monad.State-import Data.ByteString (ByteString)-import qualified Data.ByteString.Base64 as BS64-import Data.ByteString.Char8 ()-import qualified Data.ByteString.Char8 as S-import Data.Int (Int64)-import Data.List (intersperse)-import Data.Monoid (mconcat)--import Network.Http.Connection-import Network.Http.Types--#include "config.h"------- | The RequestBuilder monad allows you to abuse do-notation to--- conveniently setup a 'Request' object.----newtype RequestBuilder α = RequestBuilder (State Request α)-  deriving (Monad, MonadState Request)------- | Run a RequestBuilder, yielding a Request object you can use on the--- given connection.------ >     q <- buildRequest $ do--- >         http POST "/api/v1/messages"--- >         setContentType "application/json"--- >         setHostname "clue.example.com" 80--- >         setAccept "text/html"--- >         setHeader "X-WhoDoneIt" "The Butler"------ Obviously it's up to you to later actually /send/ JSON data.------ /Note/------ The API of this function changed from version 0.3.1 to verison 0.4.0;--- the original requirement to pass a Connection object has been removed,--- thereby allowing you to build your Request before opening the--- connection to the web server.----buildRequest :: RequestBuilder α -> IO Request-buildRequest mm = do-    let (RequestBuilder s) = (mm)-    let q = Request {-        qHost = Nothing,-        qMethod = GET,-        qPath = "/",-        qBody = Empty,-        qExpect = Normal,-        qHeaders = emptyHeaders-    }-    return $ execState s q-------- | Begin constructing a Request, starting with the request line.----http :: Method -> ByteString -> RequestBuilder ()-http m p' = do-    q <- get-    let h0 = qHeaders q-    let h1 = updateHeader h0 "User-Agent" VERSION-    let h2 = updateHeader h1 "Accept-Encoding" "gzip"--    let e  = case m of-            GET   -> Empty-            TRACE -> Empty-            _     -> Chunking--    let h3 = case e of-            Chunking    -> updateHeader h2 "Transfer-Encoding" "chunked"-            _           -> h2--    put q {-        qMethod = m,-        qPath = p',-        qBody = e,-        qHeaders = h3-    }------- | Set the [virtual] hostname for the request. In ordinary conditions--- you won't need to call this, as the @Host:@ header is a required--- header in HTTP 1.1 and is set directly from the name of the server--- you connected to when calling 'Network.Http.Connection.openConnection'.----setHostname :: Hostname -> Port -> RequestBuilder ()-setHostname h' p = do-    q <- get-    put q {-        qHost = Just v'-    }-  where-    v' :: ByteString-    v' = if p == 80-        then h'-        else Builder.toByteString $ mconcat-           [Builder.fromByteString h',-            Builder.fromString ":",-            Builder.fromShow p]------- | Set a generic header to be sent in the HTTP request. The other--- methods in the RequestBuilder API are expressed in terms of this--- function, but we recommend you use them where offered for their--- stronger types.----setHeader :: ByteString -> ByteString -> RequestBuilder ()-setHeader k' v' = do-    q <- get-    let h0 = qHeaders q-    let h1 = updateHeader h0 k' v'-    put q {-        qHeaders = h1-    }--deleteHeader :: ByteString -> RequestBuilder ()-deleteHeader k' = do-    q <- get-    let h0 = qHeaders q-    let h1 = removeHeader h0 k'-    put q {-        qHeaders = h1-    }--{-# INLINE setEntityBody #-}-setEntityBody :: EntityBody -> RequestBuilder ()-setEntityBody e = do-    q <- get-    put q {-        qBody = e-    }--{-# INLINE setExpectMode #-}-setExpectMode :: ExpectMode -> RequestBuilder ()-setExpectMode e = do-    q <- get-    put q {-        qExpect = e-    }------- | Indicate the content type you are willing to receive in a reply--- from the server. For more complex @Accept:@ headers, use--- 'setAccept''.----setAccept :: ByteString -> RequestBuilder ()-setAccept v' = do-    setHeader "Accept" v'------- | Indicate the content types you are willing to receive in a reply--- from the server in order of preference. A call of the form:------ >         setAccept' [("text/html", 1.0),--- >                     ("application/xml", 0.8),--- >                     ("*/*", 0)]------ will result in an @Accept:@ header value of--- @text\/html; q=1.0, application\/xml; q=0.8, \*\/\*; q=0.0@ as you--- would expect.----setAccept' :: [(ByteString,Float)] -> RequestBuilder ()-setAccept' tqs = do-    setHeader "Accept" v'-  where-    v' = Builder.toByteString v-    v  = mconcat $ intersperse (Builder.fromString ", ") $ map format tqs--    format :: (ByteString,Float) -> Builder-    format (t',q) =-        mconcat-           [Builder.fromByteString t',-            Builder.fromString "; q=",-            Builder.fromShow q]-------- | Set username and password credentials per the HTTP basic--- authentication method.------ >         setAuthorizationBasic "Aladdin" "open sesame"------ will result in an @Authorization:@ header value of--- @Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==@.------ Basic authentication does /not/ use a message digest function to--- encipher the password; the above string is only base-64 encoded and--- is thus plain-text visible to any observer on the wire and all--- caches and servers at the other end, making basic authentication--- completely insecure. A number of web services, however, use SSL to--- encrypt the connection that then use HTTP basic authentication to--- validate requests. Keep in mind in these cases the secret is still--- sent to the servers on the other side and passes in clear through--- all layers after the SSL termination. Do /not/ use basic--- authentication to protect secure or user-originated privacy-sensitve--- information.----{--    This would be better using Builder, right?--}-setAuthorizationBasic :: ByteString -> ByteString -> RequestBuilder ()-setAuthorizationBasic user' passwd' = do-    setHeader "Authorization" v'-  where-    v'   = S.concat ["Basic ", msg']-    msg' = BS64.encode str'-    str' = S.concat [user', ":", passwd']---type ContentType = ByteString-------- | Set the MIME type corresponding to the body of the request you are--- sending. Defaults to @\"text\/plain\"@, so usually you need to set--- this if 'PUT'ting.----setContentType :: ContentType -> RequestBuilder ()-setContentType v' = do-    setHeader "Content-Type" v'------- | Specify the length of the request body, in bytes.------ RFC 2616 requires that we either send a @Content-Length@ header or--- use @Transfer-Encoding: chunked@. If you know the exact size ahead--- of time, then call this function; the body content will still be--- streamed out by @io-streams@ in more-or-less constant space.------ This function is special: in a PUT or POST request, @http-streams@--- will assume chunked transfer-encoding /unless/ you specify a content--- length here, in which case you need to ensure your body function--- writes precisely that many bytes.-------setContentLength :: Int64 -> RequestBuilder ()-setContentLength n = do-    deleteHeader "Transfer-Encoding"-    setHeader "Content-Length" (S.pack $ show n)-    setEntityBody $ Static n------- | Specify that this request should set the expectation that the--- server needs to approve the request before you send it.------ This function is special: in a PUT or POST request, @http-streams@--- will wait for the server to reply with an HTTP/1.1 100 Continue--- status before sending the entity body. This is handled internally;--- you will get the real response (be it successful 2xx, client error,--- 4xx, or server error 5xx) in 'receiveResponse'. In theory, it--- should be 417 if the expectation failed.------ Only bother with this if you know the service you're talking to--- requires clients to send an @Expect: 100-continue@ header and will--- handle it properly. Most servers don't do any precondition checking,--- automatically send an intermediate 100 response, and then just read--- the body regardless, making this a bit of a no-op in most cases.----setExpectContinue :: RequestBuilder ()-setExpectContinue = do-    setHeader "Expect" "100-continue"-    setExpectMode Continue-
− src/Network/Http/ResponseParser.hs 
@@ -1,275 +0,0 @@------ HTTP client for use with io-streams------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is--- made available to you by its authors as open source software:--- you can redistribute it and/or modify it under the terms of--- the BSD licence.------ Significant portions of this file were written while studying--- the HTTP request parser implementation in the Snap Framework;--- snap-core's src/Snap/Internal/Parsing.hs and snap-server's--- src/Snap/Internal/Http/Parser.hs, and various utility functions--- have been cloned from there.-----{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}--module Network.Http.ResponseParser (-    readResponseHeader,-    readResponseBody,--        -- for testing-    readDecimal-) where--import Prelude hiding (take, takeWhile)--import Control.Applicative-import Control.Exception (Exception, throwIO)-import Control.Monad (void)-import Control.Monad.IO.Class (liftIO)-import Data.Attoparsec.ByteString.Char8-import Data.Bits (Bits (..))-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.CaseInsensitive (mk)-import Data.Char (ord)-import Data.Int (Int64)-import Data.Typeable (Typeable)-import System.IO.Streams (Generator, InputStream)-import qualified System.IO.Streams as Streams-import qualified System.IO.Streams.Attoparsec as Streams--import Network.Http.Types-import Network.Http.Utilities--{--    The chunk size coming down from the server is somewhat arbitrary;-    it's really just an indication of how many bytes need to be read-    before the next size marker or end marker - neither of which has-    anything to do with streaming on our side. Instead, we'll feed-    bytes into our InputStream at an appropriate intermediate size.--}-__BITE_SIZE__ :: Int-__BITE_SIZE__ = 32 * 1024---{--    Process the reply from the server up to the end of the headers as-    deliniated by a blank line.--}-readResponseHeader :: InputStream ByteString -> IO Response-readResponseHeader i = do-    (sc,sm) <- Streams.parseFromStream parseStatusLine i--    hs <- readHeaderFields i--    let h  = buildHeaders hs-    let te = case lookupHeader h "Transfer-Encoding" of-            Just x' -> if mk x' == "chunked"-                        then Chunked-                        else None-            Nothing -> None--    let ce = case lookupHeader h "Content-Encoding" of-            Just x' -> if mk x' == "gzip"-                        then Gzip-                        else Identity-            Nothing -> Identity--    let nm = case lookupHeader h "Content-Length" of-            Just x' -> Just (readDecimal x' :: Int64)-            Nothing -> case sc of-                        204 -> Just 0-                        304 -> Just 0-                        100 -> Just 0-                        _   -> Nothing--    return Response {-        pStatusCode = sc,-        pStatusMsg = sm,-        pTransferEncoding = te,-        pContentEncoding = ce,-        pContentLength = nm,-        pHeaders = h-    }---parseStatusLine :: Parser (Int,ByteString)-parseStatusLine = do-    sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' '-    sm <- takeTill (== '\r') <* crlf-    return (sc,sm)-  where-    version c = c == '1' || c == '0'---crlf :: Parser ByteString-crlf = string "\r\n"--------------------------------------------------------------------------{--    Switch on the encoding and compression headers, wrapping the raw-    InputStream to present the entity body's actual bytes.--}-readResponseBody :: Response -> InputStream ByteString -> IO (InputStream ByteString)-readResponseBody p i1 = do--    i2 <- case t of-        None        -> case l of-                        Just n  -> readFixedLengthBody i1 n-                        Nothing -> readUnlimitedBody i1-        Chunked     -> readChunkedBody i1--    i3 <- case c of-        Identity    -> return i2-        Gzip        -> readCompressedBody i2-        Deflate     -> throwIO (UnexpectedCompression $ show c)--    return i3-  where-    t = pTransferEncoding p-    c = pContentEncoding p-    l = pContentLength p---readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α-readDecimal str' =-    S.foldl' f 0 x'-  where-    f !cnt !i = cnt * 10 + digitToInt i--    x' = head $ S.words str'--    {-# INLINE digitToInt #-}-    digitToInt :: (Enum α, Num α, Bits α) => Char -> α-    digitToInt c | c >= '0' && c <= '9' = toEnum $! ord c - ord '0'-                 | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit"-{-# INLINE readDecimal #-}--data UnexpectedCompression = UnexpectedCompression String-        deriving (Typeable, Show)--instance Exception UnexpectedCompression--------------------------------------------------------------------------{--    Process a response body in chunked transfer encoding, taking the-    resultant bytes and reproducing them as an InputStream--}-readChunkedBody :: InputStream ByteString -> IO (InputStream ByteString)-readChunkedBody i1 = do-    i2 <- Streams.fromGenerator (consumeChunks i1)-    return i2---{--    For a response body in chunked transfer encoding, iterate over-    the individual chunks, reading the size parameter, then-    looping over that chunk in bites of at most __BYTE_SIZE__,-    yielding them to the receiveResponse InputStream accordingly.--}-consumeChunks :: InputStream ByteString -> Generator ByteString ()-consumeChunks i1 = do-    !n <- parseSize--    if n > 0-        then do-            -- read one or more bites, then loop to next chunk-            go n-            skipCRLF-            consumeChunks i1-        else do-            -- skip "trailers" and consume final CRLF-            skipEnd--  where-    go 0 = return ()-    go !n = do-        (!x',!r) <- liftIO $ readN n i1-        Streams.yield x'-        go r--    parseSize = do-        n <- liftIO $ Streams.parseFromStream transferChunkSize i1-        return n--    skipEnd = do-        liftIO $ do-            _ <- readHeaderFields i1-            return ()--    skipCRLF = do-        liftIO $ do-            _ <- Streams.parseFromStream crlf i1-            return ()--{--    Read the specified number of bytes up to a maximum of __BITE_SIZE__,-    returning a resultant ByteString and the number of bytes remaining.--}--readN :: Int -> InputStream ByteString -> IO (ByteString, Int)-readN n i1 = do-    !x' <- Streams.readExactly p i1-    return (x', r)-  where-    !d = n - size--    !p = if d > 0-        then size-        else n--    !r = if d > 0-        then d-        else 0--    size = __BITE_SIZE__---transferChunkSize :: Parser (Int)-transferChunkSize = do-    !n <- hexadecimal-    void (takeTill (== '\r'))-    void crlf-    return n--------------------------------------------------------------------------{--    This has the rather crucial side effect of terminating the stream-    after the requested number of bytes. Otherwise, code handling-    responses waits on more input until an HTTP timeout occurs.--}-readFixedLengthBody :: InputStream ByteString -> Int64 -> IO (InputStream ByteString)-readFixedLengthBody i1 n = do-    i2 <- Streams.takeBytes n i1-    return i2--{--    On the other hand, there is the (predominently HTTP/1.0) case-    where there is no content length sent and no chunking, with the-    result that only the connection closing marks the end of the-    response body.--}-readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString)-readUnlimitedBody i1 = do-    return i1--------------------------------------------------------------------------readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString)-readCompressedBody i1 = do-    i2 <- Streams.gunzip i1-    return i2
− src/Network/Http/Types.hs 
@@ -1,387 +0,0 @@------ HTTP client for use with io-streams------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is--- made available to you by its authors as open source software:--- you can redistribute it and/or modify it under the terms of--- the BSD licence.-----{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}--module Network.Http.Types (-    Request(..),-    EntityBody(..),-    ExpectMode(..),-    Response(..),-    StatusCode,-    TransferEncoding(..),-    ContentEncoding(..),-    getStatusCode,-    getStatusMessage,-    getHeader,-    Method(..),-    Headers,-    emptyHeaders,-    updateHeader,-    removeHeader,-    buildHeaders,-    lookupHeader,-    HttpParseException(..),--    -- for testing-    composeRequestBytes,-    composeResponseBytes-) where--import Prelude hiding (lookup)--import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (copyByteString,-                                                      copyByteString,-                                                      fromByteString,-                                                      fromByteString,-                                                      toByteString)-import qualified Blaze.ByteString.Builder.Char8 as Builder (fromChar,-                                                            fromShow,-                                                            fromString)-import Control.Exception (Exception)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.CaseInsensitive (CI, mk, original)-import Data.HashMap.Strict (HashMap, delete, empty, foldrWithKey, insert,-                            insertWith, lookup)-import Data.Int (Int64)-import Data.List (foldl')-import Data.Monoid (mconcat, mempty)-import Data.Typeable (Typeable)---- | HTTP Methods, as per RFC 2616-data Method-    = GET-    | HEAD-    | POST-    | PUT-    | DELETE-    | TRACE-    | OPTIONS-    | CONNECT-    | PATCH-    | Method ByteString-        deriving (Show, Read, Ord)---instance Eq Method where-    GET          == GET              = True-    HEAD         == HEAD             = True-    POST         == POST             = True-    PUT          == PUT              = True-    DELETE       == DELETE           = True-    TRACE        == TRACE            = True-    OPTIONS      == OPTIONS          = True-    CONNECT      == CONNECT          = True-    PATCH        == PATCH            = True-    GET          == Method "GET"     = True-    HEAD         == Method "HEAD"    = True-    POST         == Method "POST"    = True-    PUT          == Method "PUT"     = True-    DELETE       == Method "DELETE"  = True-    TRACE        == Method "TRACE"   = True-    OPTIONS      == Method "OPTIONS" = True-    CONNECT      == Method "CONNECT" = True-    PATCH        == Method "PATCH"   = True-    Method a     == Method b         = a == b-    m@(Method _) == other            = other == m-    _            == _                = False------- | A description of the request that will be sent to the server. Note--- unlike other HTTP libraries, the request body is /not/ a part of this--- object; that will be streamed out by you when actually sending the--- request with 'sendRequest'.------ 'Request' has a useful @Show@ instance that will output the request--- line and headers (as it will be sent over the wire but with the @\\r@--- characters stripped) which can be handy for debugging.------ Note that the @Host:@ header is not set until--- 'Network.Http.Connection.sendRequest' is called, so you will not see--- it in the Show instance (unless you call 'setHostname' to override--- the value inherited from the @Connection@).----data Request-    = Request {-        qMethod  :: !Method,-        qHost    :: !(Maybe ByteString),-        qPath    :: !ByteString,-        qBody    :: !EntityBody,-        qExpect  :: !ExpectMode,-        qHeaders :: !Headers-    }--instance Show Request where-    show q = {-# SCC "Request.show" #-}-        S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeRequestBytes q "<default>"---data EntityBody = Empty | Chunking | Static Int64--data ExpectMode = Normal | Continue--{--    The bit that builds up the actual string to be transmitted. This-    is on the critical path for every request, so we'll want to revisit-    this to improve performance.--    - Rewrite rule for Method?-    - How can serializing the Headers be made efficient?--    This code includes the RFC compliant CR-LF sequences as line-    terminators, which is why the Show instance above has to bother-    with removing them.--}--composeRequestBytes :: Request -> ByteString -> Builder-composeRequestBytes q h' =-    mconcat-       [requestline,-        hostLine,-        headerFields,-        crlf]-  where-    requestline = mconcat-       [method,-        sp,-        uri,-        sp,-        version,-        crlf]--    method = case qMethod q of-        GET     -> Builder.fromString "GET"-        HEAD    -> Builder.fromString "HEAD"-        POST    -> Builder.fromString "POST"-        PUT     -> Builder.fromString "PUT"-        DELETE  -> Builder.fromString "DELETE"-        TRACE   -> Builder.fromString "TRACE"-        OPTIONS -> Builder.fromString "OPTIONS"-        CONNECT -> Builder.fromString "CONNECT"-        PATCH   -> Builder.fromString "PATCH"-        (Method x) -> Builder.fromByteString x--    uri = Builder.copyByteString $ qPath q--    version = Builder.fromString "HTTP/1.1"--    hostLine = mconcat-       [Builder.fromString"Host: ",-        hostname,-        crlf]--    hostname = case qHost q of-        Just x' -> Builder.copyByteString x'-        Nothing -> Builder.copyByteString h'--    headerFields = joinHeaders $ unWrap $ qHeaders q---crlf = Builder.fromString "\r\n"--sp = Builder.fromChar ' '---type StatusCode = Int------- | A description of the response received from the server. Note--- unlike other HTTP libraries, the response body is /not/ a part--- of this object; that will be streamed in by you when calling--- 'receiveResponse'.------ Like 'Request', 'Response' has a @Show@ instance that will output--- the status line and response headers as they were received from the--- server.----data Response-    = Response {-        pStatusCode       :: !StatusCode,-        pStatusMsg        :: !ByteString,-        pTransferEncoding :: !TransferEncoding,-        pContentEncoding  :: !ContentEncoding,-        pContentLength    :: !(Maybe Int64),-        pHeaders          :: !Headers-    }--instance Show Response where-    show p =     {-# SCC "Response.show" #-}-        S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p---data TransferEncoding = None | Chunked--data ContentEncoding = Identity | Gzip | Deflate-    deriving (Show)-------- | Get the HTTP response status code.----getStatusCode :: Response -> StatusCode-getStatusCode = pStatusCode-{-# INLINE getStatusCode #-}------- | Get the HTTP response status message. Keep in mind that this is--- /not/ normative; whereas 'getStatusCode' values are authoritative.----getStatusMessage :: Response -> ByteString-getStatusMessage = pStatusMsg-{-# INLINE getStatusMessage #-}------- | Lookup a header in the response. HTTP header field names are--- case-insensitive, so you can specify the name to lookup however you--- like. If the header is not present @Nothing@ will be returned.------ >     let n = case getHeader p "Content-Length" of--- >                Just x' -> read x' :: Int--- >                Nothing -> 0------ which of course is essentially what goes on inside the library when--- @http-streams@ receives a response from the server and has to figure--- out how many bytes to read.------ There is a fair bit of complexity in some of the other HTTP response--- fields, so there are a number of specialized functions for reading--- those values where we've found them useful.----getHeader :: Response -> ByteString -> Maybe ByteString-getHeader p k =-    lookupHeader h k-  where-    h = pHeaders p---composeResponseBytes :: Response -> Builder-composeResponseBytes p =-    mconcat-       [statusline,-        headerFields,-        crlf]-  where-    statusline = mconcat-       [version,-        sp,-        code,-        sp,-        message,-        crlf]--    code = Builder.fromShow $ pStatusCode p--    message = Builder.copyByteString $ pStatusMsg p--    version = Builder.fromString "HTTP/1.1"--    headerFields = joinHeaders $ unWrap $ pHeaders p-------- | The map of headers in a 'Request' or 'Response'. Note that HTTP--- header field names are case insensitive, so if you call 'setHeader'--- on a field that's already defined but with a different capitalization--- you will replace the existing value.----{--    This is a fair bit of trouble just to avoid using a typedef here.-    Probably worth it, though; every other HTTP client library out there-    exposes the gory details of the underlying map implementation, and-    to use it you need to figure out all kinds of crazy imports. Indeed,-    this code used here in the Show instance for debugging has been-    copied & pasted around various projects of mine since I started-    writing Haskell. It's quite tedious, and very arcane! So, wrap it-    up.--}-newtype Headers = Wrap {-    unWrap :: HashMap (CI ByteString) ByteString-}--instance Show Headers where-    show x = S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ joinHeaders $ unWrap x--joinHeaders :: HashMap (CI ByteString) ByteString -> Builder-joinHeaders m = foldrWithKey combine mempty m--combine :: CI ByteString -> ByteString -> Builder -> Builder-combine k v acc =-    mconcat [acc, key, Builder.fromString ": ", value, crlf]-  where-    key = Builder.copyByteString $ original k-    value = Builder.fromByteString v-{-# INLINE combine #-}--emptyHeaders :: Headers-emptyHeaders =-    Wrap empty--{--    Set a header field to the specified value. This will overwrite-    any existing value for the field. Remember that HTTP fields names-    are case insensitive!--}-updateHeader :: Headers -> ByteString -> ByteString -> Headers-updateHeader x k v =-    Wrap result-  where-    !result = insert (mk k) v m-    !m = unWrap x--removeHeader :: Headers -> ByteString -> Headers-removeHeader x k =-    Wrap result-  where-    !result = delete (mk k) m-    !m = unWrap x---{--    Given a list of key,value pairs, construct a 'Headers' map. This is-    only going to be used by RequestBuilder and ResponseParser,-    obviously. And yes, as usual, we go to a lot of trouble to splice-    out the function doing the work, in the name of type sanity.--}-buildHeaders :: [(ByteString,ByteString)] -> Headers-buildHeaders hs =-    Wrap result-  where-    result = foldl' addHeader empty hs--{--    insertWith is used here for the case where a header is repeated-    (for example, Set-Cookie) and the values need to be intercalated-    with ',' as per RFC 2616 §4.2.--}-addHeader-    :: HashMap (CI ByteString) ByteString-    -> (ByteString,ByteString)-    -> HashMap (CI ByteString) ByteString-addHeader m (k,v) =-    insertWith f (mk k) v m-  where-    f new old = S.concat [old, ",", new]--lookupHeader :: Headers -> ByteString -> Maybe ByteString-lookupHeader x k =-    lookup (mk k) m-  where-    !m = unWrap x---data HttpParseException = HttpParseException String-        deriving (Typeable, Show)--instance Exception HttpParseException
− src/Network/Http/Utilities.hs 
@@ -1,272 +0,0 @@------ HTTP client for use with io-streams------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is--- made available to you by its authors as open source software:--- you can redistribute it and/or modify it under the terms of--- the BSD licence.------ This file is essentially a clone of Snap.Internal.Parsing,--- the HTTP request parser implementation in the Snap Framework;--- snap-core's src/Snap/Internal/Parsing.hs and snap-server's--- src/Snap/Internal/Http/Parser.hs, copied here to specialize--- it to Response parsing. This code replaces the attoparsec--- based implementation formerly in ResponseParser, but is--- kept separate to aid syncing changes from snap-core as they--- become available.-----{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MagicHash          #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE Rank2Types         #-}-{-# LANGUAGE Trustworthy        #-}-{-# LANGUAGE UnboxedTuples      #-}--module Network.Http.Utilities (-    readResponseLine,-    readHeaderFields-) where---------------------------------------------------------------------------------import Control.Exception (throwIO)-import Control.Monad (when)-import Data.Bits-import qualified Data.ByteString.Char8 as S-import Data.ByteString.Internal (ByteString, w2c)-import qualified Data.ByteString.Unsafe as S-import Data.Char hiding (digitToInt, isDigit, isSpace)-import GHC.Exts (Int (..), Int#, (+#))-import Prelude hiding (head, take, takeWhile)-import System.IO.Streams (InputStream)-import qualified System.IO.Streams as Streams-------------------------------------------------------------------------------import Network.Http.Types----------------------------------------------------------------------------------{--    This is vestigial; originally it was the Request parsing-    code in Snap. Keeping it here until we can use if for-    response parsing.--}-parseRequest :: InputStream ByteString -> IO (Maybe Request)-parseRequest input = do-    eof <- Streams.atEOF input-    if eof-      then return Nothing-      else do-        line <- readResponseLine input-        let (!mStr,!s)      = bSp line-        let (!uri, !vStr)   = bSp s-        let !version        = pVer vStr :: (Int,Int)----      hdrs    <- readHeaderFields input-        return $! Nothing--  where--    pVer s = if "HTTP/" `S.isPrefixOf` s-               then pVers (S.unsafeDrop 5 s)-               else (1, 0)--    bSp   = splitCh ' '--    pVers s = (c, d)-      where-        (!a, !b)   = splitCh '.' s-        !c         = unsafeFromNat a-        !d         = unsafeFromNat b---{--    Read a single line of an HTTP response.--}-readResponseLine :: InputStream ByteString -> IO ByteString-readResponseLine input = go []-  where-    throwNoCRLF =-        throwIO $-        HttpParseException "parse error: expected line ending in crlf"--    throwBadCRLF =-        throwIO $-        HttpParseException "parse error: got cr without subsequent lf"--    go !l = do-        !mb <- Streams.read input-        !s  <- maybe throwNoCRLF return mb--        case findCRLF s of-            FoundCRLF idx# -> foundCRLF l s idx#-            NoCR           -> noCRLF l s-            LastIsCR idx#  -> lastIsCR l s idx#-            _              -> throwBadCRLF--    foundCRLF l s idx# = do-        let !i1 = (I# idx#)-        let !i2 = (I# (idx# +# 2#))-        let !a = S.unsafeTake i1 s-        when (i2 < S.length s) $ do-            let !b = S.unsafeDrop i2 s-            Streams.unRead b input--        -- Optimize for the common case: dl is almost always "id"-        let !out = if null l then a else S.concat (reverse (a:l))-        return out--    noCRLF l s = go (s:l)--    lastIsCR l s idx# = do-        !t <- Streams.read input >>= maybe throwNoCRLF return-        if S.null t-          then lastIsCR l s idx#-          else do-            let !c = S.unsafeHead t-            if c /= 10-              then throwBadCRLF-              else do-                  let !a = S.unsafeTake (I# idx#) s-                  let !b = S.unsafeDrop 1 t-                  when (not $ S.null b) $ Streams.unRead b input-                  let !out = if null l then a else S.concat (reverse (a:l))-                  return out----------------------------------------------------------------------------------data CS = FoundCRLF !Int#-        | NoCR-        | LastIsCR !Int#-        | BadCR----------------------------------------------------------------------------------findCRLF :: ByteString -> CS-findCRLF b =-    case S.elemIndex '\r' b of-      Nothing         -> NoCR-      Just !i@(I# i#) ->-          let !i' = i + 1-          in if i' < S.length b-               then if S.unsafeIndex b i' == 10-                      then FoundCRLF i#-                      else BadCR-               else LastIsCR i#-{-# INLINE findCRLF #-}----------------------------------------------------------------------------------splitCh :: Char -> ByteString -> (ByteString, ByteString)-splitCh !c !s = maybe (s, S.empty) f (S.elemIndex c s)-  where-    f !i = let !a = S.unsafeTake i s-               !b = S.unsafeDrop (i + 1) s-           in (a, b)-{-# INLINE splitCh #-}----------------------------------------------------------------------------------breakCh :: Char -> ByteString -> (ByteString, ByteString)-breakCh !c !s = maybe (s, S.empty) f (S.elemIndex c s)-  where-    f !i = let !a = S.unsafeTake i s-               !b = S.unsafeDrop i s-           in (a, b)-{-# INLINE breakCh #-}----------------------------------------------------------------------------------splitHeader :: ByteString -> (ByteString, ByteString)-splitHeader !s = maybe (s, S.empty) f (S.elemIndex ':' s)-  where-    l = S.length s--    f i = let !a = S.unsafeTake i s-          in (a, skipSp (i + 1))--    skipSp !i | i >= l    = S.empty-              | otherwise = let c = S.unsafeIndex s i-                            in if isLWS $ w2c c-                                 then skipSp $ i + 1-                                 else S.unsafeDrop i s--{-# INLINE splitHeader #-}-----------------------------------------------------------------------------------isLWS :: Char -> Bool-isLWS c = c == ' ' || c == '\t'-{-# INLINE isLWS #-}-----------------------------------------------------------------------------------{--    Read the remainder of the response message's header section,-    parsing into key/value pairs. Note that this function terminates-    when it hits the "blank" line (ie, CRLF CRLF pair), which it-    consumes.--}-readHeaderFields :: InputStream ByteString -> IO [(ByteString,ByteString)]-readHeaderFields input = do-    f <- go id-    return $! f []--  where-    go !dlistSoFar = do-        line <- readResponseLine input-        if S.null line-          then return dlistSoFar-          else do-            let (!k,!v) = splitHeader line-            vf <- pCont id-            let vs = vf []-            let !v' = if null vs then v else S.concat (v:vs)-            let !t = (k,v')-            go (dlistSoFar . (t:))--      where-        trimBegin = S.dropWhile isLWS--        pCont !dlist = do-            mbS  <- Streams.peek input-            maybe (return dlist)-                  (\s -> if S.null s-                           then Streams.read input >> pCont dlist-                           else if isLWS $ w2c $ S.unsafeHead s-                                  then procCont dlist-                                  else return dlist)-                  mbS--        procCont !dlist = do-            line <- readResponseLine input-            let !t = trimBegin line-            pCont (dlist . (" ":) . (t:))----                            ------------------------                            -- utility functions ---                            ----------------------------------------------------------------------------------------------------------- | Note: only works for nonnegative naturals-unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a-unsafeFromNat = S.foldl' f 0-  where-    zero = ord '0'-    f !cnt !i = cnt * 10 + toEnum (digitToInt i)--    digitToInt c = if d >= 0 && d <= 9-                     then d-                     else error $ "bad digit: '" ++ [c] ++ "'"-      where-        !d = ord c - zero-{-# INLINE unsafeFromNat #-}
− tests/Check.hs 
@@ -1,25 +0,0 @@------ HTTP client for use with io-streams------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is made--- available to you by its authors as open source software: you can--- redistribute it and/or modify it under a BSD licence.-----{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS -fno-warn-unused-imports #-}--module Main where--import OpenSSL (withOpenSSL)-import Test.Hspec (hspec)--import MockServer (runMockServer)-import TestSuite (suite)--main :: IO ()-main = withOpenSSL $ do-    runMockServer-    hspec suite
+ tests/MockServer.hs view
@@ -0,0 +1,306 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2021 Athae Eredh Siniath and Others+--+-- The code in this file, and the program it is a part of, is made+-- available to you by its authors as open source software: you can+-- redistribute it and/or modify it under a BSD licence.+--+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}++{-# OPTIONS -fno-warn-dodgy-imports #-}++module MockServer (runMockServer, localPort) where++{-+    Per http://hackage.haskell.org/trac/ghc/ticket/7167, we suppress+    the warning resulting from this line, necessary on <7.6+-}+import Prelude hiding (catch)++import Control.Applicative+import Control.Concurrent (forkIO, threadDelay)+import Control.Exception (SomeException)+import Control.Exception.Lifted (catch)+import "mtl" Control.Monad.Trans (liftIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe (fromMaybe)+import System.Directory (getFileSize)+import Snap.Core+import Snap.Http.Server+import Snap.Util.FileServe+import System.IO (hFlush, hPutStrLn, stderr)++import Network.Http.Client (Hostname, Port)++localHost = "localhost" :: Hostname+localPort = 56981 :: Port++main :: IO ()+main = go++{-+    Binding the port to the IPv4 localhost appears to settle the problem+    of localhost resolving ambigiously. If that doesn't work, we can+    comment out the setBind and the resultant 0.0.0.0 does seem to work.+-}+go :: IO ()+go = httpServe c site+  where+    c =+        setAccessLog ConfigNoLog $+            setErrorLog ConfigNoLog $+                setHostname localHost $+                    setBind localHost $+                        setPort (fromIntegral localPort) $+                            setVerbose False emptyConfig++runMockServer :: IO ()+runMockServer = do+    _ <- forkIO go+    threadDelay 2000000+    return ()++--+-- Top level URL routing logic.+--++site :: Snap ()+site =+    catch+        (routeRequests)+        (\e -> serveError "Splat\n" e)++routeRequests :: Snap ()+routeRequests =+    route+        [ ("resource/:id", serveResource)+        , ("static/:id", method GET serveStatic)+        , ("time", serveTime)+        , ("", ifTop handleAsText)+        , ("bounce", serveRedirect)+        , ("local", serveLocalRedirect)+        , ("loop", serveRedirectEndlessly)+        , ("empty", serveWithoutContent)+        , ("postbox", method POST handlePostMethod)+        , ("size", handleSizeRequest)+        , ("api", handleRestfulRequest)+        , ("cookies", serveRepeatedResponseHeaders)+        ]+        <|> serveNotFound++serveResource :: Snap ()+serveResource = do+    r <- getRequest++    let m = rqMethod r+    case m of+        GET -> handleGetMethod+        PUT -> handlePutWithExpectation+        _ -> serveMethodNotAllowed++serveStatic :: Snap ()+serveStatic = do+    im' <- getParam "id"++    let i' = fromMaybe "" im'+    let f' = S.concat ["tests/", i']+    let f = S.unpack f'++    l <- liftIO $ getFileSize f++    let t = fileType defaultMimeTypes f+    modifyResponse $ setContentType t+    modifyResponse $ setContentLength $ fromIntegral l+    b' <- liftIO $ S.readFile f+    writeBS b'++serveTime :: Snap ()+serveTime = do+    writeBS "Sun 30 Dec 12, 05:39:56.746Z\n"++--+-- Dispatch normal GET requests based on MIME type.+--++handleGetMethod :: Snap ()+handleGetMethod = do+    r <- getRequest+    let mime0 = getHeader "Accept" r++    case mime0 of+        Just "text/html" -> handleAsBrowser+        _ -> handleAsText++handleAsBrowser :: Snap ()+handleAsBrowser = do+    modifyResponse $ setResponseStatus 200 "OK"+    modifyResponse $ setContentType "text/html; charset=UTF-8"+    modifyResponse $ setHeader "Cache-Control" "max-age=1"+    sendFile "tests/hello.html"++handleAsText :: Snap ()+handleAsText = do+    modifyResponse $ setContentType "text/plain"+    writeBS "Sounds good to me\n"++handleRestfulRequest :: Snap ()+handleRestfulRequest = do+    modifyResponse $ setResponseStatus 200 "OK"+    modifyResponse $ setContentType "application/json"++    sendFile "tests/data-eu-gdp.json"++serveRedirect :: Snap ()+serveRedirect = do+    modifyResponse $ setResponseStatus 307 "Temporary Redirect"+    modifyResponse $ setHeader "Cache-Control" "no-cache"+    modifyResponse $ setHeader "Location" r'+  where+    r' = S.concat ["http://", localHost, ":", S.pack $ show $ localPort, "/time"]++serveLocalRedirect :: Snap ()+serveLocalRedirect = do+    modifyResponse $ setResponseStatus 307 "Temporary Redirect"+    modifyResponse $ setHeader "Cache-Control" "no-cache"+    modifyResponse $ setHeader "Location" r'+  where+    r' = S.pack "/time"++serveRedirectEndlessly :: Snap ()+serveRedirectEndlessly = do+    modifyResponse $ setResponseStatus 307 "Temporary Redirect"+    modifyResponse $ setHeader "Cache-Control" "no-cache"+    modifyResponse $ setHeader "Location" r'+  where+    r' = S.concat ["http://", localHost, ":", S.pack $ show $ localPort, "/loop"]++{-+    Attempt to test the bug with 204 No Content not closing in absence of a+    Content-Length header, however Snap automatically adds one, it seems. So,+    after the fact, this is unused and the case is tested in+    TestServer.testDevoidOfContent.+-}++serveWithoutContent :: Snap ()+serveWithoutContent = do+    modifyResponse $ setResponseStatus 204 "No Content"+    modifyResponse $ setHeader "Cache-Control" "no-cache"++serveRepeatedResponseHeaders :: Snap ()+serveRepeatedResponseHeaders = do+    modifyResponse $ addHeader "Set-Cookie" "stone=diamond"+    modifyResponse $ addHeader "Set-Cookie" "metal=tungsten"++handlePostMethod :: Snap ()+handlePostMethod = do+    setTimeout 5+    modifyResponse $ setResponseStatus 201 "Created"+    modifyResponse $ setHeader "Cache-Control" "no-cache"+    modifyResponse $ setHeader "Location" "http://server.example.com/something/788"+    modifyResponse $ setContentType "text/plain"++    b' <- readRequestBody 1024+    writeLBS b'++handlePutWithExpectation :: Snap ()+handlePutWithExpectation = do+    setTimeout 5+    modifyResponse $ setResponseStatus 201 "Created"+    modifyResponse $ setHeader "Cache-Control" "no-cache"+    modifyResponse $ setContentType "text/plain"++    b' <- readRequestBody 1024+    writeLBS b'++handleSizeRequest :: Snap ()+handleSizeRequest = do+    r <- getRequest+    let mm = getHeader "Content-Type" r++    t <- case mm of+        Just m -> return m+        _ -> do+            serveUnsupported+            return ""++    modifyResponse $ setResponseStatus 200 "OK"+    modifyResponse $ setContentType t++    b' <- readRequestBody 65536+    writeBS $ S.pack $ show $ L.length b'++updateResource :: Snap ()+updateResource = do+    bs' <- readRequestBody 4096+    let b' = fromLazy bs'++    im' <- getParam "id"+    let i' = fromMaybe "0" im'++    -- TODO something++    modifyResponse $ setResponseStatus 204 "Updated" -- "No Content"+    modifyResponse $ setHeader "Cache-Control" "no-cache"+    modifyResponse $ setContentLength 0+    return ()+  where+    fromLazy ls' = S.concat $ L.toChunks ls'++serveNotFound :: Snap a+serveNotFound = do+    modifyResponse $ setResponseStatus 404 "Not Found"+    modifyResponse $ setHeader "Content-Type" "text/html"++    writeBS "404 Not Found"++    r <- getResponse+    finishWith r++serveBadRequest :: Snap ()+serveBadRequest = do+    modifyResponse $ setResponseStatus 400 "Bad Request"+    writeBS "400 Bad Request\n"++serveMethodNotAllowed :: Snap ()+serveMethodNotAllowed = do+    modifyResponse $ setResponseStatus 405 "Method Not Allowed"+    modifyResponse $ setHeader "Allow" "GET, POST, PUT"++    writeBS "405 Method Not Allowed\n"+    r <- getResponse+    finishWith r++serveUnsupported :: Snap ()+serveUnsupported = do+    modifyResponse $ setResponseStatus 415 "Unsupported Media Type"+    writeBS "415 Unsupported Media Type\n"+    r <- getResponse+    finishWith r++--+-- The exception will be dumped to the server's stdout, while the supplied+-- message will be sent out with the response (ideally only for debugging+-- purposes, but easier than looking in log/error.log for details).+--++serveError :: ByteString -> SomeException -> Snap ()+serveError x' e = do+    debug msg+    modifyResponse $ setResponseStatus 500 "Internal Server Error"+    writeBS x'+    r <- getResponse+    finishWith r+  where+    msg = show (e :: SomeException)++debug :: String -> Snap ()+debug cs = do+    liftIO $ do+        hPutStrLn stderr ""+        hPutStrLn stderr cs+        hFlush stderr
+ tests/TestSuite.hs view
@@ -0,0 +1,857 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2021 Athae Eredh Siniath and Others+--+-- The code in this file, and the program it is a part of, is made+-- available to you by its authors as open source software: you can+-- redistribute it and/or modify it under a BSD licence.+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS -fno-warn-unused-imports #-}++module TestSuite where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (+    fromByteString,+    toByteString,+ )+import qualified Blaze.ByteString.Builder.Char8 as Builder (+    fromChar,+    fromString,+ )+import Control.Applicative+import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (Exception, bracket, handleJust)+import Control.Monad (forM_, guard)+import Data.Aeson (+    FromJSON,+    ToJSON,+    Value (..),+    encode,+    object,+    parseJSON,+    toJSON,+    (.:),+    (.=),+ )+import Data.Aeson.Encode.Pretty+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as KeyMap+#endif+import Data.Bits+import Data.Maybe (fromJust)+import Data.Monoid+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import GHC.Generics hiding (Selector)+import Network.Socket (SockAddr (..))+import Network.URI (URI (..), URIAuth (..), parseURI)+import System.Timeout (timeout)+import Test.HUnit+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Expectations (Selector, anyException, shouldThrow)++import Debug.Trace++--+-- Otherwise redundent imports, but useful for testing in GHCi.+--++import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly, parseTest)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy as L+import Debug.Trace+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Streams+import qualified System.IO.Streams.Debug as Streams++--+-- what we're actually testing+--++import MockServer (localPort)+import Network.Http.Client+import Network.Http.Connection (Connection (..))+import Network.Http.Inconvenience (+    HttpClientError (..),+    TooManyRedirects (..),+    parseURL,+    splitURI,+ )+import Network.Http.Internal (+    Request (..),+    Response (..),+    composeRequestBytes,+    lookupHeader,+ )+import Network.Http.ResponseParser (readDecimal, readResponseHeader)++localhost = S.pack ("localhost:" ++ show localPort)++suite :: Spec+suite = do+    describe "Opening a connection" $ do+        testConnectionHost++    describe "Request, when serialized" $ do+        testRequestLineFormat+        testRequestTermination+        testEnsureHostField+        testAcceptHeaderFormat+        testBasicAuthorizatonHeader++    describe "Parsing responses" $ do+        testResponseParser1+        testResponseParserMismatch+        testPaddedContentLength+        --      testTrailingWhitespace+        testChunkedEncoding+        testContentLength+        testDevoidOfContent+        testCompressedResponse+        testRepeatedResponseHeaders++    describe "Expectation handling" $ do+        testExpectationContinue++    describe "Convenience API" $ do+        testPutChunks+        testPostChunks+        testPostWithForm+        testGetRedirects+        testSplitURI+        testParseURL+        testParseURLHasEscaped+        testGetLocalRedirects+        testGetFormatsRequest+        testExcessiveRedirects+        testGeneralHandler+        testEstablishConnection+        testParsingJson1+        testParsingJson2+        testPutWithSimple+        testPutWithJson+        testMultipartUpload++    describe "Corner cases in protocol compliance" $ do+        testSendBodyFor PUT+        testSendBodyFor DELETE+        testSendBodyFor PATCH++testRequestTermination =+    it "terminates with a blank line" $ do+        c <- openConnection "localhost" localPort+        let q = buildRequest1 $ do+                http GET "/time"+                setAccept "text/plain"++        let e' = Builder.toByteString $ composeRequestBytes q "booga"+        let n = S.length e' - 4+        let (a', b') = S.splitAt n e'++        assertEqual "Termination not CRLF CRLF" "\r\n\r\n" b'+        assertBool+            "Must be only one blank line at end of headers"+            ('\n' /= S.last a')++        closeConnection c++testRequestLineFormat = do+    it "has a properly formatted request line" $+        bracket+            (fakeConnection)+            (return)+            ( \c -> do+                let q = buildRequest1 $ do+                        http GET "/time"++                let e' = Builder.toByteString $ composeRequestBytes q (cHost c)+                let l' = S.takeWhile (/= '\r') e'++                assertEqual "Invalid HTTP request line" "GET /time HTTP/1.1" l'+            )++    it "handles empty request path" $+        bracket+            (fakeConnection)+            (return)+            ( \c -> do+                let q = buildRequest1 $ do+                        http GET ""++                let e' = Builder.toByteString $ composeRequestBytes q (cHost c)+                let l' = S.takeWhile (/= '\r') e'++                assertEqual "Invalid HTTP request line" "GET / HTTP/1.1" l'+            )++fakeConnection :: IO Connection+fakeConnection = do+    i <- Streams.nullInput+    o <- Streams.nullOutput+    c <- makeConnection "www.example.com" (return ()) o i+    return c++testAcceptHeaderFormat =+    it "properly formats Accept header" $ do+        let q = buildRequest1 $ do+                setAccept' [("text/html", 1), ("*/*", 0.0)]++        let h = qHeaders q+        let (Just a) = lookupHeader h "Accept"+        assertEqual "Failed to format header" "text/html; q=1.0, */*; q=0.0" a++testBasicAuthorizatonHeader =+    it "properly formats Authorization header" $ do+        let q = buildRequest1 $ do+                setAuthorizationBasic "Aladdin" "open sesame"++        let h = qHeaders q+        let (Just a) = lookupHeader h "Authorization"+        assertEqual "Failed to format header" "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" a++testConnectionHost = do+    it "properly caches hostname and port" $ do+        bracket+            (openConnection "localhost" localPort)+            closeConnection+            ( \c -> do+                let h' = cHost c+                assertEqual+                    "Host value needs to be name, not IP address"+                    expected+                    h'+            )+  where+    expected = S.pack $ "localhost:" ++ show localPort++{-+    Incidentally, Host is *not* stored in the Headers map, but is a field+    of the Request object.+-}+testEnsureHostField =+    it "has a properly formatted Host header" $ do+        let q1 = buildRequest1 $ do+                http GET "/hello.txt"++        let h1 = qHost q1+        assertEqual "Incorrect Host header" Nothing h1++        let q2 = buildRequest1 $ do+                http GET "/hello.txt"+                setHostname "other.example.com" 80++        let h2 = qHost q2+        assertEqual "Incorrect Host header" (Just "other.example.com") h2++        let q3 = buildRequest1 $ do+                http GET "/hello.txt"+                setHostname "other.example.com" 54321++        let h3 = qHost q3+        assertEqual "Incorrect Host header" (Just "other.example.com:54321") h3++testResponseParser1 =+    it "parses a simple 200 response" $ do+        p <- Streams.withFileAsInput "tests/example1.txt" (\i -> readResponseHeader i)++        assertEqual "Incorrect parse of response" 200 (getStatusCode p)+        return ()++testResponseParserMismatch =+    it "parses response when HTTP version doesn't match" $ do+        p <- Streams.withFileAsInput "tests/example3.txt" (\i -> readResponseHeader i)++        assertEqual "Incorrect parse of response" 200 (getStatusCode p)+        return ()++testPaddedContentLength =+    it "handles padded Content-Length" $ do+        p <- Streams.withFileAsInput "tests/example4.txt" (\i -> readResponseHeader i)++        let (Just len) = pContentLength p+        assertEqual "Should have trimmed in decimal conversion" 86 len++{-+    Presently inactive+-}+testTrailingWhitespace =+    it "where headers have trailing whitespace" $ do+        p <- Streams.withFileAsInput "tests/example4.txt" (\i -> readResponseHeader i)++        let (Just value) = getHeader p "Content-Length"+        assertEqual "Should have trimmed field value" "86" value++testChunkedEncoding =+    it "recognizes chunked transfer encoding and decodes" $ do+        c <- openConnection "localhost" localPort++        let q = buildRequest1 $ do+                http GET "/time"++        sendRequest c q emptyBody+        receiveResponse+            c+            ( \p i1 -> do+                let cm = getHeader p "Transfer-Encoding"+                assertEqual "Should be chunked encoding!" (Just "chunked") cm++                (i2, getCount) <- Streams.countInput i1+                Streams.skipToEof i2++                len <- getCount+                assertEqual "Incorrect number of bytes read" 29 len+            )++testContentLength = do+    it "recognzies fixed length message" $ do+        c <- openConnection "localhost" localPort++        let q = buildRequest1 $ do+                http GET "/static/statler.jpg"++        sendRequest c q emptyBody++        receiveResponse+            c+            ( \p i1 -> do+                let nm = getHeader p "Content-Length"+                assertMaybe "Should be a Content-Length header!" nm++                let n = read $ S.unpack $ fromJust nm :: Int+                assertEqual "Should be a fixed length message!" 4611 n++                (i2, getCount) <- Streams.countInput i1+                x' <- Streams.readExactly 4611 i2++                len <- getCount+                assertEqual "Incorrect number of bytes read" 4611 len+                assertBool "Incorrect length" (4611 == S.length x')++                end <- Streams.atEOF i2+                assertBool "Expected end of stream" end+            )++    it "doesn't choke if server neglects Content-Length" $ do+        p <- Streams.withFileAsInput "tests/example3.txt" (\i -> readResponseHeader i)++        assertEqual "Incorrect parse of response" 200 (getStatusCode p)+        assertEqual "Incorrect parse of response" Nothing (getHeader p "Content-Length")+        assertEqual "Should not have pContentLength" Nothing (pContentLength p)+        return ()++    it "reads body without Content-Length or Transfer-Encoding" $ do+        c <- fakeConnectionHttp10+        let q = buildRequest1 $ do+                http GET "/fake"+        sendRequest c q emptyBody+        receiveResponse+            c+            ( \_ i1 -> do+                (i2, getCount) <- Streams.countInput i1+                o <- Streams.nullOutput+                Streams.connect i2 o++                end <- Streams.atEOF i2+                assertBool "Expected end of stream" end++                len <- getCount+                assertEqual "Incorrect number of bytes read" 4611 len+            )++        return ()++fakeConnectionHttp10 :: IO Connection+fakeConnectionHttp10 = do+    x' <- S.readFile "tests/example3.txt"+    i <- Streams.fromByteString x'++    o <- Streams.nullOutput+    c <- makeConnection "bad.example.com" (return ()) o i+    return c++{-+    Corner case where servers responding 204 No Content are not required to+    transmit a Content-Length header; Snap *does* send one, so we can't test it+    in the MockServer, so fake it with example5.txt+-}++testDevoidOfContent = do+    it "handles 204 No Content response without Content-Length" $+        timeout_ 2 $ do+            (c, mv) <- fakeConnectionNoContent+            let q = buildRequest1 $ do+                    http GET "/fake"+            sendRequest c q emptyBody+            receiveResponse+                c+                ( \_ i1 -> do+                    (i2, getCount) <- Streams.countInput i1+                    o <- Streams.nullOutput+                    Streams.connect i2 o++                    end <- Streams.atEOF i2+                    assertBool "Expected end of stream" end++                    len <- getCount+                    assertEqual "Incorrect number of bytes read" 0 len+                )+            putMVar mv ()+            return ()+  where+    secs :: Int+    secs = 10 ^ (6 :: Int)++    timeout_ :: Int -> IO a -> IO a+    timeout_ t m = timeout (t * secs) m >>= maybe (error "timeout") return++fakeConnectionNoContent :: IO (Connection, MVar ())+fakeConnectionNoContent = do+    x' <- S.readFile "tests/example5.txt"+    i1 <- Streams.fromByteString x'+    mv <- newEmptyMVar+    i2 <- Streams.makeInputStream $ blockOn mv+    i3 <- Streams.concatInputStreams [i1, i2]++    o <- Streams.nullOutput+    c <- makeConnection "worse.example.com" (return ()) o i3+    return (c, mv)+  where+    blockOn :: MVar () -> IO (Maybe ByteString)+    blockOn mv = takeMVar mv >> return Nothing++{-+    This had to change when we moved to an internal test server; seems+    Snap is doing something funny when gzipping and switching to chunked+    encoding no matter what I do.+-}+testCompressedResponse =+    it "recognizes gzip content encoding and decompresses" $ do+        c <- openConnection "localhost" localPort++        let q = buildRequest1 $ do+                http GET "/static/hello.html"+                setHeader "Accept-Encoding" "gzip"++        sendRequest c q emptyBody++        receiveResponse+            c+            ( \p i -> do+                let nm = getHeader p "Content-Encoding"+                assertMaybe "Should be a Content-Encoding header!" nm+                assertEqual "Content-Encoding header should be 'gzip'!" (Just "gzip") nm++                (i2, getCount) <- Streams.countInput i+                x' <- Streams.readExactly 102 i2++                len <- getCount+                assertEqual "Incorrect number of bytes read" 102 len+                assertBool "Incorrect length" (102 == S.length x')++                end <- Streams.atEOF i+                assertBool "Expected end of stream" end+            )++{-+    This isn't much of a test yet; we really need to test+    a) that 100 Continue was received b) that it was absorbed+    c) that body is correct size, and then d) 4xx and 5xx+    responses are propegated through.+-}++testExpectationContinue =+    it "sends expectation and handles 100 response" $ do+        c <- openConnection "localhost" localPort++        let q = buildRequest1 $ do+                http PUT "/resource/x149"+                setExpectContinue++        sendRequest+            c+            q+            ( \o -> do+                Streams.write (Just (Builder.fromString "Hello world\n")) o+            )++        receiveResponse+            c+            ( \p i -> do+                assertEqual "Incorrect status code" 201 (getStatusCode p)+                x' <- Streams.readExactly 12 i++                end <- Streams.atEOF i+                assertBool "Expected end of stream" end++                assertEqual "Incorrect body" "Hello world\n" x'+            )++        closeConnection c++assertMaybe :: String -> Maybe a -> Assertion+assertMaybe prefix m0 =+    case m0 of+        Nothing -> assertFailure prefix+        Just _ -> assertBool "" True++testPutChunks =+    it "PUT correctly chunks known size entity body" $ do+        let url = S.concat ["http://", localhost, "/size"]++        put url "text/plain" body handler+  where+    body :: OutputStream Builder -> IO ()+    body o = do+        let x = mconcat $ replicate 33000 (Builder.fromChar 'x')+        Streams.write (Just x) o++    handler :: Response -> InputStream ByteString -> IO ()+    handler _ i = do+        (Just b') <- Streams.read i++        end <- Streams.atEOF i+        assertBool "Expected end of stream" end++        let size = readDecimal b' :: Int+        assertEqual "Should have replied with correct file size" 33000 size++testSendBodyFor meth =+    it ("Sends a request body for " ++ show meth) $ do+        c <- openConnection "localhost" localPort++        let q = buildRequest1 $ do+                http meth "/size"+                setContentType "text/plain"+                setTransferEncoding++        sendRequest+            c+            q+            ( \o -> do+                Streams.write (Just (Builder.fromString "a request")) o+            )++        receiveResponse+            c+            ( \p i -> do+                assertEqual "Incorrect status code" 200 (getStatusCode p)+                (Just b') <- Streams.read i++                let size = readDecimal b' :: Int+                assertEqual "Should have received a request body" 9 size+            )++        closeConnection c++testPostChunks =+    it "POST correctly chunks a fileBody" $ do+        let url = S.concat ["http://", localhost, "/size"]++        post url "image/jpeg" (fileBody "tests/statler.jpg") handler+  where+    handler :: Response -> InputStream ByteString -> IO ()+    handler p i = do+        let code = getStatusCode p+        assertEqual "Expected 200 OK" 200 code++        (Just b') <- Streams.read i++        end <- Streams.atEOF i+        assertBool "Expected end of stream" end++        let size = readDecimal b' :: Int+        assertEqual "Should have replied with correct file size" 4611 size++testPostWithForm =+    it "POST with form data correctly encodes parameters" $ do+        let url = S.concat ["http://", localhost, "/postbox"]++        postForm+            url+            [ ("name", "Kermit")+            , ("role", "St&gehand")+            , ("country", Text.encodeUtf8 $ Text.pack "Nørway")+            ]+            handler+  where+    handler :: Response -> InputStream ByteString -> IO ()+    handler p i = do+        let code = getStatusCode p+        assertEqual "Expected 201" 201 code++        b' <- Streams.readExactly 48 i++        end <- Streams.atEOF i+        assertBool "Expected end of stream" end++        assertEqual+            "Incorrect URL encoding"+            "name=Kermit&role=St%26gehand&country=N%c3%b8rway"+            b'++testGetRedirects =+    it "GET internal handler follows redirect on 307" $ do+        let url = S.concat ["http://", localhost, "/bounce"]++        get url handler+  where+    handler :: Response -> InputStream ByteString -> IO ()+    handler p i1 = do+        let code = getStatusCode p+        assertEqual "Should have been final code" 200 code++        (i2, getCount) <- Streams.countInput i1+        Streams.skipToEof i2++        len <- getCount+        assertEqual "Incorrect number of bytes read" 29 len++testGetLocalRedirects =+    it "GET internal handler follows local redirect on 307" $ do+        let url = S.concat ["http://", localhost, "/local"]++        get url handler+  where+    handler :: Response -> InputStream ByteString -> IO ()+    handler p i1 = do+        let code = getStatusCode p+        assertEqual "Should have been final code" 200 code++        (i2, getCount) <- Streams.countInput i1+        Streams.skipToEof i2++        len <- getCount+        assertEqual "Incorrect number of bytes read" 29 len++testSplitURI =+    it "check splitURI for local redirects" $ do+        let a1 = "http://asdf@ya.ru:8000/hello/?asd=asd&abc=2"+            r1 = S.pack "/hello/?asd=asd&abc=2"+        assertEqual "Incorrect split uri 1" (S.pack a1) (splitURI (fromJust $ parseURI a1) r1)++        let a2 = "http://asdf@ya.ru:8000/again/?asd=asd&abc=2"+            r2 = S.pack "/again/?asd=asd&abc=2"+        assertEqual "Incorrect split uri 2" (S.pack a2) (splitURI (fromJust $ parseURI a2) r2)++        let a3 = "http://ya.ru:8000/here/?asd=asd&abc=2"+            r3 = S.pack "/here/?asd=asd&abc=2"+        assertEqual "Incorrect split uri 3" (S.pack a3) (splitURI (fromJust $ parseURI a3) r3)++        let a4 = "http://ya.ru/?asd=asd&abc=2#papa"+            r4 = S.pack "/?asd=asd&abc=2#papa"+        assertEqual "Incorrect split uri 4" (S.pack a4) (splitURI (fromJust $ parseURI a4) r4)++        let a5 = "http://ya.ru/?asd=asd&abc=2#papa"+            r5 = S.pack "http://google.ru/"+        assertEqual "Incorrect split uri 5" r5 (splitURI (fromJust $ parseURI a5) r5)++testParseURL =+    it "Parse URL with chars needing encoding" $ do+        let url = parseURL (Text.encodeUtf8 $ Text.pack "http://example.com/α")+        assertEqual+            "Incorrect URL parsing"+            (URI "http:" (Just $ URIAuth "" "example.com" "") "/%CE%B1" "" "")+            url++testParseURLHasEscaped =+    it "Parse URL with chars already encoded" $ do+        let url = parseURL (Text.encodeUtf8 $ Text.pack "http://example.com/hello%20world")+        assertEqual+            "Incorrect URL parsing"+            (URI "http:" (Just $ URIAuth "" "example.com" "") "/hello%20world" "" "")+            url++testGetFormatsRequest =+    it "GET includes a properly formatted request path" $ do+        let url = S.concat ["http://", localhost]+        x' <- get url concatHandler'++        assertBool "Incorrect context path" (S.length x' > 0)++testExcessiveRedirects =+    it "too many redirects result in an exception" $ do+        let url = S.concat ["http://", localhost, "/loop"]++        get url handler `shouldThrow` tooManyRedirects+  where+    handler :: Response -> InputStream ByteString -> IO ()+    handler _ _ = do+        assertBool "Should have thrown exception before getting here" False++testRepeatedResponseHeaders =+    it "repeated response headers are properly concatonated" $ do+        let url = S.concat ["http://", localhost, "/cookies"]++        get url handler+  where+    handler :: Response -> InputStream ByteString -> IO ()+    handler r _ = do+        assertEqual "Invalid response headers" (Just "stone=diamond,metal=tungsten") (getHeader r "Set-Cookie")++{-+    From http://stackoverflow.com/questions/6147435/is-there-an-assertexception-in-any-of-the-haskell-test-frameworks+    because "although HUnit doesn't have this, it's easy to write your+    own". Uh huh. Surely there's an easier way to do this.+-}++assertException :: (Exception e, Eq e) => e -> IO a -> IO ()+assertException ex action =+    handleJust isWanted (const $ return ()) $ do+        _ <- action+        assertFailure $ "Expected exception: " ++ show ex+  where+    isWanted = guard . (== ex)++testGeneralHandler =+    it "GET with general purpose handler throws exception on 404" $ do+        let url = S.concat ["http://", localhost, "/booga"]++        get url concatHandler' `shouldThrow` httpClientError 404++tooManyRedirects :: Selector TooManyRedirects+tooManyRedirects = const True++--              :: Int -> Selector HttpClientError+httpClientError :: Int -> HttpClientError -> Bool+httpClientError expected (HttpClientError actual _) = expected == actual++testEstablishConnection =+    it "public establish function behaves correctly" $ do+        let url = S.concat ["http://", localhost, "/static/statler.jpg"]++        x' <-+            withConnection (establishConnection url) $+                ( \c -> do+                    let q = buildRequest1 $ do+                            http GET "/static/statler.jpg"+                    -- TODO be nice if we could replace that with 'url';+                    -- fix the routeRequests function in TestServer maybe?+                    sendRequest c q emptyBody+                    receiveResponse c concatHandler'+                )++        let len = S.length x'+        assertEqual "Incorrect number of bytes read" 4611 len++testParsingJson1 =+    it "GET with JSON handler behaves" $ do+        let url = S.concat ["http://", localhost, "/static/data-eu-gdp.json"]++        x <- get url jsonHandler+        let (Object o) = x+        let (Just v) = KeyMap.lookup "label" o+        let (String t) = v++        assertEqual "Incorrect response" "Europe (EU27)" t++testParsingJson2 =+    it "GET with JSON handler parses using Aeson" $ do+        let url = S.concat ["http://", localhost, "/static/data-jp-gdp.json"]++        x <- get url jsonHandler :: IO GrossDomesticProduct++        assertEqual "Incorrect response" "Japan" (gLabel x)+        assertEqual "Data not parsed as expected" 2008 (fst $ last $ gData x)++--      L.putStr $ encodePretty x++{-+    Go to the trouble to create a Haskell data type representing the JSON feed+    we're getting from the sample data files. The Generic trick doesn't work+    because data is a reserved word, of course.+-}++data GrossDomesticProduct = GrossDomesticProduct+    { gLabel :: Text+    , gData :: [(Int, Double)]+    }+    deriving (Show, Generic)++instance FromJSON GrossDomesticProduct where+    parseJSON (Object o) =+        GrossDomesticProduct+            <$> o .: "label"+            <*> o .: "data"+    parseJSON _ = undefined++instance ToJSON GrossDomesticProduct where+    toJSON (GrossDomesticProduct l d) =+        object+            [ "label" .= l+            , "data" .= d+            ]++testPutWithSimple =+    it "PUT with static data" $ do+        let url = S.concat ["http://", localhost, "/resource/y98"]++        x' <- put url "text/plain" (simpleBody b') simpleHandler++        assertEqual+            "Object was encoded to JSON as expected"+            "Hello"+            x'+  where+    b' :: ByteString+    b' = S.pack "Hello"++testPutWithJson =+    it "PUT with json data" $ do+        let url = S.concat ["http://", localhost, "/resource/y99"]++        x' <- put url "application/json" (jsonBody obj) simpleHandler++        assertEqual+            "Object was encoded to JSON as expected"+            "{\"data\":[[2000,1],[2020,0]],\"label\":\"Sealand\"}"+            x'+  where+    obj :: GrossDomesticProduct+    obj =+        GrossDomesticProduct+            { gLabel = "Sealand"+            , gData = [(2000, 1), (2020, 0)]+            }++    obj' :: ByteString+    obj' = L.toStrict (encode obj)++testMultipartUpload =+    it "PUT with json data" $ do+        let url = S.concat ["http://", localhost, "/postbox"]++        let boundary = packBoundary "bEacHV0113YB@ll"++        let q = buildRequest1 $ do+                http POST "/postbox"+                setContentMultipart boundary++        let parts =+                [ simplePart "first" Nothing "Old guys in the box."+                , filePart "second" (Just "text/plain") "tests/hello.txt"+                ]++        c <- openConnection "localhost" localPort++        sendRequest c q (multipartFormBody boundary parts)++        result <- receiveResponse c simpleHandler++        closeConnection c++        expected <- S.readFile "tests/multipart.bin"+        assertEqual+            "Multipart form data was not encoded as expected"+            expected+            result
+ tests/check.hs view
@@ -0,0 +1,25 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+--+-- The code in this file, and the program it is a part of, is made+-- available to you by its authors as open source software: you can+-- redistribute it and/or modify it under a BSD licence.+--++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-unused-imports #-}++module Main where++import OpenSSL (withOpenSSL)+import Test.Hspec (hspec)++import MockServer (runMockServer)+import TestSuite (suite)++main :: IO ()+main = withOpenSSL $ do+    runMockServer+    hspec suite
+ tests/data-eu-gdp.json view
@@ -0,0 +1,4 @@+{+    "label": "Europe (EU27)",+    "data": [[1999, 3.0], [2000, 3.9], [2001, 2.0], [2002, 1.2], [2003, 1.3], [2004, 2.5], [2005, 2.0], [2006, 3.1], [2007, 2.9], [2008, 0.9]]+}
+ tests/data-jp-gdp.json view
@@ -0,0 +1,4 @@+{+    "label": "Japan",+    "data": [[1999, -0.1], [2000, 2.9], [2001, 0.2], [2002, 0.3], [2003, 1.4], [2004, 2.7], [2005, 1.9], [2006, 2.0], [2007, 2.3], [2008, -0.7]]+}
+ tests/data-us-gdp.json view
@@ -0,0 +1,4 @@+{+    "label": "USA",+    "data": [[1999, 4.4], [2000, 3.7], [2001, 0.8], [2002, 1.6], [2003, 2.5], [2004, 3.6], [2005, 2.9], [2006, 2.8], [2007, 2.0], [2008, 1.1]]+}
+ tests/example1.txt view
@@ -0,0 +1,6 @@+HTTP/1.1 200 OK
+Content-Type: text/plain
+Content-Length: 10
+
+Hi there.+
+ tests/example2.txt view
@@ -0,0 +1,17 @@+HTTP/1.1 200 OK
+Content-Type: text/html; charset=UTF-8
+Server: Apache/2.2.22
+Expires: Fri, 04 Jan 2013 06:48:57 GMT
+Date: Fri, 04 Jan 2013 06:48:56 GMT
+Content-Length: 133
+Cache-Control: max-age=1
+
+<html>+<head>+<title>Hello</title>+</head>+<body>+<h1>Hello!</h1>+<p>Hello world. <span class="FIXME">□</span></p>+</body>+</html>
+ tests/example3.txt view

binary file changed (absent → 4675 bytes)

+ tests/example4.txt view
@@ -0,0 +1,6 @@+HTTP/1.1 200 OK
+Content-Type: text/plain
+Content-Length: 86     
+
+This is an HTTP response with a header that has trailing whitespace. Bad+server, Bad!
+ tests/example5.txt view
@@ -0,0 +1,3 @@+HTTP/1.1 204 No Content
+Server: Ye Plain Olde Text File
+
+ tests/hello.html view
@@ -0,0 +1,9 @@+<html>+<head>+<title>Hello</title>+</head>+<body>+<h1>Hello!</h1>+<p>Hello world.</p>+</body>+</html>
+ tests/hello.txt view
@@ -0,0 +1,1 @@+Hello World
+ 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--
+ tests/statler.jpg view

binary file changed (absent → 4611 bytes)