diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,6 +1,6 @@ An HTTP client for use with io-streams -Copyright © 2012 Operational Dynamics Consulting, Pty Ltd +Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd and Others All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/http-streams.cabal b/http-streams.cabal --- a/http-streams.cabal +++ b/http-streams.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: http-streams -version: 0.7.2.0 +version: 0.7.2.2 synopsis: An HTTP client using io-streams description: /Overview/ @@ -17,9 +17,9 @@ license-file: LICENCE author: Andrew Cowie maintainer: Andrew Cowie -copyright: © 2012-2013 Operational Dynamics Consulting, Pty Ltd and Others +copyright: © 2012-2014 Operational Dynamics Consulting, Pty Ltd and Others category: Web -tested-with: GHC == 7.6 +tested-with: GHC == 7.8 stability: experimental homepage: http://research.operationaldynamics.com/projects/http-streams/ bug-reports: https://github.com/afcowie/http-streams/issues @@ -30,7 +30,7 @@ default-language: Haskell2010 build-depends: attoparsec, - http-common >= 0.7.1, + http-common >= 0.7.2, base >= 4 && <5, directory, base64-bytestring, @@ -47,7 +47,7 @@ unordered-containers, aeson - hs-source-dirs: src + hs-source-dirs: lib exposed-modules: Network.Http.Client other-modules: Network.Http.Connection, Network.Http.ResponseParser, @@ -100,9 +100,10 @@ system-filepath >= 0.4.1 && < 0.5, text, unordered-containers, - aeson + aeson, + http-streams - hs-source-dirs: src,tests + hs-source-dirs: lib,tests main-is: check.hs ghc-options: -O2 diff --git a/lib/Network/Http/Client.hs b/lib/Network/Http/Client.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Client.hs @@ -0,0 +1,185 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd +-- +-- The code in this file, and the program it is a part of, is +-- made available to you by its authors as open source software: +-- you can redistribute it and/or modify it under the terms of +-- the BSD licence. +-- + +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-orphans #-} + +-- | +-- Maintainer: Andrew Cowie +-- Stability: Experimental +-- +-- /Overview/ +-- +-- A simple HTTP client library, using the Snap Framework's @io-streams@ +-- library to handle the streaming I\/O. The @http-streams@ API is designed +-- for ease of use when querying web services and dealing with the result. +-- +-- Given: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import System.IO.Streams (InputStream, OutputStream, stdout) +-- > import qualified System.IO.Streams as Streams +-- > import qualified Data.ByteString as S +-- +-- and this library: +-- +-- > import Network.Http.Client +-- +-- the underlying API is straight-forward. In particular, constructing the +-- 'Request' to send is quick and to the point: +-- +-- @ +-- main :: IO () +-- main = do +-- \ c <- 'openConnection' \"www.example.com\" 80 +-- +-- \ q <- 'buildRequest' $ do +-- 'http' GET \"\/\" +-- 'setAccept' \"text/html\" +-- +-- \ 'sendRequest' c q 'emptyBody' +-- +-- \ `receiveResponse` c (\\p i -> do +-- xm <- Streams.read i +-- case xm of +-- Just x -> S.putStr x +-- Nothing -> \"\") +-- +-- \ 'closeConnection' c +-- @ +-- +-- which would print the first chunk of the response back from the +-- server. Obviously in real usage you'll do something more interesting +-- with the 'Response' in the handler function, and consume the entire +-- response body from the InputStream ByteString. +-- +-- Because this is all happening in 'IO' (the defining feature of +-- @io-streams@!), you can ensure resource cleanup on normal or +-- abnormal termination by using @Control.Exception@'s standard +-- 'Control.Exception.bracket' function; see 'closeConnection' for an +-- example. For the common case we have a utility function which +-- wraps @bracket@ for you: +-- +-- @ +-- foo :: IO ByteString +-- foo = 'withConnection' ('openConnection' \"www.example.com\" 80) doStuff +-- +-- \ doStuff :: Connection -> IO ByteString +-- @ +-- +-- There are also a set of convenience APIs that do just that, along with +-- the tedious bits like parsing URLs. For example, to do an HTTP GET and +-- stream the response body to stdout, you can simply do: +-- +-- @ +-- 'get' \"http:\/\/www.example.com\/file.txt\" (\\p i -> Streams.connect i stdout) +-- @ +-- +-- which on the one hand is \"easy\" while on the other exposes the the +-- 'Response' and InputStream for you to read from. Of course, messing +-- around with URLs is all a bit inefficient, so if you already have e.g. +-- hostname and path, or if you need more control over the request being +-- created, then the underlying @http-streams@ API is simple enough to use +-- directly. +-- +module Network.Http.Client ( + -- * Connecting to server + Hostname, + Port, + Connection, + openConnection, + + -- * Building Requests + -- | You setup a request using the RequestBuilder monad, and + -- get the resultant Request object by running 'buildRequest'. The + -- first call doesn't have to be to 'http', but it looks better when + -- it is, don't you think? + Method(..), + RequestBuilder, + buildRequest, + http, + setHostname, + setAccept, + setAccept', + setAuthorizationBasic, + ContentType, + setContentType, + setContentLength, + setExpectContinue, + 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(..), + jsonHandler, + + -- * Resource cleanup + closeConnection, + withConnection, + + -- * Convenience APIs + -- | Some simple functions for making requests with useful defaults. + -- There's no @head@ function for the usual reason of needing to + -- avoid collision with @Prelude@. + -- + -- These convenience functions work with @http@ and @https@, but + -- note that if you retrieve an @https@ URL, you /must/ wrap your + -- @main@ function with 'OpenSSL.withOpenSSL' to initialize the + -- native openssl library code. + -- + URL, + get, + TooManyRedirects, + post, + postForm, + put, + + -- * Secure connections + openConnectionSSL, + baselineContextSSL, + modifyContextSSL, + establishConnection, + + -- * Testing support + makeConnection, + Headers, + getHeaders, + getHeadersFull, + + -- * Deprecated + getRequestHeaders +) where + +import Network.Http.Types + +import Network.Http.Connection +import Network.Http.Inconvenience diff --git a/lib/Network/Http/Connection.hs b/lib/Network/Http/Connection.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Connection.hs @@ -0,0 +1,614 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd +-- +-- The code in this file, and the program it is a part of, is +-- made available to you by its authors as open source software: +-- you can redistribute it and/or modify it under the terms of +-- the BSD licence. +-- + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Http.Connection ( + Connection(..), + -- constructors only for testing + makeConnection, + withConnection, + openConnection, + openConnectionSSL, + 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 Data.Monoid (mappend, mempty) +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 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 +-- > q <- buildRequest $ do +-- > http GET "/bucket42/object/149" +-- > sendRequest c q emptyBody +-- > ... +-- > return "blah") +-- +-- which can make the code making an HTTP request a lot more +-- straight-forward. +-- +-- Wraps @Control.Exception@'s 'Control.Exception.bracket'. +-- +withConnection :: IO Connection -> (Connection -> IO γ) -> IO γ +withConnection mkC = + bracket mkC closeConnection + + +-- +-- | In order to make a request you first establish the TCP +-- connection to the server over which to send it. +-- +-- Ordinarily you would supply the host part of the URL here and it will +-- be used as the value of the HTTP 1.1 @Host:@ field. However, you can +-- specify any server name or IP addresss and set the @Host:@ value +-- later with 'Network.Http.Client.setHostname' when building the +-- request. +-- +-- Usage is as follows: +-- +-- > c <- openConnection "localhost" 80 +-- > ... +-- > closeConnection c +-- +-- More likely, you'll use 'withConnection' to wrap the call in order +-- to ensure finalization. +-- +-- HTTP pipelining is supported; you can reuse the connection to a +-- web server, but it's up to you to ensure you match the number of +-- requests sent to the number of responses read, and to process those +-- responses in order. This is all assuming that the /server/ supports +-- pipelining; be warned that not all do. Web browsers go to +-- extraordinary lengths to probe this; you probably only want to do +-- pipelining under controlled conditions. Otherwise just open a new +-- connection for subsequent requests. +-- +openConnection :: Hostname -> Port -> IO Connection +openConnection h1' p = do + is <- getAddrInfo (Just hints) (Just h1) (Just $ show p) + let addr = head is + let a = addrAddress addr + s <- socket (addrFamily addr) Stream defaultProtocol + + connect s a + (i,o1) <- Streams.socketToStreams s + + o2 <- Streams.builderStream o1 + + return Connection { + cHost = h2', + cClose = close s, + cOut = o2, + cIn = i + } + where + hints = defaultHints { + addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV], + 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.connect ssl + + (i,o1) <- Streams.sslToStreams ssl + + o2 <- Streams.builderStream o1 + + return Connection { + cHost = h2', + cClose = closeSSL s ssl, + cOut = o2, + cIn = i + } + where + h2' :: ByteString + h2' = if p == 443 + then h1' + else S.concat [ h1', ":", S.pack $ show p ] + h1 = S.unpack h1' + +closeSSL :: Socket -> SSL -> IO () +closeSSL s ssl = do + SSL.shutdown ssl SSL.Unidirectional + close s + +-- +-- | Having composed a 'Request' object with the headers and metadata for +-- this connection, you can now send the request to the server, along +-- with the entity body, if there is one. For the rather common case of +-- HTTP requests like 'GET' that don't send data, use 'emptyBody' as the +-- output stream: +-- +-- > sendRequest c q emptyBody +-- +-- For 'PUT' and 'POST' requests, you can use 'fileBody' or +-- 'inputStreamBody' to send content to the server, or you can work with +-- the @io-streams@ API directly: +-- +-- > sendRequest c q (\o -> +-- > Streams.write (Just (Builder.fromString "Hello World\n")) o) +-- +{- + I would like to enforce the constraints on the Empty and Static + cases shown here, but those functions take OutputStream ByteString, + and we are of course working in OutputStream Builder by that point. +-} +sendRequest :: Connection -> Request -> (OutputStream Builder -> IO α) -> IO α +sendRequest c q handler = do + -- write the headers + + Streams.write (Just msg) o2 + + -- deal with the expect-continue mess + + e2 <- case t of + Normal -> do + return e + + Continue -> do + Streams.write (Just Builder.flush) o2 + + p <- readResponseHeader i + + case getStatusCode p of + 100 -> do + -- ok to send + return e + _ -> do + -- put the response back + Streams.unRead (rsp p) i + return Empty + + -- write the body, if there is one + + x <- case e2 of + Empty -> do + o3 <- Streams.nullOutput + y <- handler o3 + return y + + Chunking -> do + o3 <- Streams.contramap Builder.chunkedTransferEncoding o2 + y <- handler o3 + Streams.write (Just Builder.chunkedTransferTerminator) o2 + return y + + (Static _) -> do +-- o3 <- Streams.giveBytes (fromIntegral n :: Int64) o2 + y <- handler o2 + return y + + + -- push the stream out by flushing the output buffers + + Streams.write (Just Builder.flush) o2 + + return x + + where + o2 = cOut c + e = qBody q + t = qExpect q + msg = composeRequestBytes q h' + h' = cHost c + i = cIn c + rsp p = Builder.toByteString $ composeResponseBytes p + + +-- +-- | Get the virtual hostname that will be used as the @Host:@ header in +-- the HTTP 1.1 request. Per RFC 2616 § 14.23, this will be of the form +-- @hostname:port@ if the port number is other than the default, ie 80 +-- for HTTP. +-- +getHostname :: Connection -> Request -> ByteString +getHostname c q = + case qHost q of + Just h' -> h' + Nothing -> cHost c + + +{-# 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 +-- > +-- > q <- buildRequest $ do +-- > http GET "/time" +-- > +-- > sendRequest c q emptyBody +-- > +-- > receiveResponse c debugHandler +-- +-- would print out: +-- +-- > HTTP/1.1 200 OK +-- > Transfer-Encoding: chunked +-- > Content-Type: text/plain +-- > Vary: Accept-Encoding +-- > Server: Snap/0.9.2.4 +-- > Content-Encoding: gzip +-- > Date: Mon, 21 Jan 2013 06:13:37 GMT +-- > +-- > Mon 21 Jan 13, 06:13:37.303Z +-- +-- or thereabouts. +-- +debugHandler :: Response -> InputStream ByteString -> IO () +debugHandler p i = do + S.putStr $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p + Streams.connect i stdout + + +-- +-- | Sometimes you just want the entire response body as a single blob. +-- This function concatonates all the bytes from the response into a +-- ByteString. If using the main @http-streams@ API, you would use it +-- as follows: +-- +-- > ... +-- > x' <- receiveResponse c concatHandler +-- > ... +-- +-- The methods in the convenience API all take a function to handle the +-- response; this function is passed directly to the 'receiveResponse' +-- call underlying the request. Thus this utility function can be used +-- for 'get' as well: +-- +-- > x' <- get "http://www.example.com/document.txt" concatHandler +-- +-- Either way, the usual caveats about allocating a +-- single object from streaming I/O apply: do not use this if you are +-- not absolutely certain that the response body will fit in a +-- reasonable amount of memory. +-- +-- Note that this function makes no discrimination based on the +-- response's HTTP status code. You're almost certainly better off +-- writing your own handler function. +-- +{- + I'd welcome a better name for this function. +-} +concatHandler :: Response -> InputStream ByteString -> IO ByteString +concatHandler _ i1 = do + i2 <- Streams.map Builder.fromByteString i1 + x <- Streams.fold mappend mempty i2 + return $ Builder.toByteString x + + +-- +-- | Shutdown the connection. You need to call this release the +-- underlying socket file descriptor and related network resources. To +-- do so reliably, use this in conjunction with 'openConnection' in a +-- call to 'Control.Exception.bracket': +-- +-- > -- +-- > -- Make connection, cleaning up afterward +-- > -- +-- > +-- > foo :: IO ByteString +-- > foo = bracket +-- > (openConnection "localhost" 80) +-- > (closeConnection) +-- > (doStuff) +-- > +-- > -- +-- > -- Actually use Connection to send Request and receive Response +-- > -- +-- > +-- > doStuff :: Connection -> IO ByteString +-- +-- or, just use 'withConnection'. +-- +-- While returning a ByteString is probably the most common use case, +-- you could conceivably do more processing of the response in 'doStuff' +-- and have it and 'foo' return a different type. +-- +closeConnection :: Connection -> IO () +closeConnection c = cClose c diff --git a/lib/Network/Http/Inconvenience.hs b/lib/Network/Http/Inconvenience.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Inconvenience.hs @@ -0,0 +1,613 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd +-- +-- The code in this file, and the program it is a part of, is +-- made available to you by its authors as open source software: +-- you can redistribute it and/or modify it under the terms of +-- the BSD licence. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Network.Http.Inconvenience ( + URL, + modifyContextSSL, + establishConnection, + get, + post, + postForm, + encodedFormBody, + put, + baselineContextSSL, + concatHandler', + jsonHandler, + TooManyRedirects(..), + HttpClientError(..), + + -- for testing + splitURI +) where + +#include "config.h" + +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as Builder (fromByteString, + fromWord8, toByteString) +import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString) +import Control.Exception (Exception, bracket, throw) +import Data.Aeson (FromJSON, Result (..), fromJSON, json') +import Data.Bits (Bits (..)) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Internal (c2w, w2c) +import Data.Char (intToDigit) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (intersperse) +import Data.Monoid (Monoid (..), mappend) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Typeable (Typeable) +import Data.Word (Word16) +import GHC.Exts +import GHC.Word (Word8 (..)) +import Network.URI (URI (..), URIAuth (..), 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 qualified System.IO.Streams.Attoparsec as Streams +import System.IO.Unsafe (unsafePerformIO) + +import Network.Http.Connection +import Network.Http.RequestBuilder +import Network.Http.Types + +#if defined __LINUX__ +import System.Directory (doesDirectoryExist) +#endif + + +type URL = ByteString + +------------------------------------------------------------------------------ + +-- +-- | URL-escapes a string (see +-- ) +-- +urlEncode :: ByteString -> URL +urlEncode = Builder.toByteString . urlEncodeBuilder +{-# INLINE urlEncode #-} + + +-- +-- | URL-escapes a string (see +-- ) into a 'Builder'. +-- +urlEncodeBuilder :: ByteString -> Builder +urlEncodeBuilder = go mempty + where + go !b !s = maybe b' esc (S.uncons y) + where + (x,y) = S.span (flip HashSet.member urlEncodeTable) s + b' = b `mappend` Builder.fromByteString x + esc (c,r) = let b'' = if c == ' ' + then b' `mappend` Builder.fromWord8 (c2w '+') + else b' `mappend` hexd c + in go b'' r + + +hexd :: Char -> Builder +hexd c0 = Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi + `mappend` Builder.fromWord8 low + where + !c = c2w c0 + toDigit = c2w . intToDigit + !low = toDigit $ fromEnum $ c .&. 0xf + !hi = toDigit $ (c .&. 0xf0) `shiftr` 4 + + shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#)) + + +urlEncodeTable :: HashSet Char +urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0..255] + where + f c | c >= 'A' && c <= 'Z' = True + | c >= 'a' && c <= 'z' = True + | c >= '0' && c <= '9' = True + f c = c `elem` "$-_.!~*'()," + + +------------------------------------------------------------------------------ + +{- + The default SSLContext used by the convenience APIs in the http-streams + library. This is a kludge, unsafe bad yada yada. The technique, however, + was described on a Haskell Wiki page, so that makes it an officially + supported kludge. The justification for doing this is a) the functions + accessing this IORef are themselves all in the IO monad, and b) these + contortions are necessary to allow the library to be used for http:// URLs + *without* requiring the developer to do 'withOpenSSL'. +-} +global :: IORef SSLContext +global = unsafePerformIO $ do + ctx <- baselineContextSSL + newIORef ctx +{-# NOINLINE global #-} + +-- +-- | Modify the context being used to configure the SSL tunnel used by +-- the convenience API functions to make @https://@ connections. The +-- default is that setup by 'baselineContextSSL'. +-- +modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO () +modifyContextSSL f = do + ctx <- readIORef global + ctx' <- f ctx + writeIORef global ctx' + +-- +-- | Given a URL, work out whether it is normal or secure, and then +-- open the connection to the webserver including setting the +-- appropriate default port if one was not specified in the URL. This +-- is what powers the convenience API, but you may find it useful in +-- composing your own similar functions. +-- +-- For example (on the assumption that your server behaves when given +-- an absolute URI as the request path), this will open a connection +-- to server @www.example.com@ port @443@ and request @/photo.jpg@: +-- +-- > let url = "https://www.example.com/photo.jpg" +-- > +-- > c <- establishConnection url +-- > q <- buildRequest $ do +-- > http GET url +-- > ... +-- +establishConnection :: URL -> IO (Connection) +establishConnection r' = do + establish u + where + u = parseURL r' +{-# INLINE establishConnection #-} + +establish :: URI -> IO (Connection) +establish u = + case scheme of + "http:" -> do + openConnection host port + "https:" -> withOpenSSL $ do + ctx <- readIORef global + openConnectionSSL ctx host ports + _ -> error ("Unknown URI scheme " ++ scheme) + where + scheme = uriScheme u + + auth = case uriAuthority u of + Just x -> x + Nothing -> URIAuth "" "localhost" "" + + host = S.pack (uriRegName auth) + port = case uriPort auth of + "" -> 80 + _ -> read $ tail $ uriPort auth :: Word16 + ports = case uriPort auth of + "" -> 443 + _ -> read $ tail $ uriPort auth :: Word16 + + +-- +-- | Creates a basic SSL context. This is the SSL context used if you make an +-- @\"https:\/\/\"@ request using one of the convenience functions. It +-- configures OpenSSL to use the default set of ciphers. +-- +-- On Linux systems, this function also configures OpenSSL to verify +-- certificates using the system certificates stored in @\/etc\/ssl\/certs@. +-- +-- On other systems, /no certificate validation is performed/ by the +-- generated 'SSLContext' because there is no canonical place to find +-- the set of system certificates. When using this library on a +-- non-Linux system, you are encouraged to install the system +-- certificates somewhere and create your own 'SSLContext'. +-- +{- + We would like to turn certificate verification on for everyone, but + this has proved contingent on leveraging platform specific mechanisms + to reach the certificate store. That logic should probably be in + hsopenssl, but feel free to change this as appropriate for your OS. +-} +baselineContextSSL :: IO SSLContext +baselineContextSSL = do + ctx <- SSL.context + SSL.contextSetDefaultCiphers ctx +#if defined __MACOSX__ + SSL.contextSetVerificationMode ctx SSL.VerifyNone +#elif defined __WINDOWS__ + SSL.contextSetVerificationMode ctx SSL.VerifyNone +#else + 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' + + process c = do + q <- buildRequest $ do + http GET (path u) + setAccept "*/*" + + 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' + + process c = do + q <- buildRequest $ do + http POST (path u) + setAccept "*/*" + setContentType t + + _ <- sendRequest c q body + + x <- receiveResponse c handler + return x + + +-- +-- | Send form data to a server via an HTTP POST request. This is the +-- usual use case; most services expect the body to be MIME type +-- @application/x-www-form-urlencoded@ as this is what conventional +-- web browsers send on form submission. If you want to POST to a URL +-- with an arbitrary Content-Type, use 'post'. +-- +postForm + :: URL + -- ^ Resource to POST to. + -> [(ByteString, ByteString)] + -- ^ List of name=value pairs. Will be sent URL-encoded. + -> (Response -> InputStream ByteString -> IO β) + -- ^ Handler function to receive the response from the server. + -> IO β +postForm r' nvs handler = do + bracket + (establish u) + (teardown) + (process) + where + teardown = closeConnection + + u = parseURL r' + + process c = do + q <- buildRequest $ do + http POST (path u) + setAccept "*/*" + setContentType "application/x-www-form-urlencoded" + + _ <- sendRequest c q (encodedFormBody nvs) + + x <- receiveResponse c handler + return x + + +-- +-- | Specify name/value pairs to be sent to the server in the manner +-- used by web browsers when submitting a form via a POST request. +-- Parameters will be URL encoded per RFC 2396 and combined into a +-- single string which will be sent as the body of your request. +-- +-- You use this partially applied: +-- +-- > let nvs = [("name","Kermit"), +-- > ("type","frog")] +-- > ("role","stagehand")] +-- > +-- > sendRequest c q (encodedFormBody nvs) +-- +-- Note that it's going to be up to you to call 'setContentType' with +-- a value of @\"application/x-www-form-urlencoded\"@ when building the +-- Request object; the 'postForm' convenience (which uses this +-- @encodedFormBody@ function) takes care of this for you, obviously. +-- +encodedFormBody :: [(ByteString,ByteString)] -> OutputStream Builder -> IO () +encodedFormBody nvs o = do + Streams.write (Just b) o + where + b = mconcat $ intersperse (Builder.fromString "&") $ map combine nvs + + combine :: (ByteString,ByteString) -> Builder + combine (n',v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", urlEncodeBuilder v'] + + +-- +-- | Place content on the server at the given URL via an HTTP PUT +-- request, specifying the content type and a function to write the +-- content to the supplied 'OutputStream'. You might see: +-- +-- > put "http://s3.example.com/bucket42/object149" "text/plain" +-- > (fileBody "hello.txt") (\p i -> do +-- > putStr $ show p +-- > Streams.connect i stdout) +-- +put :: URL + -- ^ Resource to PUT to. + -> ContentType + -- ^ MIME type of the request body being sent. + -> (OutputStream Builder -> IO α) + -- ^ Handler function to write content to server. + -> (Response -> InputStream ByteString -> IO β) + -- ^ Handler function to receive the response from the server. + -> IO β +put r' t body handler = do + bracket + (establish u) + (teardown) + (process) + where + teardown = closeConnection + + u = parseURL r' + + process c = do + q <- buildRequest $ do + http PUT (path u) + setAccept "*/*" + setHeader "Content-Type" t + + _ <- sendRequest c q body + + x <- receiveResponse c handler + return x + + +-- +-- | A special case of 'concatHandler', this function will return the +-- entire response body as a single ByteString, but will throw +-- '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. +-} + +-- +-- | If you're working with a data stream that is in @application/json@, +-- then chances are you're using @aeson@ to handle the JSON to Haskell +-- decoding. If so, then this helper function might be of use. +-- +-- > v <- get "http://api.example.com/v1/" jsonHandler +-- +-- This function feeds the input body to the 'Data.Aeson.Parser.json'' +-- @attoparsec@ Parser in order to get the aeson Value type. This is then +-- marshalled to your type represeting the source data, via the FromJSON +-- typeclass. +-- +-- The above example was actually insufficient; when working with +-- @aeson@ you need to fix the type so it knows what FromJSON instance +-- to use. Let's say you're getting Person objects, then it would be +-- +-- > v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person +-- +-- assuming your Person type had a FromJSON instance, of course. +-- +-- /Note/ +-- +-- This function parses a single top level JSON object or array, which +-- is all you're supposed to get if it's a valid document. People do +-- all kinds of crazy things though, so beware. Also, this function (like the +-- "concatHander" convenience) loads the entire response into memory; it's +-- not /streaming/; if you're receiving a document which is (say) a very +-- long array of objects then you may want to implement your own +-- handler function, perhaps using "Streams.parserToInputStream" and +-- the 'Data.Aeson.Parser' combinators directly — with a result type of +-- InputStream Value, perhaps — by which you could then iterate over +-- the Values one at a time in constant space. +-- +{- + This looks simple. It wasn't. The types involved are rediculous to + disentangle. The biggest problem is that the Parser type used in + [aeson] is *NOT* the Parser type from [attoparsec]. But the parsing + function `json` and `json` from Aeson use the attoparsec Parser even + though the rest of the top level page is all about Aeson's parser as + used in FromJSON! + + Anyway, `json` and `json'` are [attoparsec] Parser [aeson] Value; we + run that using the [io-streams] convenience function + `parseFromStream` which gets us a Value which is the intermediate + abstract syntax tree for a JSON document. Then (and this was hard + to find) to work with that in terms of the FromJSON typeclass, you + use the `fromJSON` function which has type (FromJSON α => Value -> + Result α). Then finally, pull the result out of it. Why in Bog's + name this wasn't just Either I'll never know. +-} +jsonHandler + :: (FromJSON α) + => Response + -> InputStream ByteString + -> IO α +jsonHandler _ i = do + v <- Streams.parseFromStream json' i -- Value + let r = fromJSON v -- Result + case r of + (Success a) -> return a + (Error str) -> error str + diff --git a/lib/Network/Http/ResponseParser.hs b/lib/Network/Http/ResponseParser.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/ResponseParser.hs @@ -0,0 +1,276 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd +-- +-- The code in this file, and the program it is a part of, is +-- made available to you by its authors as open source software: +-- you can redistribute it and/or modify it under the terms of +-- the BSD licence. +-- +-- Significant portions of this file were written while studying +-- the HTTP request parser implementation in the Snap Framework; +-- snap-core's src/Snap/Internal/Parsing.hs and snap-server's +-- src/Snap/Internal/Http/Parser.hs, and various utility functions +-- have been cloned from there. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Http.ResponseParser ( + readResponseHeader, + readResponseBody, + UnexpectedCompression(..), + + -- for testing + readDecimal +) where + +import Prelude hiding (take, takeWhile) + +import Control.Applicative +import Control.Exception (Exception, throwIO) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Attoparsec.ByteString.Char8 +import Data.Bits (Bits (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S +import Data.CaseInsensitive (mk) +import Data.Char (ord) +import Data.Int (Int64) +import Data.Typeable (Typeable) +import System.IO.Streams (Generator, InputStream) +import qualified System.IO.Streams as Streams +import qualified System.IO.Streams.Attoparsec as Streams + +import Network.Http.Internal +import Network.Http.Utilities + +{- + The chunk size coming down from the server is somewhat arbitrary; + it's really just an indication of how many bytes need to be read + before the next size marker or end marker - neither of which has + anything to do with streaming on our side. Instead, we'll feed + bytes into our InputStream at an appropriate intermediate size. +-} +__BITE_SIZE__ :: Int +__BITE_SIZE__ = 32 * 1024 + + +{- + Process the reply from the server up to the end of the headers as + deliniated by a blank line. +-} +readResponseHeader :: InputStream ByteString -> IO Response +readResponseHeader i = do + (sc,sm) <- Streams.parseFromStream parseStatusLine i + + hs <- readHeaderFields i + + let h = buildHeaders hs + let te = case lookupHeader h "Transfer-Encoding" of + Just x' -> if mk x' == "chunked" + then Chunked + else None + Nothing -> None + + let ce = case lookupHeader h "Content-Encoding" of + Just x' -> if mk x' == "gzip" + then Gzip + else Identity + Nothing -> Identity + + let nm = case lookupHeader h "Content-Length" of + Just x' -> Just (readDecimal x' :: Int64) + Nothing -> case sc of + 204 -> Just 0 + 304 -> Just 0 + 100 -> Just 0 + _ -> Nothing + + return Response { + pStatusCode = sc, + pStatusMsg = sm, + pTransferEncoding = te, + pContentEncoding = ce, + pContentLength = nm, + pHeaders = h + } + + +parseStatusLine :: Parser (Int,ByteString) +parseStatusLine = do + sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' ' + sm <- takeTill (== '\r') <* crlf + return (sc,sm) + where + version c = c == '1' || c == '0' + + +crlf :: Parser ByteString +crlf = string "\r\n" + + +--------------------------------------------------------------------- + +{- + Switch on the encoding and compression headers, wrapping the raw + InputStream to present the entity body's actual bytes. +-} +readResponseBody :: Response -> InputStream ByteString -> IO (InputStream ByteString) +readResponseBody p i1 = do + + i2 <- case t of + None -> case l of + Just n -> readFixedLengthBody i1 n + Nothing -> readUnlimitedBody i1 + Chunked -> readChunkedBody i1 + + i3 <- case c of + Identity -> return i2 + Gzip -> readCompressedBody i2 + Deflate -> throwIO (UnexpectedCompression $ show c) + + return i3 + where + t = pTransferEncoding p + c = pContentEncoding p + l = pContentLength p + + +readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α +readDecimal str' = + S.foldl' f 0 x' + where + f !cnt !i = cnt * 10 + digitToInt i + + x' = head $ S.words str' + + {-# INLINE digitToInt #-} + digitToInt :: (Enum α, Num α, Bits α) => Char -> α + digitToInt c | c >= '0' && c <= '9' = toEnum $! ord c - ord '0' + | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit" +{-# INLINE readDecimal #-} + +data UnexpectedCompression = UnexpectedCompression String + deriving (Typeable, Show) + +instance Exception UnexpectedCompression + + +--------------------------------------------------------------------- + +{- + Process a response body in chunked transfer encoding, taking the + resultant bytes and reproducing them as an InputStream +-} +readChunkedBody :: InputStream ByteString -> IO (InputStream ByteString) +readChunkedBody i1 = do + i2 <- Streams.fromGenerator (consumeChunks i1) + return i2 + + +{- + For a response body in chunked transfer encoding, iterate over + the individual chunks, reading the size parameter, then + looping over that chunk in bites of at most __BYTE_SIZE__, + yielding them to the receiveResponse InputStream accordingly. +-} +consumeChunks :: InputStream ByteString -> Generator ByteString () +consumeChunks i1 = do + !n <- parseSize + + if n > 0 + then do + -- read one or more bites, then loop to next chunk + go n + skipCRLF + consumeChunks i1 + else do + -- skip "trailers" and consume final CRLF + skipEnd + + where + go 0 = return () + go !n = do + (!x',!r) <- liftIO $ readN n i1 + Streams.yield x' + go r + + parseSize = do + n <- liftIO $ Streams.parseFromStream transferChunkSize i1 + return n + + skipEnd = do + liftIO $ do + _ <- readHeaderFields i1 + return () + + skipCRLF = do + liftIO $ do + _ <- Streams.parseFromStream crlf i1 + return () + +{- + Read the specified number of bytes up to a maximum of __BITE_SIZE__, + returning a resultant ByteString and the number of bytes remaining. +-} + +readN :: Int -> InputStream ByteString -> IO (ByteString, Int) +readN n i1 = do + !x' <- Streams.readExactly p i1 + return (x', r) + where + !d = n - size + + !p = if d > 0 + then size + else n + + !r = if d > 0 + then d + else 0 + + size = __BITE_SIZE__ + + +transferChunkSize :: Parser (Int) +transferChunkSize = do + !n <- hexadecimal + void (takeTill (== '\r')) + void crlf + return n + + +--------------------------------------------------------------------- + +{- + This has the rather crucial side effect of terminating the stream + after the requested number of bytes. Otherwise, code handling + responses waits on more input until an HTTP timeout occurs. +-} +readFixedLengthBody :: InputStream ByteString -> Int64 -> IO (InputStream ByteString) +readFixedLengthBody i1 n = do + i2 <- Streams.takeBytes n i1 + return i2 + +{- + On the other hand, there is the (predominently HTTP/1.0) case + where there is no content length sent and no chunking, with the + result that only the connection closing marks the end of the + response body. +-} +readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString) +readUnlimitedBody i1 = do + return i1 + + +--------------------------------------------------------------------- + +readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString) +readCompressedBody i1 = do + i2 <- Streams.gunzip i1 + return i2 diff --git a/lib/Network/Http/Utilities.hs b/lib/Network/Http/Utilities.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Utilities.hs @@ -0,0 +1,272 @@ +-- +-- HTTP client for use with io-streams +-- +-- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd +-- +-- The code in this file, and the program it is a part of, is +-- made available to you by its authors as open source software: +-- you can redistribute it and/or modify it under the terms of +-- the BSD licence. +-- +-- This file is essentially a clone of Snap.Internal.Parsing, +-- the HTTP request parser implementation in the Snap Framework; +-- snap-core's src/Snap/Internal/Parsing.hs and snap-server's +-- src/Snap/Internal/Http/Parser.hs, copied here to specialize +-- it to Response parsing. This code replaces the attoparsec +-- based implementation formerly in ResponseParser, but is +-- kept separate to aid syncing changes from snap-core as they +-- become available. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} + +module Network.Http.Utilities ( + readResponseLine, + readHeaderFields +) where + +------------------------------------------------------------------------------ +import Control.Exception (throwIO) +import Control.Monad (when) +import Data.Bits +import qualified Data.ByteString.Char8 as S +import Data.ByteString.Internal (ByteString, w2c) +import qualified Data.ByteString.Unsafe as S +import Data.Char hiding (digitToInt, isDigit, isSpace) +import GHC.Exts (Int (..), Int#, (+#)) +import Prelude hiding (head, take, takeWhile) +import System.IO.Streams (InputStream) +import qualified System.IO.Streams as Streams +---------------------------------------------------------------------------- + +import Network.Http.Types + +------------------------------------------------------------------------------ + +{- + This is vestigial; originally it was the Request parsing + code in Snap. Keeping it here until we can use if for + response parsing. +-} +parseRequest :: InputStream ByteString -> IO (Maybe Request) +parseRequest input = do + eof <- Streams.atEOF input + if eof + then return Nothing + else do + line <- readResponseLine input + let (!mStr,!s) = bSp line + let (!uri, !vStr) = bSp s + let !version = pVer vStr :: (Int,Int) + +-- hdrs <- readHeaderFields input + return $! Nothing + + where + + pVer s = if "HTTP/" `S.isPrefixOf` s + then pVers (S.unsafeDrop 5 s) + else (1, 0) + + bSp = splitCh ' ' + + pVers s = (c, d) + where + (!a, !b) = splitCh '.' s + !c = unsafeFromNat a + !d = unsafeFromNat b + + +{- + Read a single line of an HTTP response. +-} +readResponseLine :: InputStream ByteString -> IO ByteString +readResponseLine input = go [] + where + throwNoCRLF = + throwIO $ + HttpParseException "parse error: expected line ending in crlf" + + throwBadCRLF = + throwIO $ + HttpParseException "parse error: got cr without subsequent lf" + + go !l = do + !mb <- Streams.read input + !s <- maybe throwNoCRLF return mb + + case findCRLF s of + FoundCRLF idx# -> foundCRLF l s idx# + NoCR -> noCRLF l s + LastIsCR idx# -> lastIsCR l s idx# + _ -> throwBadCRLF + + foundCRLF l s idx# = do + let !i1 = (I# idx#) + let !i2 = (I# (idx# +# 2#)) + let !a = S.unsafeTake i1 s + when (i2 < S.length s) $ do + let !b = S.unsafeDrop i2 s + Streams.unRead b input + + -- Optimize for the common case: dl is almost always "id" + let !out = if null l then a else S.concat (reverse (a:l)) + return out + + noCRLF l s = go (s:l) + + lastIsCR l s idx# = do + !t <- Streams.read input >>= maybe throwNoCRLF return + if S.null t + then lastIsCR l s idx# + else do + let !c = S.unsafeHead t + if c /= 10 + then throwBadCRLF + else do + let !a = S.unsafeTake (I# idx#) s + let !b = S.unsafeDrop 1 t + when (not $ S.null b) $ Streams.unRead b input + let !out = if null l then a else S.concat (reverse (a:l)) + return out + + +------------------------------------------------------------------------------ +data CS = FoundCRLF !Int# + | NoCR + | LastIsCR !Int# + | BadCR + + +------------------------------------------------------------------------------ +findCRLF :: ByteString -> CS +findCRLF b = + case S.elemIndex '\r' b of + Nothing -> NoCR + Just !i@(I# i#) -> + let !i' = i + 1 + in if i' < S.length b + then if S.unsafeIndex b i' == 10 + then FoundCRLF i# + else BadCR + else LastIsCR i# +{-# INLINE findCRLF #-} + + +------------------------------------------------------------------------------ +splitCh :: Char -> ByteString -> (ByteString, ByteString) +splitCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) + where + f !i = let !a = S.unsafeTake i s + !b = S.unsafeDrop (i + 1) s + in (a, b) +{-# INLINE splitCh #-} + + +------------------------------------------------------------------------------ +breakCh :: Char -> ByteString -> (ByteString, ByteString) +breakCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) + where + f !i = let !a = S.unsafeTake i s + !b = S.unsafeDrop i s + in (a, b) +{-# INLINE breakCh #-} + + +------------------------------------------------------------------------------ +splitHeader :: ByteString -> (ByteString, ByteString) +splitHeader !s = maybe (s, S.empty) f (S.elemIndex ':' s) + where + l = S.length s + + f i = let !a = S.unsafeTake i s + in (a, skipSp (i + 1)) + + skipSp !i | i >= l = S.empty + | otherwise = let c = S.unsafeIndex s i + in if isLWS $ w2c c + then skipSp $ i + 1 + else S.unsafeDrop i s + +{-# INLINE splitHeader #-} + + + +------------------------------------------------------------------------------ +isLWS :: Char -> Bool +isLWS c = c == ' ' || c == '\t' +{-# INLINE isLWS #-} + + +------------------------------------------------------------------------------ + +{- + Read the remainder of the response message's header section, + parsing into key/value pairs. Note that this function terminates + when it hits the "blank" line (ie, CRLF CRLF pair), which it + consumes. +-} +readHeaderFields :: InputStream ByteString -> IO [(ByteString,ByteString)] +readHeaderFields input = do + f <- go id + return $! f [] + + where + go !dlistSoFar = do + line <- readResponseLine input + if S.null line + then return dlistSoFar + else do + let (!k,!v) = splitHeader line + vf <- pCont id + let vs = vf [] + let !v' = if null vs then v else S.concat (v:vs) + let !t = (k,v') + go (dlistSoFar . (t:)) + + where + trimBegin = S.dropWhile isLWS + + pCont !dlist = do + mbS <- Streams.peek input + maybe (return dlist) + (\s -> if S.null s + then Streams.read input >> pCont dlist + else if isLWS $ w2c $ S.unsafeHead s + then procCont dlist + else return dlist) + mbS + + procCont !dlist = do + line <- readResponseLine input + let !t = trimBegin line + pCont (dlist . (" ":) . (t:)) + + + + ----------------------- + -- utility functions -- + ----------------------- + + +------------------------------------------------------------------------------ +-- | Note: only works for nonnegative naturals +unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a +unsafeFromNat = S.foldl' f 0 + where + zero = ord '0' + f !cnt !i = cnt * 10 + toEnum (digitToInt i) + + digitToInt c = if d >= 0 && d <= 9 + then d + else error $ "bad digit: '" ++ [c] ++ "'" + where + !d = ord c - zero +{-# INLINE unsafeFromNat #-} diff --git a/src/Network/Http/Client.hs b/src/Network/Http/Client.hs deleted file mode 100644 --- a/src/Network/Http/Client.hs +++ /dev/null @@ -1,185 +0,0 @@ --- --- HTTP client for use with io-streams --- --- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd --- --- The code in this file, and the program it is a part of, is --- made available to you by its authors as open source software: --- you can redistribute it and/or modify it under the terms of --- the BSD licence. --- - -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS -fno-warn-orphans #-} - --- | --- Maintainer: Andrew Cowie --- Stability: Experimental --- --- /Overview/ --- --- A simple HTTP client library, using the Snap Framework's @io-streams@ --- library to handle the streaming I\/O. The @http-streams@ API is designed --- for ease of use when querying web services and dealing with the result. --- --- Given: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import System.IO.Streams (InputStream, OutputStream, stdout) --- > import qualified System.IO.Streams as Streams --- > import qualified Data.ByteString as S --- --- and this library: --- --- > import Network.Http.Client --- --- the underlying API is straight-forward. In particular, constructing the --- 'Request' to send is quick and to the point: --- --- @ --- main :: IO () --- main = do --- \ c <- 'openConnection' \"www.example.com\" 80 --- --- \ q <- 'buildRequest' $ do --- 'http' GET \"\/\" --- 'setAccept' \"text/html\" --- --- \ 'sendRequest' c q 'emptyBody' --- --- \ `receiveResponse` c (\\p i -> do --- xm <- Streams.read i --- case xm of --- Just x -> S.putStr x --- Nothing -> \"\") --- --- \ 'closeConnection' c --- @ --- --- which would print the first chunk of the response back from the --- server. Obviously in real usage you'll do something more interesting --- with the 'Response' in the handler function, and consume the entire --- response body from the InputStream ByteString. --- --- Because this is all happening in 'IO' (the defining feature of --- @io-streams@!), you can ensure resource cleanup on normal or --- abnormal termination by using @Control.Exception@'s standard --- 'Control.Exception.bracket' function; see 'closeConnection' for an --- example. For the common case we have a utility function which --- wraps @bracket@ for you: --- --- @ --- foo :: IO ByteString --- foo = 'withConnection' ('openConnection' \"www.example.com\" 80) doStuff --- --- \ doStuff :: Connection -> IO ByteString --- @ --- --- There are also a set of convenience APIs that do just that, along with --- the tedious bits like parsing URLs. For example, to do an HTTP GET and --- stream the response body to stdout, you can simply do: --- --- @ --- 'get' \"http:\/\/www.example.com\/file.txt\" (\\p i -> Streams.connect i stdout) --- @ --- --- which on the one hand is \"easy\" while on the other exposes the the --- 'Response' and InputStream for you to read from. Of course, messing --- around with URLs is all a bit inefficient, so if you already have e.g. --- hostname and path, or if you need more control over the request being --- created, then the underlying @http-streams@ API is simple enough to use --- directly. --- -module Network.Http.Client ( - -- * Connecting to server - Hostname, - Port, - Connection, - openConnection, - - -- * Building Requests - -- | You setup a request using the RequestBuilder monad, and - -- get the resultant Request object by running 'buildRequest'. The - -- first call doesn't have to be to 'http', but it looks better when - -- it is, don't you think? - Method(..), - RequestBuilder, - buildRequest, - http, - setHostname, - setAccept, - setAccept', - setAuthorizationBasic, - ContentType, - setContentType, - setContentLength, - setExpectContinue, - 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, - jsonHandler, - - -- * Resource cleanup - closeConnection, - withConnection, - - -- * Convenience APIs - -- | Some simple functions for making requests with useful defaults. - -- There's no @head@ function for the usual reason of needing to - -- avoid collision with @Prelude@. - -- - -- These convenience functions work with @http@ and @https@, but - -- note that if you retrieve an @https@ URL, you /must/ wrap your - -- @main@ function with 'OpenSSL.withOpenSSL' to initialize the - -- native openssl library code. - -- - URL, - get, - TooManyRedirects, - post, - postForm, - put, - - -- * Secure connections - openConnectionSSL, - baselineContextSSL, - modifyContextSSL, - establishConnection, - - -- * Testing support - makeConnection, - Headers, - getHeaders, - getHeadersFull, - - -- * Deprecated - getRequestHeaders -) where - -import Network.Http.Types - -import Network.Http.Connection -import Network.Http.Inconvenience diff --git a/src/Network/Http/Connection.hs b/src/Network/Http/Connection.hs deleted file mode 100644 --- a/src/Network/Http/Connection.hs +++ /dev/null @@ -1,611 +0,0 @@ --- --- HTTP client for use with io-streams --- --- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd --- --- The code in this file, and the program it is a part of, is --- made available to you by its authors as open source software: --- you can redistribute it and/or modify it under the terms of --- the BSD licence. --- - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Http.Connection ( - Connection(..), - -- constructors only for testing - makeConnection, - withConnection, - openConnection, - openConnectionSSL, - 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 Data.Monoid (mappend, mempty) -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 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 --- > q <- buildRequest $ do --- > http GET "/bucket42/object/149" --- > sendRequest c q emptyBody --- > ... --- > return "blah") --- --- which can make the code making an HTTP request a lot more --- straight-forward. --- --- Wraps @Control.Exception@'s 'Control.Exception.bracket'. --- -withConnection :: IO Connection -> (Connection -> IO γ) -> IO γ -withConnection mkC = - bracket mkC closeConnection - - --- --- | In order to make a request you first establish the TCP --- connection to the server over which to send it. --- --- Ordinarily you would supply the host part of the URL here and it will --- be used as the value of the HTTP 1.1 @Host:@ field. However, you can --- specify any server name or IP addresss and set the @Host:@ value --- later with 'Network.Http.Client.setHostname' when building the --- request. --- --- Usage is as follows: --- --- > c <- openConnection "localhost" 80 --- > ... --- > closeConnection c --- --- More likely, you'll use 'withConnection' to wrap the call in order --- to ensure finalization. --- --- HTTP pipelining is supported; you can reuse the connection to a --- web server, but it's up to you to ensure you match the number of --- requests sent to the number of responses read, and to process those --- responses in order. This is all assuming that the /server/ supports --- pipelining; be warned that not all do. Web browsers go to --- extraordinary lengths to probe this; you probably only want to do --- pipelining under controlled conditions. Otherwise just open a new --- connection for subsequent requests. --- -openConnection :: Hostname -> Port -> IO Connection -openConnection h1' p = do - is <- getAddrInfo (Just hints) (Just h1) (Just $ show p) - let addr = head is - let a = addrAddress addr - s <- socket (addrFamily addr) Stream defaultProtocol - - connect s a - (i,o1) <- Streams.socketToStreams s - - o2 <- Streams.builderStream o1 - - return Connection { - cHost = h2', - cClose = close s, - cOut = o2, - cIn = i - } - where - hints = defaultHints {addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV]} - h2' = if p == 80 - then h1' - else S.concat [ h1', ":", S.pack $ show p ] - h1 = S.unpack h1' - --- --- | Open a secure connection to a web server. --- --- > 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.connect ssl - - (i,o1) <- Streams.sslToStreams ssl - - o2 <- Streams.builderStream o1 - - return Connection { - cHost = h2', - cClose = closeSSL s ssl, - cOut = o2, - cIn = i - } - where - h2' :: ByteString - h2' = if p == 443 - then h1' - else S.concat [ h1', ":", S.pack $ show p ] - h1 = S.unpack h1' - -closeSSL :: Socket -> SSL -> IO () -closeSSL s ssl = do - SSL.shutdown ssl SSL.Unidirectional - close s - --- --- | Having composed a 'Request' object with the headers and metadata for --- this connection, you can now send the request to the server, along --- with the entity body, if there is one. For the rather common case of --- HTTP requests like 'GET' that don't send data, use 'emptyBody' as the --- output stream: --- --- > sendRequest c q emptyBody --- --- For 'PUT' and 'POST' requests, you can use 'fileBody' or --- 'inputStreamBody' to send content to the server, or you can work with --- the @io-streams@ API directly: --- --- > sendRequest c q (\o -> --- > Streams.write (Just (Builder.fromString "Hello World\n")) o) --- -{- - I would like to enforce the constraints on the Empty and Static - cases shown here, but those functions take OutputStream ByteString, - and we are of course working in OutputStream Builder by that point. --} -sendRequest :: Connection -> Request -> (OutputStream Builder -> IO α) -> IO α -sendRequest c q handler = do - -- write the headers - - Streams.write (Just msg) o2 - - -- deal with the expect-continue mess - - e2 <- case t of - Normal -> do - return e - - Continue -> do - Streams.write (Just Builder.flush) o2 - - p <- readResponseHeader i - - case getStatusCode p of - 100 -> do - -- ok to send - return e - _ -> do - -- put the response back - Streams.unRead (rsp p) i - return Empty - - -- write the body, if there is one - - x <- case e2 of - Empty -> do - o3 <- Streams.nullOutput - y <- handler o3 - return y - - Chunking -> do - o3 <- Streams.contramap Builder.chunkedTransferEncoding o2 - y <- handler o3 - Streams.write (Just Builder.chunkedTransferTerminator) o2 - return y - - (Static _) -> do --- o3 <- Streams.giveBytes (fromIntegral n :: Int64) o2 - y <- handler o2 - return y - - - -- push the stream out by flushing the output buffers - - Streams.write (Just Builder.flush) o2 - - return x - - where - o2 = cOut c - e = qBody q - t = qExpect q - msg = composeRequestBytes q h' - h' = cHost c - i = cIn c - rsp p = Builder.toByteString $ composeResponseBytes p - - --- --- | Get the virtual hostname that will be used as the @Host:@ header in --- the HTTP 1.1 request. Per RFC 2616 § 14.23, this will be of the form --- @hostname:port@ if the port number is other than the default, ie 80 --- for HTTP. --- -getHostname :: Connection -> Request -> ByteString -getHostname c q = - case qHost q of - Just h' -> h' - Nothing -> cHost c - - -{-# 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 --- > --- > q <- buildRequest $ do --- > http GET "/time" --- > --- > sendRequest c q emptyBody --- > --- > receiveResponse c debugHandler --- --- would print out: --- --- > HTTP/1.1 200 OK --- > Transfer-Encoding: chunked --- > Content-Type: text/plain --- > Vary: Accept-Encoding --- > Server: Snap/0.9.2.4 --- > Content-Encoding: gzip --- > Date: Mon, 21 Jan 2013 06:13:37 GMT --- > --- > Mon 21 Jan 13, 06:13:37.303Z --- --- or thereabouts. --- -debugHandler :: Response -> InputStream ByteString -> IO () -debugHandler p i = do - S.putStr $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p - Streams.connect i stdout - - --- --- | Sometimes you just want the entire response body as a single blob. --- This function concatonates all the bytes from the response into a --- ByteString. If using the main @http-streams@ API, you would use it --- as follows: --- --- > ... --- > x' <- receiveResponse c concatHandler --- > ... --- --- The methods in the convenience API all take a function to handle the --- response; this function is passed directly to the 'receiveResponse' --- call underlying the request. Thus this utility function can be used --- for 'get' as well: --- --- > x' <- get "http://www.example.com/document.txt" concatHandler --- --- Either way, the usual caveats about allocating a --- single object from streaming I/O apply: do not use this if you are --- not absolutely certain that the response body will fit in a --- reasonable amount of memory. --- --- Note that this function makes no discrimination based on the --- response's HTTP status code. You're almost certainly better off --- writing your own handler function. --- -{- - I'd welcome a better name for this function. --} -concatHandler :: Response -> InputStream ByteString -> IO ByteString -concatHandler _ i1 = do - i2 <- Streams.map Builder.fromByteString i1 - x <- Streams.fold mappend mempty i2 - return $ Builder.toByteString x - - --- --- | Shutdown the connection. You need to call this release the --- underlying socket file descriptor and related network resources. To --- do so reliably, use this in conjunction with 'openConnection' in a --- call to 'Control.Exception.bracket': --- --- > -- --- > -- Make connection, cleaning up afterward --- > -- --- > --- > foo :: IO ByteString --- > foo = bracket --- > (openConnection "localhost" 80) --- > (closeConnection) --- > (doStuff) --- > --- > -- --- > -- Actually use Connection to send Request and receive Response --- > -- --- > --- > doStuff :: Connection -> IO ByteString --- --- or, just use 'withConnection'. --- --- While returning a ByteString is probably the most common use case, --- you could conceivably do more processing of the response in 'doStuff' --- and have it and 'foo' return a different type. --- -closeConnection :: Connection -> IO () -closeConnection c = cClose c diff --git a/src/Network/Http/Inconvenience.hs b/src/Network/Http/Inconvenience.hs deleted file mode 100644 --- a/src/Network/Http/Inconvenience.hs +++ /dev/null @@ -1,613 +0,0 @@ --- --- HTTP client for use with io-streams --- --- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd --- --- The code in this file, and the program it is a part of, is --- made available to you by its authors as open source software: --- you can redistribute it and/or modify it under the terms of --- the BSD licence. --- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Network.Http.Inconvenience ( - URL, - modifyContextSSL, - establishConnection, - get, - post, - postForm, - encodedFormBody, - put, - baselineContextSSL, - concatHandler', - jsonHandler, - TooManyRedirects(..), - HttpClientError(..), - - -- for testing - splitURI -) where - -#include "config.h" - -import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder as Builder (fromByteString, - fromWord8, toByteString) -import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString) -import Control.Exception (Exception, bracket, throw) -import Data.Aeson (FromJSON, Result (..), fromJSON, json') -import Data.Bits (Bits (..)) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as S -import Data.ByteString.Internal (c2w, w2c) -import Data.Char (intToDigit) -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (intersperse) -import Data.Monoid (Monoid (..), mappend) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Typeable (Typeable) -import Data.Word (Word16) -import GHC.Exts -import GHC.Word (Word8 (..)) -import Network.URI (URI (..), URIAuth (..), 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 qualified System.IO.Streams.Attoparsec as Streams -import System.IO.Unsafe (unsafePerformIO) - -import Network.Http.Connection -import Network.Http.RequestBuilder -import Network.Http.Types - -#if defined __LINUX__ -import System.Directory (doesDirectoryExist) -#endif - - -type URL = ByteString - ------------------------------------------------------------------------------- - --- --- | URL-escapes a string (see --- ) --- -urlEncode :: ByteString -> URL -urlEncode = Builder.toByteString . urlEncodeBuilder -{-# INLINE urlEncode #-} - - --- --- | URL-escapes a string (see --- ) into a 'Builder'. --- -urlEncodeBuilder :: ByteString -> Builder -urlEncodeBuilder = go mempty - where - go !b !s = maybe b' esc (S.uncons y) - where - (x,y) = S.span (flip HashSet.member urlEncodeTable) s - b' = b `mappend` Builder.fromByteString x - esc (c,r) = let b'' = if c == ' ' - then b' `mappend` Builder.fromWord8 (c2w '+') - else b' `mappend` hexd c - in go b'' r - - -hexd :: Char -> Builder -hexd c0 = Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi - `mappend` Builder.fromWord8 low - where - !c = c2w c0 - toDigit = c2w . intToDigit - !low = toDigit $ fromEnum $ c .&. 0xf - !hi = toDigit $ (c .&. 0xf0) `shiftr` 4 - - shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#)) - - -urlEncodeTable :: HashSet Char -urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0..255] - where - f c | c >= 'A' && c <= 'Z' = True - | c >= 'a' && c <= 'z' = True - | c >= '0' && c <= '9' = True - f c = c `elem` "$-_.!~*'()," - - ------------------------------------------------------------------------------- - -{- - The default SSLContext used by the convenience APIs in the http-streams - library. This is a kludge, unsafe bad yada yada. The technique, however, - was described on a Haskell Wiki page, so that makes it an officially - supported kludge. The justification for doing this is a) the functions - accessing this IORef are themselves all in the IO monad, and b) these - contortions are necessary to allow the library to be used for http:// URLs - *without* requiring the developer to do 'withOpenSSL'. --} -global :: IORef SSLContext -global = unsafePerformIO $ do - ctx <- baselineContextSSL - newIORef ctx -{-# NOINLINE global #-} - --- --- | Modify the context being used to configure the SSL tunnel used by --- the convenience API functions to make @https://@ connections. The --- default is that setup by 'baselineContextSSL'. --- -modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO () -modifyContextSSL f = do - ctx <- readIORef global - ctx' <- f ctx - writeIORef global ctx' - --- --- | Given a URL, work out whether it is normal or secure, and then --- open the connection to the webserver including setting the --- appropriate default port if one was not specified in the URL. This --- is what powers the convenience API, but you may find it useful in --- composing your own similar functions. --- --- For example (on the assumption that your server behaves when given --- an absolute URI as the request path), this will open a connection --- to server @www.example.com@ port @443@ and request @/photo.jpg@: --- --- > let url = "https://www.example.com/photo.jpg" --- > --- > c <- establishConnection url --- > q <- buildRequest $ do --- > http GET url --- > ... --- -establishConnection :: URL -> IO (Connection) -establishConnection r' = do - establish u - where - u = parseURL r' -{-# INLINE establishConnection #-} - -establish :: URI -> IO (Connection) -establish u = - case scheme of - "http:" -> do - openConnection host port - "https:" -> withOpenSSL $ do - ctx <- readIORef global - openConnectionSSL ctx host ports - _ -> error ("Unknown URI scheme " ++ scheme) - where - scheme = uriScheme u - - auth = case uriAuthority u of - Just x -> x - Nothing -> URIAuth "" "localhost" "" - - host = S.pack (uriRegName auth) - port = case uriPort auth of - "" -> 80 - _ -> read $ tail $ uriPort auth :: Word16 - ports = case uriPort auth of - "" -> 443 - _ -> read $ tail $ uriPort auth :: Word16 - - --- --- | Creates a basic SSL context. This is the SSL context used if you make an --- @\"https:\/\/\"@ request using one of the convenience functions. It --- configures OpenSSL to use the default set of ciphers. --- --- On Linux systems, this function also configures OpenSSL to verify --- certificates using the system certificates stored in @\/etc\/ssl\/certs@. --- --- On other systems, /no certificate validation is performed/ by the --- generated 'SSLContext' because there is no canonical place to find --- the set of system certificates. When using this library on a --- non-Linux system, you are encouraged to install the system --- certificates somewhere and create your own 'SSLContext'. --- -{- - We would like to turn certificate verification on for everyone, but - this has proved contingent on leveraging platform specific mechanisms - to reach the certificate store. That logic should probably be in - hsopenssl, but feel free to change this as appropriate for your OS. --} -baselineContextSSL :: IO SSLContext -baselineContextSSL = do - ctx <- SSL.context - SSL.contextSetDefaultCiphers ctx -#if defined __MACOSX__ - SSL.contextSetVerificationMode ctx SSL.VerifyNone -#elif defined __WINDOWS__ - SSL.contextSetVerificationMode ctx SSL.VerifyNone -#else - 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' - - process c = do - q <- buildRequest $ do - http GET (path u) - setAccept "*/*" - - 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' - - process c = do - q <- buildRequest $ do - http POST (path u) - setAccept "*/*" - setContentType t - - _ <- sendRequest c q body - - x <- receiveResponse c handler - return x - - --- --- | Send form data to a server via an HTTP POST request. This is the --- usual use case; most services expect the body to be MIME type --- @application/x-www-form-urlencoded@ as this is what conventional --- web browsers send on form submission. If you want to POST to a URL --- with an arbitrary Content-Type, use 'post'. --- -postForm - :: URL - -- ^ Resource to POST to. - -> [(ByteString, ByteString)] - -- ^ List of name=value pairs. Will be sent URL-encoded. - -> (Response -> InputStream ByteString -> IO β) - -- ^ Handler function to receive the response from the server. - -> IO β -postForm r' nvs handler = do - bracket - (establish u) - (teardown) - (process) - where - teardown = closeConnection - - u = parseURL r' - - process c = do - q <- buildRequest $ do - http POST (path u) - setAccept "*/*" - setContentType "application/x-www-form-urlencoded" - - _ <- sendRequest c q (encodedFormBody nvs) - - x <- receiveResponse c handler - return x - - --- --- | Specify name/value pairs to be sent to the server in the manner --- used by web browsers when submitting a form via a POST request. --- Parameters will be URL encoded per RFC 2396 and combined into a --- single string which will be sent as the body of your request. --- --- You use this partially applied: --- --- > let nvs = [("name","Kermit"), --- > ("type","frog")] --- > ("role","stagehand")] --- > --- > sendRequest c q (encodedFormBody nvs) --- --- Note that it's going to be up to you to call 'setContentType' with --- a value of @\"application/x-www-form-urlencoded\"@ when building the --- Request object; the 'postForm' convenience (which uses this --- @encodedFormBody@ function) takes care of this for you, obviously. --- -encodedFormBody :: [(ByteString,ByteString)] -> OutputStream Builder -> IO () -encodedFormBody nvs o = do - Streams.write (Just b) o - where - b = mconcat $ intersperse (Builder.fromString "&") $ map combine nvs - - combine :: (ByteString,ByteString) -> Builder - combine (n',v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", urlEncodeBuilder v'] - - --- --- | Place content on the server at the given URL via an HTTP PUT --- request, specifying the content type and a function to write the --- content to the supplied 'OutputStream'. You might see: --- --- > put "http://s3.example.com/bucket42/object149" "text/plain" --- > (fileBody "hello.txt") (\p i -> do --- > putStr $ show p --- > Streams.connect i stdout) --- -put :: URL - -- ^ Resource to PUT to. - -> ContentType - -- ^ MIME type of the request body being sent. - -> (OutputStream Builder -> IO α) - -- ^ Handler function to write content to server. - -> (Response -> InputStream ByteString -> IO β) - -- ^ Handler function to receive the response from the server. - -> IO β -put r' t body handler = do - bracket - (establish u) - (teardown) - (process) - where - teardown = closeConnection - - u = parseURL r' - - process c = do - q <- buildRequest $ do - http PUT (path u) - setAccept "*/*" - setHeader "Content-Type" t - - _ <- sendRequest c q body - - x <- receiveResponse c handler - return x - - --- --- | A special case of 'concatHandler', this function will return the --- entire response body as a single ByteString, but will throw --- '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. --} - --- --- | If you're working with a data stream that is in @application/json@, --- then chances are you're using @aeson@ to handle the JSON to Haskell --- decoding. If so, then this helper function might be of use. --- --- > v <- get "http://api.example.com/v1/" jsonHandler --- --- This function feeds the input body to the 'Data.Aeson.Parser.json'' --- @attoparsec@ Parser in order to get the aeson Value type. This is then --- marshalled to your type represeting the source data, via the FromJSON --- typeclass. --- --- The above example was actually insufficient; when working with --- @aeson@ you need to fix the type so it knows what FromJSON instance --- to use. Let's say you're getting Person objects, then it would be --- --- > v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person --- --- assuming your Person type had a FromJSON instance, of course. --- --- /Note/ --- --- This function parses a single top level JSON object or array, which --- is all you're supposed to get if it's a valid document. People do --- all kinds of crazy things though, so beware. Also, this function (like the --- "concatHander" convenience) loads the entire response into memory; it's --- not /streaming/; if you're receiving a document which is (say) a very --- long array of objects then you may want to implement your own --- handler function, perhaps using "Streams.parserToInputStream" and --- the 'Data.Aeson.Parser' combinators directly — with a result type of --- InputStream Value, perhaps — by which you could then iterate over --- the Values one at a time in constant space. --- -{- - This looks simple. It wasn't. The types involved are rediculous to - disentangle. The biggest problem is that the Parser type used in - [aeson] is *NOT* the Parser type from [attoparsec]. But the parsing - function `json` and `json` from Aeson use the attoparsec Parser even - though the rest of the top level page is all about Aeson's parser as - used in FromJSON! - - Anyway, `json` and `json'` are [attoparsec] Parser [aeson] Value; we - run that using the [io-streams] convenience function - `parseFromStream` which gets us a Value which is the intermediate - abstract syntax tree for a JSON document. Then (and this was hard - to find) to work with that in terms of the FromJSON typeclass, you - use the `fromJSON` function which has type (FromJSON α => Value -> - Result α). Then finally, pull the result out of it. Why in Bog's - name this wasn't just Either I'll never know. --} -jsonHandler - :: (FromJSON α) - => Response - -> InputStream ByteString - -> IO α -jsonHandler _ i = do - v <- Streams.parseFromStream json' i -- Value - let r = fromJSON v -- Result - case r of - (Success a) -> return a - (Error str) -> error str - diff --git a/src/Network/Http/ResponseParser.hs b/src/Network/Http/ResponseParser.hs deleted file mode 100644 --- a/src/Network/Http/ResponseParser.hs +++ /dev/null @@ -1,276 +0,0 @@ --- --- HTTP client for use with io-streams --- --- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd --- --- The code in this file, and the program it is a part of, is --- made available to you by its authors as open source software: --- you can redistribute it and/or modify it under the terms of --- the BSD licence. --- --- Significant portions of this file were written while studying --- the HTTP request parser implementation in the Snap Framework; --- snap-core's src/Snap/Internal/Parsing.hs and snap-server's --- src/Snap/Internal/Http/Parser.hs, and various utility functions --- have been cloned from there. --- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Http.ResponseParser ( - readResponseHeader, - readResponseBody, - UnexpectedCompression(..), - - -- for testing - readDecimal -) where - -import Prelude hiding (take, takeWhile) - -import Control.Applicative -import Control.Exception (Exception, throwIO) -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) -import Data.Attoparsec.ByteString.Char8 -import Data.Bits (Bits (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as S -import Data.CaseInsensitive (mk) -import Data.Char (ord) -import Data.Int (Int64) -import Data.Typeable (Typeable) -import System.IO.Streams (Generator, InputStream) -import qualified System.IO.Streams as Streams -import qualified System.IO.Streams.Attoparsec as Streams - -import Network.Http.Internal -import Network.Http.Utilities - -{- - The chunk size coming down from the server is somewhat arbitrary; - it's really just an indication of how many bytes need to be read - before the next size marker or end marker - neither of which has - anything to do with streaming on our side. Instead, we'll feed - bytes into our InputStream at an appropriate intermediate size. --} -__BITE_SIZE__ :: Int -__BITE_SIZE__ = 32 * 1024 - - -{- - Process the reply from the server up to the end of the headers as - deliniated by a blank line. --} -readResponseHeader :: InputStream ByteString -> IO Response -readResponseHeader i = do - (sc,sm) <- Streams.parseFromStream parseStatusLine i - - hs <- readHeaderFields i - - let h = buildHeaders hs - let te = case lookupHeader h "Transfer-Encoding" of - Just x' -> if mk x' == "chunked" - then Chunked - else None - Nothing -> None - - let ce = case lookupHeader h "Content-Encoding" of - Just x' -> if mk x' == "gzip" - then Gzip - else Identity - Nothing -> Identity - - let nm = case lookupHeader h "Content-Length" of - Just x' -> Just (readDecimal x' :: Int64) - Nothing -> case sc of - 204 -> Just 0 - 304 -> Just 0 - 100 -> Just 0 - _ -> Nothing - - return Response { - pStatusCode = sc, - pStatusMsg = sm, - pTransferEncoding = te, - pContentEncoding = ce, - pContentLength = nm, - pHeaders = h - } - - -parseStatusLine :: Parser (Int,ByteString) -parseStatusLine = do - sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' ' - sm <- takeTill (== '\r') <* crlf - return (sc,sm) - where - version c = c == '1' || c == '0' - - -crlf :: Parser ByteString -crlf = string "\r\n" - - ---------------------------------------------------------------------- - -{- - Switch on the encoding and compression headers, wrapping the raw - InputStream to present the entity body's actual bytes. --} -readResponseBody :: Response -> InputStream ByteString -> IO (InputStream ByteString) -readResponseBody p i1 = do - - i2 <- case t of - None -> case l of - Just n -> readFixedLengthBody i1 n - Nothing -> readUnlimitedBody i1 - Chunked -> readChunkedBody i1 - - i3 <- case c of - Identity -> return i2 - Gzip -> readCompressedBody i2 - Deflate -> throwIO (UnexpectedCompression $ show c) - - return i3 - where - t = pTransferEncoding p - c = pContentEncoding p - l = pContentLength p - - -readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α -readDecimal str' = - S.foldl' f 0 x' - where - f !cnt !i = cnt * 10 + digitToInt i - - x' = head $ S.words str' - - {-# INLINE digitToInt #-} - digitToInt :: (Enum α, Num α, Bits α) => Char -> α - digitToInt c | c >= '0' && c <= '9' = toEnum $! ord c - ord '0' - | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit" -{-# INLINE readDecimal #-} - -data UnexpectedCompression = UnexpectedCompression String - deriving (Typeable, Show) - -instance Exception UnexpectedCompression - - ---------------------------------------------------------------------- - -{- - Process a response body in chunked transfer encoding, taking the - resultant bytes and reproducing them as an InputStream --} -readChunkedBody :: InputStream ByteString -> IO (InputStream ByteString) -readChunkedBody i1 = do - i2 <- Streams.fromGenerator (consumeChunks i1) - return i2 - - -{- - For a response body in chunked transfer encoding, iterate over - the individual chunks, reading the size parameter, then - looping over that chunk in bites of at most __BYTE_SIZE__, - yielding them to the receiveResponse InputStream accordingly. --} -consumeChunks :: InputStream ByteString -> Generator ByteString () -consumeChunks i1 = do - !n <- parseSize - - if n > 0 - then do - -- read one or more bites, then loop to next chunk - go n - skipCRLF - consumeChunks i1 - else do - -- skip "trailers" and consume final CRLF - skipEnd - - where - go 0 = return () - go !n = do - (!x',!r) <- liftIO $ readN n i1 - Streams.yield x' - go r - - parseSize = do - n <- liftIO $ Streams.parseFromStream transferChunkSize i1 - return n - - skipEnd = do - liftIO $ do - _ <- readHeaderFields i1 - return () - - skipCRLF = do - liftIO $ do - _ <- Streams.parseFromStream crlf i1 - return () - -{- - Read the specified number of bytes up to a maximum of __BITE_SIZE__, - returning a resultant ByteString and the number of bytes remaining. --} - -readN :: Int -> InputStream ByteString -> IO (ByteString, Int) -readN n i1 = do - !x' <- Streams.readExactly p i1 - return (x', r) - where - !d = n - size - - !p = if d > 0 - then size - else n - - !r = if d > 0 - then d - else 0 - - size = __BITE_SIZE__ - - -transferChunkSize :: Parser (Int) -transferChunkSize = do - !n <- hexadecimal - void (takeTill (== '\r')) - void crlf - return n - - ---------------------------------------------------------------------- - -{- - This has the rather crucial side effect of terminating the stream - after the requested number of bytes. Otherwise, code handling - responses waits on more input until an HTTP timeout occurs. --} -readFixedLengthBody :: InputStream ByteString -> Int64 -> IO (InputStream ByteString) -readFixedLengthBody i1 n = do - i2 <- Streams.takeBytes n i1 - return i2 - -{- - On the other hand, there is the (predominently HTTP/1.0) case - where there is no content length sent and no chunking, with the - result that only the connection closing marks the end of the - response body. --} -readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString) -readUnlimitedBody i1 = do - return i1 - - ---------------------------------------------------------------------- - -readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString) -readCompressedBody i1 = do - i2 <- Streams.gunzip i1 - return i2 diff --git a/src/Network/Http/Utilities.hs b/src/Network/Http/Utilities.hs deleted file mode 100644 --- a/src/Network/Http/Utilities.hs +++ /dev/null @@ -1,272 +0,0 @@ --- --- HTTP client for use with io-streams --- --- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd --- --- The code in this file, and the program it is a part of, is --- made available to you by its authors as open source software: --- you can redistribute it and/or modify it under the terms of --- the BSD licence. --- --- This file is essentially a clone of Snap.Internal.Parsing, --- the HTTP request parser implementation in the Snap Framework; --- snap-core's src/Snap/Internal/Parsing.hs and snap-server's --- src/Snap/Internal/Http/Parser.hs, copied here to specialize --- it to Response parsing. This code replaces the attoparsec --- based implementation formerly in ResponseParser, but is --- kept separate to aid syncing changes from snap-core as they --- become available. --- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE UnboxedTuples #-} - -module Network.Http.Utilities ( - readResponseLine, - readHeaderFields -) where - ------------------------------------------------------------------------------- -import Control.Exception (throwIO) -import Control.Monad (when) -import Data.Bits -import qualified Data.ByteString.Char8 as S -import Data.ByteString.Internal (ByteString, w2c) -import qualified Data.ByteString.Unsafe as S -import Data.Char hiding (digitToInt, isDigit, isSpace) -import GHC.Exts (Int (..), Int#, (+#)) -import Prelude hiding (head, take, takeWhile) -import System.IO.Streams (InputStream) -import qualified System.IO.Streams as Streams ----------------------------------------------------------------------------- - -import Network.Http.Types - ------------------------------------------------------------------------------- - -{- - This is vestigial; originally it was the Request parsing - code in Snap. Keeping it here until we can use if for - response parsing. --} -parseRequest :: InputStream ByteString -> IO (Maybe Request) -parseRequest input = do - eof <- Streams.atEOF input - if eof - then return Nothing - else do - line <- readResponseLine input - let (!mStr,!s) = bSp line - let (!uri, !vStr) = bSp s - let !version = pVer vStr :: (Int,Int) - --- hdrs <- readHeaderFields input - return $! Nothing - - where - - pVer s = if "HTTP/" `S.isPrefixOf` s - then pVers (S.unsafeDrop 5 s) - else (1, 0) - - bSp = splitCh ' ' - - pVers s = (c, d) - where - (!a, !b) = splitCh '.' s - !c = unsafeFromNat a - !d = unsafeFromNat b - - -{- - Read a single line of an HTTP response. --} -readResponseLine :: InputStream ByteString -> IO ByteString -readResponseLine input = go [] - where - throwNoCRLF = - throwIO $ - HttpParseException "parse error: expected line ending in crlf" - - throwBadCRLF = - throwIO $ - HttpParseException "parse error: got cr without subsequent lf" - - go !l = do - !mb <- Streams.read input - !s <- maybe throwNoCRLF return mb - - case findCRLF s of - FoundCRLF idx# -> foundCRLF l s idx# - NoCR -> noCRLF l s - LastIsCR idx# -> lastIsCR l s idx# - _ -> throwBadCRLF - - foundCRLF l s idx# = do - let !i1 = (I# idx#) - let !i2 = (I# (idx# +# 2#)) - let !a = S.unsafeTake i1 s - when (i2 < S.length s) $ do - let !b = S.unsafeDrop i2 s - Streams.unRead b input - - -- Optimize for the common case: dl is almost always "id" - let !out = if null l then a else S.concat (reverse (a:l)) - return out - - noCRLF l s = go (s:l) - - lastIsCR l s idx# = do - !t <- Streams.read input >>= maybe throwNoCRLF return - if S.null t - then lastIsCR l s idx# - else do - let !c = S.unsafeHead t - if c /= 10 - then throwBadCRLF - else do - let !a = S.unsafeTake (I# idx#) s - let !b = S.unsafeDrop 1 t - when (not $ S.null b) $ Streams.unRead b input - let !out = if null l then a else S.concat (reverse (a:l)) - return out - - ------------------------------------------------------------------------------- -data CS = FoundCRLF !Int# - | NoCR - | LastIsCR !Int# - | BadCR - - ------------------------------------------------------------------------------- -findCRLF :: ByteString -> CS -findCRLF b = - case S.elemIndex '\r' b of - Nothing -> NoCR - Just !i@(I# i#) -> - let !i' = i + 1 - in if i' < S.length b - then if S.unsafeIndex b i' == 10 - then FoundCRLF i# - else BadCR - else LastIsCR i# -{-# INLINE findCRLF #-} - - ------------------------------------------------------------------------------- -splitCh :: Char -> ByteString -> (ByteString, ByteString) -splitCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) - where - f !i = let !a = S.unsafeTake i s - !b = S.unsafeDrop (i + 1) s - in (a, b) -{-# INLINE splitCh #-} - - ------------------------------------------------------------------------------- -breakCh :: Char -> ByteString -> (ByteString, ByteString) -breakCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) - where - f !i = let !a = S.unsafeTake i s - !b = S.unsafeDrop i s - in (a, b) -{-# INLINE breakCh #-} - - ------------------------------------------------------------------------------- -splitHeader :: ByteString -> (ByteString, ByteString) -splitHeader !s = maybe (s, S.empty) f (S.elemIndex ':' s) - where - l = S.length s - - f i = let !a = S.unsafeTake i s - in (a, skipSp (i + 1)) - - skipSp !i | i >= l = S.empty - | otherwise = let c = S.unsafeIndex s i - in if isLWS $ w2c c - then skipSp $ i + 1 - else S.unsafeDrop i s - -{-# INLINE splitHeader #-} - - - ------------------------------------------------------------------------------- -isLWS :: Char -> Bool -isLWS c = c == ' ' || c == '\t' -{-# INLINE isLWS #-} - - ------------------------------------------------------------------------------- - -{- - Read the remainder of the response message's header section, - parsing into key/value pairs. Note that this function terminates - when it hits the "blank" line (ie, CRLF CRLF pair), which it - consumes. --} -readHeaderFields :: InputStream ByteString -> IO [(ByteString,ByteString)] -readHeaderFields input = do - f <- go id - return $! f [] - - where - go !dlistSoFar = do - line <- readResponseLine input - if S.null line - then return dlistSoFar - else do - let (!k,!v) = splitHeader line - vf <- pCont id - let vs = vf [] - let !v' = if null vs then v else S.concat (v:vs) - let !t = (k,v') - go (dlistSoFar . (t:)) - - where - trimBegin = S.dropWhile isLWS - - pCont !dlist = do - mbS <- Streams.peek input - maybe (return dlist) - (\s -> if S.null s - then Streams.read input >> pCont dlist - else if isLWS $ w2c $ S.unsafeHead s - then procCont dlist - else return dlist) - mbS - - procCont !dlist = do - line <- readResponseLine input - let !t = trimBegin line - pCont (dlist . (" ":) . (t:)) - - - - ----------------------- - -- utility functions -- - ----------------------- - - ------------------------------------------------------------------------------- --- | Note: only works for nonnegative naturals -unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a -unsafeFromNat = S.foldl' f 0 - where - zero = ord '0' - f !cnt !i = cnt * 10 + toEnum (digitToInt i) - - digitToInt c = if d >= 0 && d <= 9 - then d - else error $ "bad digit: '" ++ [c] ++ "'" - where - !d = ord c - zero -{-# INLINE unsafeFromNat #-}