http-io-streams (empty) → 0.1.0.0
raw patch · 12 files changed
+2902/−0 lines, 12 filesdep +HsOpenSSLdep +attoparsecdep +basesetup-changed
Dependencies added: HsOpenSSL, attoparsec, base, base64-bytestring, blaze-builder, bytestring, case-insensitive, containers, directory, io-streams, mtl, network, network-uri, openssl-streams, text, transformers
Files
- CHANGELOG.md +4/−0
- LICENCE +32/−0
- Setup.hs +2/−0
- http-common/lib/Network/Http/Internal.hs +459/−0
- http-common/lib/Network/Http/RequestBuilder.hs +321/−0
- http-common/lib/Network/Http/Types.hs +70/−0
- http-io-streams.cabal +85/−0
- http-streams/lib/Network/Http/Client.hs +180/−0
- http-streams/lib/Network/Http/Connection.hs +643/−0
- http-streams/lib/Network/Http/Inconvenience.hs +558/−0
- http-streams/lib/Network/Http/ResponseParser.hs +277/−0
- http-streams/lib/Network/Http/Utilities.hs +271/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+## 0.1.0.0++* First version. Released on an unsuspecting world.+* Derived from `http-streams-core-0.8.6.1` & `http-common-0.8.2.0`
+ LICENCE view
@@ -0,0 +1,32 @@+An HTTP client for use with io-streams++Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd and Others+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.+ + 3. Neither the name of the project nor the names of its contributors+ may be used to endorse or promote products derived from this + software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ http-common/lib/Network/Http/Internal.hs view
@@ -0,0 +1,459 @@+--+-- HTTP types for use with io-streams and pipes+--+-- 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 the terms of+-- the BSD licence.+--++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide, prune #-}++--+-- | If you're not http-streams or pipes-http and you're importing this,+-- you're Doing It Wrong.+--++module Network.Http.Internal (+ Hostname,+ Port,+ Request(..),+ EntityBody(..),+ ExpectMode(..),+ Response(..),+ StatusCode,+ TransferEncoding(..),+ ContentEncoding(..),+ getStatusCode,+ getStatusMessage,+ getHeader,+ Method(..),+ Headers,+ emptyHeaders,+ updateHeader,+ removeHeader,+ buildHeaders,+ lookupHeader,+ retrieveHeaders,+ HttpType (getHeaders),+ 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, toList)+import qualified Data.Map.Strict as Map+import Data.Map (Map)++import Data.Int (Int64)+import Data.List (foldl')+import Data.Monoid (mconcat, mempty)+import Data.Typeable (Typeable)+import Data.Word (Word16)++{-+ 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++--+-- | 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 actual @Host:@ header is not set until the request is sent,+-- 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+ } deriving (Eq)++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 deriving (Show, Eq, Ord)++data ExpectMode = Normal | Continue deriving (Show, Eq, Ord)++{-+ 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 = case qPath q of+ "" -> Builder.fromChar '/'+ path -> Builder.copyByteString path++ 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 client library when+-- it 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++--+-- | Accessors common to both the outbound and return sides of an HTTP+-- connection.+--+class HttpType τ where++ --+ -- | Get the Headers from a Request or Response. Most people do not need+ -- this; for most cases you just need to get a header or two from the+ -- response, for which you can use 'getHeader'. On the other hand, if you+ -- do need to poke around in the raw headers,+ --+ -- @ import Network.Http.Types @+ --+ -- will give you functions like 'lookupHeader' and 'updateHeader' to to+ -- work with.+ --+ getHeaders :: τ -> Headers++instance HttpType Request where+ getHeaders q = qHeaders q++instance HttpType Response where+ getHeaders p = 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 :: Map (CI ByteString) ByteString+} deriving (Eq)++instance Show Headers where+ show x = S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ joinHeaders $ unWrap x++joinHeaders :: Map (CI ByteString) ByteString -> Builder+joinHeaders m = Map.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 Map.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 = Map.insert (mk k) v m+ !m = unWrap x++--+-- | Remove a header from the map. If a field with that name is not present,+-- then this will have no effect.+--+removeHeader :: Headers -> ByteString -> Headers+removeHeader x k =+ Wrap result+ where+ !result = Map.delete (mk k) m+ !m = unWrap x+++--+-- | Given a list of field-name,field-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 Map.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+ :: Map (CI ByteString) ByteString+ -> (ByteString,ByteString)+ -> Map (CI ByteString) ByteString+addHeader m (k,v) =+ Map.insertWith f (mk k) v m+ where+ f new old = S.concat [old, ",", new]+++lookupHeader :: Headers -> ByteString -> Maybe ByteString+lookupHeader x k =+ Map.lookup (mk k) m+ where+ !m = unWrap x+++--+-- | Get the headers as a field-name,field-value association list.+--+retrieveHeaders :: Headers -> [(ByteString, ByteString)]+retrieveHeaders x =+ map down $ Map.toList m+ where+ !m = unWrap x++down :: (CI ByteString, ByteString) -> (ByteString, ByteString)+down (k, v) =+ (original k, v)++data HttpParseException = HttpParseException String+ deriving (Typeable, Show)++instance Exception HttpParseException
+ http-common/lib/Network/Http/RequestBuilder.hs view
@@ -0,0 +1,321 @@+--+-- HTTP types for use with io-streams and pipes+--+-- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd 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 GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}++module Network.Http.RequestBuilder (+ RequestBuilder,+ buildRequest,+ buildRequest1,+ http,+ setHostname,+ setAccept,+ setAccept',+ setAuthorizationBasic,+ ContentType,+ setContentType,+ setContentLength,+ setExpectContinue,+ setTransferEncoding,+ 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.Applicative as App+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.Internal++--+-- | The RequestBuilder monad allows you to abuse do-notation to+-- conveniently setup a 'Request' object.+--+newtype RequestBuilder α = RequestBuilder (State Request α)+ deriving (Functor, App.Applicative, Monad, MonadState Request)++--+-- | Run a RequestBuilder, yielding a Request object you can use on the+-- given connection.+--+-- > let q = buildRequest1 $ 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.+--+buildRequest1 :: RequestBuilder α -> Request+buildRequest1 mm = do+ let (RequestBuilder s) = (mm)+ let q = Request {+ qHost = Nothing,+ qMethod = GET,+ qPath = "/",+ qBody = Empty,+ qExpect = Normal,+ qHeaders = emptyHeaders+ }+ execState s q++--+-- | Run a RequestBuilder from within a monadic action.+--+-- Older versions of this library had 'buildRequest' in IO; there's+-- no longer a need for that, but this code path will continue to+-- work for existing users.+--+-- > q <- buildRequest $ do+-- > http GET "/"+--+buildRequest :: Monad ν => RequestBuilder α -> ν Request+buildRequest = return . buildRequest1+{-# INLINE buildRequest #-}++--+-- | Begin constructing a Request, starting with the request line.+--+http :: Method -> ByteString -> RequestBuilder ()+http m p' = do+ q <- get+ let h1 = qHeaders q+ let h2 = updateHeader h1 "Accept-Encoding" "gzip"++ let e = case m of+ PUT -> Chunking+ POST -> Chunking+ _ -> Empty++ let h3 = case e of+ Chunking -> updateHeader h2 "Transfer-Encoding" "chunked"+ _ -> h2++ put q {+ qMethod = m,+ qPath = p',+ qBody = e,+ qHeaders = h3+ }++--+-- | Set the [virtual] hostname for the request. In ordinary conditions+-- you won't need to call this, as the @Host:@ header is a required+-- header in HTTP 1.1 and is set directly from the name of the server+-- you connected to when calling 'Network.Http.Connection.openConnection'.+--+setHostname :: 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++--+-- | Override the default setting about how the entity body will be sent.+--+-- This function is special: this explicitly sets the @Transfer-Encoding:@+-- header to @chunked@ and will instruct the library to actually tranfer the+-- body as a stream ("chunked transfer encoding"). See 'setContentLength' for+-- forcing the opposite. You /really/ won't need this in normal operation, but+-- some people are control freaks.+--+setTransferEncoding :: RequestBuilder ()+setTransferEncoding = do+ deleteHeader "Content-Length"+ setEntityBody Chunking+ setHeader "Transfer-Encoding" "chunked"+++--+-- | 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+
+ http-common/lib/Network/Http/Types.hs view
@@ -0,0 +1,70 @@+--+-- HTTP types for use with io-streams and pipes+--+-- 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 the terms of+-- the BSD licence.+--++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK not-home #-}++--+-- | Basic types used in HTTP communications. This modules is re-exported by+-- both "Network.Http.Client" and "Pipes.Http.Client", so if you're using+-- either of those you don't need to explicitly import this module.+--++module Network.Http.Types (+ -- * Requests+ Hostname,+ Port,+ Request,+ EntityBody(..),+ ExpectMode(..),++ RequestBuilder,+ buildRequest,+ buildRequest1,+ http,+ setHostname,+ setAccept,+ setAccept',+ setAuthorizationBasic,+ ContentType,+ setContentType,+ setContentLength,+ setExpectContinue,+ setTransferEncoding,+ setHeader,++ -- * Responses+ Response,+ StatusCode,+ TransferEncoding(..),+ ContentEncoding(..),+ getStatusCode,+ getStatusMessage,+ getHeader,+ Method(..),++ -- * Headers+ Headers,+ emptyHeaders,+ updateHeader,+ removeHeader,+ buildHeaders,+ lookupHeader,+ retrieveHeaders,+ HttpType (getHeaders),++ -- * Exceptions+ HttpParseException(..)++) where++import Network.Http.Internal+import Network.Http.RequestBuilder
+ http-io-streams.cabal view
@@ -0,0 +1,85 @@+cabal-version: 2.2+name: http-io-streams+version: 0.1.0.0++synopsis: HTTP client based on io-streams+description:+ An HTTP client, using the Snap Framework's [io-streams](https://hackage.haskell.org/package/io-streams) library to+ handle the streaming IO. The @http-io-streams@ API designed for ease of use when querying web services and dealing with the result as streaming I/O.+ .+ The library is exported in a single module; see "Network.Http.Client"+ for full documentation.+ .+ __NOTE__: This is a fork of [http-streams](http://hackage.haskell.org/package/http-streams)+ with a lighter dependency footprint which focuses on core HTTP+ functionality and as a consequence doesn't include out-of-the-box+ support for handling JSON data. If you need support for handling JSON+ web-services, you should use the original @http-streams@ package instead of+ this package.++license: BSD-3-Clause+license-file: LICENCE+author: Andrew Cowie <andrew@operationaldynamics.com>+maintainer: Herbert Valerio Riedel <hvr@gnu.org>+copyright: © 2012-2018 Operational Dynamics Consulting, Pty Ltd and Others+category: Web, IO-Streams+bug-reports: https://github.com/hvr/http-io-streams/issues+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/hvr/http-io-streams.git++common settings+ build-depends:+ , base >= 4.5 && < 4.13+ , blaze-builder ^>= 0.4.1.0+ , bytestring ^>= 0.10.0.0+ , case-insensitive ^>= 1.2.0.11+ , containers ^>= 0.5.0.0 || ^>= 0.6.0.1++ default-language: Haskell2010++ ghc-options:+ -Wall+ -fno-warn-missing-signatures+ -fno-warn-unused-binds+ -fno-warn-unused-do-bind+ -funbox-strict-fields++library+ import: settings++ -- http-streams++ build-depends:+ , HsOpenSSL ^>= 0.11.2+ , attoparsec ^>= 0.13.2.2+ , directory ^>= 1.2.0.1 || ^>= 1.3.0.0+ , io-streams ^>= 1.5.0.1+ , network ^>= 2.6.0.0 || ^>= 2.7.0.0+ , network-uri ^>= 2.6.0.0+ , openssl-streams ^>= 1.2.1.3+ , text ^>= 1.2.3.0+ , transformers ^>= 0.3.0.0 || ^>= 0.4.2.0 || ^>= 0.5.2.0++ hs-source-dirs: http-streams/lib+ exposed-modules:+ Network.Http.Client+ other-modules:+ Network.Http.Connection+ Network.Http.ResponseParser+ Network.Http.Utilities+ Network.Http.Inconvenience++ -- http-common++ build-depends:+ , base64-bytestring ^>= 1.0.0.1+ , mtl ^>= 2.2.2++ hs-source-dirs: http-common/lib+ other-modules:+ Network.Http.Types+ Network.Http.RequestBuilder,+ Network.Http.Internal
+ http-streams/lib/Network/Http/Client.hs view
@@ -0,0 +1,180 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2018 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.+--++-- |+--+-- == Overview+--+-- A simple HTTP client library, using the Snap Framework's @io-streams@+-- library to handle the streaming I\/O. The @http-io-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-io-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,+ setExpectContinue,+ setTransferEncoding,+ setHeader,++ -- * Sending HTTP request+ Request,+ Response,+ getHostname,+ sendRequest,+ emptyBody,+ fileBody,+ inputStreamBody,+ encodedFormBody,++ -- * Processing HTTP response+ receiveResponse,+ receiveResponseRaw,+ UnexpectedCompression,+ StatusCode,+ getStatusCode,+ getStatusMessage,+ getHeader,+ debugHandler,+ concatHandler,+ concatHandler',+ HttpClientError(..),++ -- * 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,++ -- -- * Deprecated+ -- getRequestHeaders+) where++import Network.Http.Types+import Network.Http.Connection+import Network.Http.Inconvenience
+ http-streams/lib/Network/Http/Connection.hs view
@@ -0,0 +1,643 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2018 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 #-}+{-# 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,+ UnexpectedCompression,+ 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 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)+import qualified Data.Monoid as Mon++import Network.Http.Internal+import Network.Http.ResponseParser++--+-- | A connection to a web server.+--+data Connection+ = Connection {+ cHost :: ByteString,+ -- ^ will be used as the Host: header in the HTTP request.+ cClose :: IO (),+ -- ^ called when the connection should be closed.+ cOut :: OutputStream Builder,+ cIn :: InputStream ByteString+ }++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+-- > 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_ADDRCONFIG, 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+++--+-- | 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+-- >+-- > 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-io-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 Mon.mappend Mon.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
+ http-streams/lib/Network/Http/Inconvenience.hs view
@@ -0,0 +1,558 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2018 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_HADDOCK hide, not-home #-}++module Network.Http.Inconvenience (+ URL,+ modifyContextSSL,+ establishConnection,+ get,+ post,+ postForm,+ encodedFormBody,+ put,+ baselineContextSSL,+ concatHandler',+ TooManyRedirects(..),+ HttpClientError(..),++ -- for testing+ splitURI+) 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.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.Set (Set)+import qualified Data.Set as Set+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 (..), isAbsoluteURI,+ parseRelativeReference, parseURI, uriToString)+import OpenSSL (withOpenSSL)+import OpenSSL.Session (SSLContext)+import qualified OpenSSL.Session as SSL+import System.IO.Streams (InputStream, OutputStream)+import qualified System.IO.Streams as Streams+import System.IO.Unsafe (unsafePerformIO)++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid (..), mappend)+#endif++import Network.Http.Connection+import Network.Http.RequestBuilder+import Network.Http.Types++-- (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 Set.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 :: Set Char+urlEncodeTable = Set.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-io-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 = 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.+--+-- Throws 'TooManyRedirects' if more than 5 redirects are thrown.+--+get :: URL+ -- ^ Resource to GET from.+ -> (Response -> InputStream ByteString -> IO β)+ -- ^ Handler function to receive the response from the server.+ -> IO β+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 (path 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 :: 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'++ q = buildRequest1 $ do+ http POST (path 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+ :: 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'++ q = buildRequest1 $ do+ http POST (path 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']+++--+-- | 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'++ q = buildRequest1 $ do+ http PUT (path 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@.+--+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.+-}
+ http-streams/lib/Network/Http/ResponseParser.hs view
@@ -0,0 +1,277 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2018 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 #-}+{-# 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+import Control.Applicative as App++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 (StatusCode,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 -> App.pure 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
+ http-streams/lib/Network/Http/Utilities.hs view
@@ -0,0 +1,271 @@+--+-- HTTP client for use with io-streams+--+-- Copyright © 2012-2018 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 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 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 #-}