diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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` diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,32 @@ +An HTTP client for use with io-streams + +Copyright © 2012-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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/http-common/lib/Network/Http/Internal.hs b/http-common/lib/Network/Http/Internal.hs new file mode 100644 --- /dev/null +++ b/http-common/lib/Network/Http/Internal.hs @@ -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 "" + + +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 diff --git a/http-common/lib/Network/Http/RequestBuilder.hs b/http-common/lib/Network/Http/RequestBuilder.hs new file mode 100644 --- /dev/null +++ b/http-common/lib/Network/Http/RequestBuilder.hs @@ -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 + diff --git a/http-common/lib/Network/Http/Types.hs b/http-common/lib/Network/Http/Types.hs new file mode 100644 --- /dev/null +++ b/http-common/lib/Network/Http/Types.hs @@ -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 diff --git a/http-io-streams.cabal b/http-io-streams.cabal new file mode 100644 --- /dev/null +++ b/http-io-streams.cabal @@ -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 +maintainer: Herbert Valerio Riedel +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 diff --git a/http-streams/lib/Network/Http/Client.hs b/http-streams/lib/Network/Http/Client.hs new file mode 100644 --- /dev/null +++ b/http-streams/lib/Network/Http/Client.hs @@ -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 diff --git a/http-streams/lib/Network/Http/Connection.hs b/http-streams/lib/Network/Http/Connection.hs new file mode 100644 --- /dev/null +++ b/http-streams/lib/Network/Http/Connection.hs @@ -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 diff --git a/http-streams/lib/Network/Http/Inconvenience.hs b/http-streams/lib/Network/Http/Inconvenience.hs new file mode 100644 --- /dev/null +++ b/http-streams/lib/Network/Http/Inconvenience.hs @@ -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 +-- ) +-- +urlEncode :: ByteString -> URL +urlEncode = Builder.toByteString . urlEncodeBuilder +{-# INLINE urlEncode #-} + + +-- +-- | URL-escapes a string (see +-- ) into a 'Builder'. +-- +urlEncodeBuilder :: ByteString -> Builder +urlEncodeBuilder = go mempty + where + go !b !s = maybe b' esc (S.uncons y) + where + (x,y) = S.span (flip 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. +-} diff --git a/http-streams/lib/Network/Http/ResponseParser.hs b/http-streams/lib/Network/Http/ResponseParser.hs new file mode 100644 --- /dev/null +++ b/http-streams/lib/Network/Http/ResponseParser.hs @@ -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 diff --git a/http-streams/lib/Network/Http/Utilities.hs b/http-streams/lib/Network/Http/Utilities.hs new file mode 100644 --- /dev/null +++ b/http-streams/lib/Network/Http/Utilities.hs @@ -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 #-}