http-streams 0.7.2.0 → 0.7.2.2

raw patch · 12 files changed

+1969/−1965 lines, 12 filesdep ~aesondep ~http-commonPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: aeson, http-common

API changes (from Hackage documentation)

Files

• LICENCE +1/−1
• http-streams.cabal +8/−7
• lib/Network/Http/Client.hs +185/−0
• lib/Network/Http/Connection.hs +614/−0
• lib/Network/Http/Inconvenience.hs +613/−0
• lib/Network/Http/ResponseParser.hs +276/−0
• lib/Network/Http/Utilities.hs +272/−0
• src/Network/Http/Client.hs +0/−185
• src/Network/Http/Connection.hs +0/−611
• src/Network/Http/Inconvenience.hs +0/−613
• src/Network/Http/ResponseParser.hs +0/−276
• src/Network/Http/Utilities.hs +0/−272

@@ -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

@@ -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 <andrew@operationaldynamics.com> maintainer:          Andrew Cowie <andrew@operationaldynamics.com>-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

@@ -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

@@ -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

@@ -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+-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)+--+urlEncode :: ByteString -> URL+urlEncode = Builder.toByteString . urlEncodeBuilder+{-# INLINE urlEncode #-}+++--+-- | URL-escapes a string (see+-- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.+--+urlEncodeBuilder :: ByteString -> Builder+urlEncodeBuilder = go mempty+  where+    go !b !s = maybe b' esc (S.uncons y)+      where+        (x,y)     = S.span (flip HashSet.member urlEncodeTable) s+        b'        = b `mappend` Builder.fromByteString x+        esc (c,r) = let b'' = if c == ' '+                                then b' `mappend` Builder.fromWord8 (c2w '+')+                                else b' `mappend` hexd c+                    in go b'' r+++hexd :: Char -> Builder+hexd c0 = Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi+                                      `mappend` Builder.fromWord8 low+  where+    !c        = c2w c0+    toDigit   = c2w . intToDigit+    !low      = toDigit $ fromEnum $ c .&. 0xf+    !hi       = toDigit $ (c .&. 0xf0) `shiftr` 4++    shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#))+++urlEncodeTable :: HashSet Char+urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0..255]+  where+    f c | 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+

@@ -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

@@ -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 #-}

@@ -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

@@ -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

@@ -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--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)----urlEncode :: ByteString -> URL-urlEncode = Builder.toByteString . urlEncodeBuilder-{-# INLINE urlEncode #-}-------- | URL-escapes a string (see--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.----urlEncodeBuilder :: ByteString -> Builder-urlEncodeBuilder = go mempty-  where-    go !b !s = maybe b' esc (S.uncons y)-      where-        (x,y)     = S.span (flip HashSet.member urlEncodeTable) s-        b'        = b `mappend` Builder.fromByteString x-        esc (c,r) = let b'' = if c == ' '-                                then b' `mappend` Builder.fromWord8 (c2w '+')-                                else b' `mappend` hexd c-                    in go b'' r---hexd :: Char -> Builder-hexd c0 = Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi-                                      `mappend` Builder.fromWord8 low-  where-    !c        = c2w c0-    toDigit   = c2w . intToDigit-    !low      = toDigit $ fromEnum $ c .&. 0xf-    !hi       = toDigit $ (c .&. 0xf0) `shiftr` 4--    shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#))---urlEncodeTable :: HashSet Char-urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0..255]-  where-    f c | 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-

@@ -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

@@ -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 #-}