http-common 0.7.1.1 → 0.7.2.0
raw patch · 8 files changed
+837/−834 lines, 8 filesdep ~base
Dependency ranges changed: base
Files
- LICENCE +1/−1
- http-common.cabal +4/−4
- lib/Network/Http/Internal.hs +456/−0
- lib/Network/Http/RequestBuilder.hs +307/−0
- lib/Network/Http/Types.hs +69/−0
- src/Network/Http/Internal.hs +0/−454
- src/Network/Http/RequestBuilder.hs +0/−306
- src/Network/Http/Types.hs +0/−69
LICENCE view
@@ -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
http-common.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: http-common-version: 0.7.1.1+version: 0.7.2.0 synopsis: Common types for HTTP clients and servers description: /Overview/@@ -14,9 +14,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-common/issues@@ -38,7 +38,7 @@ text, unordered-containers - hs-source-dirs: src+ hs-source-dirs: lib exposed-modules: Network.Http.Types, Network.Http.RequestBuilder, Network.Http.Internal
+ lib/Network/Http/Internal.hs view
@@ -0,0 +1,456 @@+--+-- HTTP types for use with io-streams and pipes+--+-- Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the BSD licence.+--++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide, prune #-}++--+-- | If you're not http-streams or pipes-http and you're importing this,+-- you're Doing It Wrong.+--++module Network.Http.Internal (+ Hostname,+ Port,+ Request(..),+ EntityBody(..),+ ExpectMode(..),+ Response(..),+ StatusCode,+ TransferEncoding(..),+ ContentEncoding(..),+ getStatusCode,+ getStatusMessage,+ getHeader,+ Method(..),+ Headers,+ emptyHeaders,+ updateHeader,+ removeHeader,+ buildHeaders,+ lookupHeader,+ retrieveHeaders,+ HttpType (getHeaders),+ HttpParseException(..),++ -- for testing+ composeRequestBytes,+ composeResponseBytes+) where++import Prelude hiding (lookup)++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (copyByteString,+ copyByteString,+ fromByteString,+ fromByteString,+ toByteString)+import qualified Blaze.ByteString.Builder.Char8 as Builder (fromChar,+ fromShow,+ fromString)+import Control.Exception (Exception)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.CaseInsensitive (CI, mk, original)+import Data.HashMap.Strict (HashMap, delete, empty, foldrWithKey, insert,+ insertWith, lookup, toList)+import Data.Int (Int64)+import Data.List (foldl')+import Data.Monoid (mconcat, mempty)+import Data.Typeable (Typeable)+import Data.Word (Word16)++{-+ This is a String because that's what the uri package works in. There+ was a fairly detailed disucssion on haskell-cafe about this, with+ the conclusion that URLs are composed of characters, not octets.+-}++type Hostname = ByteString++type Port = Word16++--+-- | HTTP Methods, as per RFC 2616+--+data Method+ = GET+ | HEAD+ | POST+ | PUT+ | DELETE+ | TRACE+ | OPTIONS+ | CONNECT+ | PATCH+ | Method ByteString+ deriving (Show, Read, Ord)+++instance Eq Method where+ GET == GET = True+ HEAD == HEAD = True+ POST == POST = True+ PUT == PUT = True+ DELETE == DELETE = True+ TRACE == TRACE = True+ OPTIONS == OPTIONS = True+ CONNECT == CONNECT = True+ PATCH == PATCH = True+ GET == Method "GET" = True+ HEAD == Method "HEAD" = True+ POST == Method "POST" = True+ PUT == Method "PUT" = True+ DELETE == Method "DELETE" = True+ TRACE == Method "TRACE" = True+ OPTIONS == Method "OPTIONS" = True+ CONNECT == Method "CONNECT" = True+ PATCH == Method "PATCH" = True+ Method a == Method b = a == b+ m@(Method _) == other = other == m+ _ == _ = False++--+-- | A description of the request that will be sent to the server. Note+-- unlike other HTTP libraries, the request body is /not/ a part of this+-- object; that will be streamed out by you when actually sending the+-- request with 'sendRequest'.+--+-- 'Request' has a useful @Show@ instance that will output the request+-- line and headers (as it will be sent over the wire but with the @\\r@+-- characters stripped) which can be handy for debugging.+--+-- Note that the actual @Host:@ header is not set until the request is sent,+-- so you will not see it in the Show instance (unless you call 'setHostname'+-- to override the value inherited from the @Connection@).+--+data Request+ = Request {+ qMethod :: !Method,+ qHost :: !(Maybe ByteString),+ qPath :: !ByteString,+ qBody :: !EntityBody,+ qExpect :: !ExpectMode,+ qHeaders :: !Headers+ } deriving (Eq)++instance Show Request where+ show q = {-# SCC "Request.show" #-}+ S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeRequestBytes q "<default>"+++data EntityBody = Empty | Chunking | Static Int64 deriving (Show, Eq, Ord)++data ExpectMode = Normal | Continue deriving (Show, Eq, Ord)++{-+ The bit that builds up the actual string to be transmitted. This+ is on the critical path for every request, so we'll want to revisit+ this to improve performance.++ - Rewrite rule for Method?+ - How can serializing the Headers be made efficient?++ This code includes the RFC compliant CR-LF sequences as line+ terminators, which is why the Show instance above has to bother+ with removing them.+-}++composeRequestBytes :: Request -> ByteString -> Builder+composeRequestBytes q h' =+ mconcat+ [requestline,+ hostLine,+ headerFields,+ crlf]+ where+ requestline = mconcat+ [method,+ sp,+ uri,+ sp,+ version,+ crlf]++ method = case qMethod q of+ GET -> Builder.fromString "GET"+ HEAD -> Builder.fromString "HEAD"+ POST -> Builder.fromString "POST"+ PUT -> Builder.fromString "PUT"+ DELETE -> Builder.fromString "DELETE"+ TRACE -> Builder.fromString "TRACE"+ OPTIONS -> Builder.fromString "OPTIONS"+ CONNECT -> Builder.fromString "CONNECT"+ PATCH -> Builder.fromString "PATCH"+ (Method x) -> Builder.fromByteString x++ uri = case qPath q of+ "" -> Builder.fromChar '/'+ path -> Builder.copyByteString path++ version = Builder.fromString "HTTP/1.1"++ hostLine = mconcat+ [Builder.fromString "Host: ",+ hostname,+ crlf]++ hostname = case qHost q of+ Just x' -> Builder.copyByteString x'+ Nothing -> Builder.copyByteString h'++ headerFields = joinHeaders $ unWrap $ qHeaders q+++crlf = Builder.fromString "\r\n"++sp = Builder.fromChar ' '+++type StatusCode = Int++--+-- | A description of the response received from the server. Note+-- unlike other HTTP libraries, the response body is /not/ a part+-- of this object; that will be streamed in by you when calling+-- 'receiveResponse'.+--+-- Like 'Request', 'Response' has a @Show@ instance that will output+-- the status line and response headers as they were received from the+-- server.+--+data Response+ = Response {+ pStatusCode :: !StatusCode,+ pStatusMsg :: !ByteString,+ pTransferEncoding :: !TransferEncoding,+ pContentEncoding :: !ContentEncoding,+ pContentLength :: !(Maybe Int64),+ pHeaders :: !Headers+ }++instance Show Response where+ show p = {-# SCC "Response.show" #-}+ S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p+++data TransferEncoding = None | Chunked++data ContentEncoding = Identity | Gzip | Deflate+ deriving (Show)+++--+-- | Get the HTTP response status code.+--+getStatusCode :: Response -> StatusCode+getStatusCode = pStatusCode+{-# INLINE getStatusCode #-}++--+-- | Get the HTTP response status message. Keep in mind that this is+-- /not/ normative; whereas 'getStatusCode' values are authoritative.+--+getStatusMessage :: Response -> ByteString+getStatusMessage = pStatusMsg+{-# INLINE getStatusMessage #-}++--+-- | Lookup a header in the response. HTTP header field names are+-- case-insensitive, so you can specify the name to lookup however you+-- like. If the header is not present @Nothing@ will be returned.+--+-- > let n = case getHeader p "Content-Length" of+-- > Just x' -> read x' :: Int+-- > Nothing -> 0+--+-- which of course is essentially what goes on inside the client library when+-- it receives a response from the server and has to figure out how many bytes+-- to read.+--+-- There is a fair bit of complexity in some of the other HTTP response+-- fields, so there are a number of specialized functions for reading+-- those values where we've found them useful.+--+getHeader :: Response -> ByteString -> Maybe ByteString+getHeader p k =+ lookupHeader h k+ where+ h = pHeaders p++--+-- | Accessors common to both the outbound and return sides of an HTTP+-- connection.+--+class HttpType τ where++ --+ -- | Get the Headers from a Request or Response. Most people do not need+ -- this; for most cases you just need to get a header or two from the+ -- response, for which you can use 'getHeader'. On the other hand, if you+ -- do need to poke around in the raw headers,+ --+ -- @ import Network.Http.Types @+ --+ -- will give you functions like 'lookupHeader' and 'updateHeader' to to+ -- work with.+ --+ getHeaders :: τ -> Headers++instance HttpType Request where+ getHeaders q = qHeaders q++instance HttpType Response where+ getHeaders p = pHeaders p+++composeResponseBytes :: Response -> Builder+composeResponseBytes p =+ mconcat+ [statusline,+ headerFields,+ crlf]+ where+ statusline = mconcat+ [version,+ sp,+ code,+ sp,+ message,+ crlf]++ code = Builder.fromShow $ pStatusCode p++ message = Builder.copyByteString $ pStatusMsg p++ version = Builder.fromString "HTTP/1.1"++ headerFields = joinHeaders $ unWrap $ pHeaders p+++--+-- | The map of headers in a 'Request' or 'Response'. Note that HTTP+-- header field names are case insensitive, so if you call 'setHeader'+-- on a field that's already defined but with a different capitalization+-- you will replace the existing value.+--+{-+ This is a fair bit of trouble just to avoid using a typedef here.+ Probably worth it, though; every other HTTP client library out there+ exposes the gory details of the underlying map implementation, and+ to use it you need to figure out all kinds of crazy imports. Indeed,+ this code used here in the Show instance for debugging has been+ copied & pasted around various projects of mine since I started+ writing Haskell. It's quite tedious, and very arcane! So, wrap it+ up.+-}+newtype Headers = Wrap {+ unWrap :: HashMap (CI ByteString) ByteString+} deriving (Eq)++instance Show Headers where+ show x = S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ joinHeaders $ unWrap x++joinHeaders :: HashMap (CI ByteString) ByteString -> Builder+joinHeaders m = foldrWithKey combine mempty m++combine :: CI ByteString -> ByteString -> Builder -> Builder+combine k v acc =+ mconcat [acc, key, Builder.fromString ": ", value, crlf]+ where+ key = Builder.copyByteString $ original k+ value = Builder.fromByteString v+{-# INLINE combine #-}++emptyHeaders :: Headers+emptyHeaders =+ Wrap empty++--+-- | Set a header field to the specified value. This will overwrite+-- any existing value for the field. Remember that HTTP fields names+-- are case insensitive!+--+updateHeader :: Headers -> ByteString -> ByteString -> Headers+updateHeader x k v =+ Wrap result+ where+ !result = insert (mk k) v m+ !m = unWrap x++--+-- | Remove a header from the map. If a field with that name is not present,+-- then this will have no effect.+--+removeHeader :: Headers -> ByteString -> Headers+removeHeader x k =+ Wrap result+ where+ !result = delete (mk k) m+ !m = unWrap x+++--+-- | Given a list of field-name,field-value pairs, construct a Headers map.+--+{-+ This is only going to be used by RequestBuilder and ResponseParser,+ obviously. And yes, as usual, we go to a lot of trouble to splice out the+ function doing the work, in the name of type sanity.+-}+buildHeaders :: [(ByteString, ByteString)] -> Headers+buildHeaders hs =+ Wrap result+ where+ result = foldl' addHeader empty hs++{-+ insertWith is used here for the case where a header is repeated+ (for example, Set-Cookie) and the values need to be intercalated+ with ',' as per RFC 2616 §4.2.+-}+addHeader+ :: HashMap (CI ByteString) ByteString+ -> (ByteString,ByteString)+ -> HashMap (CI ByteString) ByteString+addHeader m (k,v) =+ insertWith f (mk k) v m+ where+ f new old = S.concat [old, ",", new]+++lookupHeader :: Headers -> ByteString -> Maybe ByteString+lookupHeader x k =+ lookup (mk k) m+ where+ !m = unWrap x+++--+-- | Get the headers as a field-name,field-value association list.+--+retrieveHeaders :: Headers -> [(ByteString, ByteString)]+retrieveHeaders x =+ map down $ toList m+ where+ !m = unWrap x++down :: (CI ByteString, ByteString) -> (ByteString, ByteString)+down (k, v) =+ (original k, v)++data HttpParseException = HttpParseException String+ deriving (Typeable, Show)++instance Exception HttpParseException
+ lib/Network/Http/RequestBuilder.hs view
@@ -0,0 +1,307 @@+--+-- HTTP types for use with io-streams and pipes+--+-- 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 GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}++module Network.Http.RequestBuilder (+ RequestBuilder,+ buildRequest,+ http,+ setHostname,+ setAccept,+ setAccept',+ setAuthorizationBasic,+ ContentType,+ setContentType,+ setContentLength,+ setExpectContinue,+ setTransferEncoding,+ setHeader+) where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Builder (fromByteString,+ toByteString)+import qualified Blaze.ByteString.Builder.Char8 as Builder (fromShow,+ fromString)+import Control.Applicative+import Control.Monad.State+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base64 as BS64+import Data.ByteString.Char8 ()+import qualified Data.ByteString.Char8 as S+import Data.Int (Int64)+import Data.List (intersperse)+import Data.Monoid (mconcat)++import Network.Http.Internal++--+-- | The RequestBuilder monad allows you to abuse do-notation to+-- conveniently setup a 'Request' object.+--+newtype RequestBuilder α = RequestBuilder (State Request α)+ deriving (Functor, Applicative, Monad, MonadState Request)++--+-- | Run a RequestBuilder, yielding a Request object you can use on the+-- given connection.+--+-- > q <- buildRequest $ do+-- > http POST "/api/v1/messages"+-- > setContentType "application/json"+-- > setHostname "clue.example.com" 80+-- > setAccept "text/html"+-- > setHeader "X-WhoDoneIt" "The Butler"+--+-- Obviously it's up to you to later actually /send/ JSON data.+--+buildRequest :: RequestBuilder α -> IO Request+buildRequest mm = do+ let (RequestBuilder s) = (mm)+ let q = Request {+ qHost = Nothing,+ qMethod = GET,+ qPath = "/",+ qBody = Empty,+ qExpect = Normal,+ qHeaders = emptyHeaders+ }+ return $ execState s q+++--+-- | Begin constructing a Request, starting with the request line.+--+http :: Method -> ByteString -> RequestBuilder ()+http m p' = do+ q <- get+ let h1 = qHeaders q+ let h2 = updateHeader h1 "Accept-Encoding" "gzip"++ let e = case m of+ PUT -> Chunking+ POST -> Chunking+ _ -> Empty++ let h3 = case e of+ Chunking -> updateHeader h2 "Transfer-Encoding" "chunked"+ _ -> h2++ put q {+ qMethod = m,+ qPath = p',+ qBody = e,+ qHeaders = h3+ }++--+-- | Set the [virtual] hostname for the request. In ordinary conditions+-- you won't need to call this, as the @Host:@ header is a required+-- header in HTTP 1.1 and is set directly from the name of the server+-- you connected to when calling 'Network.Http.Connection.openConnection'.+--+setHostname :: Hostname -> Port -> RequestBuilder ()+setHostname h' p = do+ q <- get+ put q {+ qHost = Just v'+ }+ where+ v' :: ByteString+ v' = if p == 80+ then h'+ else Builder.toByteString $ mconcat+ [Builder.fromByteString h',+ Builder.fromString ":",+ Builder.fromShow p]++--+-- | Set a generic header to be sent in the HTTP request. The other+-- methods in the RequestBuilder API are expressed in terms of this+-- function, but we recommend you use them where offered for their+-- stronger types.+--+setHeader :: ByteString -> ByteString -> RequestBuilder ()+setHeader k' v' = do+ q <- get+ let h0 = qHeaders q+ let h1 = updateHeader h0 k' v'+ put q {+ qHeaders = h1+ }++deleteHeader :: ByteString -> RequestBuilder ()+deleteHeader k' = do+ q <- get+ let h0 = qHeaders q+ let h1 = removeHeader h0 k'+ put q {+ qHeaders = h1+ }++{-# INLINE setEntityBody #-}+setEntityBody :: EntityBody -> RequestBuilder ()+setEntityBody e = do+ q <- get+ put q {+ qBody = e+ }++{-# INLINE setExpectMode #-}+setExpectMode :: ExpectMode -> RequestBuilder ()+setExpectMode e = do+ q <- get+ put q {+ qExpect = e+ }++--+-- | Indicate the content type you are willing to receive in a reply+-- from the server. For more complex @Accept:@ headers, use+-- 'setAccept''.+--+setAccept :: ByteString -> RequestBuilder ()+setAccept v' = do+ setHeader "Accept" v'++--+-- | Indicate the content types you are willing to receive in a reply+-- from the server in order of preference. A call of the form:+--+-- > setAccept' [("text/html", 1.0),+-- > ("application/xml", 0.8),+-- > ("*/*", 0)]+--+-- will result in an @Accept:@ header value of+-- @text\/html; q=1.0, application\/xml; q=0.8, \*\/\*; q=0.0@ as you+-- would expect.+--+setAccept' :: [(ByteString,Float)] -> RequestBuilder ()+setAccept' tqs = do+ setHeader "Accept" v'+ where+ v' = Builder.toByteString v+ v = mconcat $ intersperse (Builder.fromString ", ") $ map format tqs++ format :: (ByteString,Float) -> Builder+ format (t',q) =+ mconcat+ [Builder.fromByteString t',+ Builder.fromString "; q=",+ Builder.fromShow q]+++--+-- | Set username and password credentials per the HTTP basic+-- authentication method.+--+-- > setAuthorizationBasic "Aladdin" "open sesame"+--+-- will result in an @Authorization:@ header value of+-- @Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==@.+--+-- Basic authentication does /not/ use a message digest function to+-- encipher the password; the above string is only base-64 encoded and+-- is thus plain-text visible to any observer on the wire and all+-- caches and servers at the other end, making basic authentication+-- completely insecure. A number of web services, however, use SSL to+-- encrypt the connection that then use HTTP basic authentication to+-- validate requests. Keep in mind in these cases the secret is still+-- sent to the servers on the other side and passes in clear through+-- all layers after the SSL termination. Do /not/ use basic+-- authentication to protect secure or user-originated privacy-sensitve+-- information.+--+{-+ This would be better using Builder, right?+-}+setAuthorizationBasic :: ByteString -> ByteString -> RequestBuilder ()+setAuthorizationBasic user' passwd' = do+ setHeader "Authorization" v'+ where+ v' = S.concat ["Basic ", msg']+ msg' = BS64.encode str'+ str' = S.concat [user', ":", passwd']+++type ContentType = ByteString+++--+-- | Set the MIME type corresponding to the body of the request you are+-- sending. Defaults to @\"text\/plain\"@, so usually you need to set+-- this if 'PUT'ting.+--+setContentType :: ContentType -> RequestBuilder ()+setContentType v' = do+ setHeader "Content-Type" v'++--+-- | Specify the length of the request body, in bytes.+--+-- RFC 2616 requires that we either send a @Content-Length@ header or+-- use @Transfer-Encoding: chunked@. If you know the exact size ahead+-- of time, then call this function; the body content will still be+-- streamed out by @io-streams@ in more-or-less constant space.+--+-- This function is special: in a PUT or POST request, @http-streams@+-- will assume chunked transfer-encoding /unless/ you specify a content+-- length here, in which case you need to ensure your body function+-- writes precisely that many bytes.+--+--+setContentLength :: Int64 -> RequestBuilder ()+setContentLength n = do+ deleteHeader "Transfer-Encoding"+ setHeader "Content-Length" (S.pack $ show n)+ setEntityBody $ Static n++--+-- | Override the default setting about how the entity body will be sent.+--+-- This function is special: this explicitly sets the @Transfer-Encoding:@+-- header to @chunked@ and will instruct the library to actually tranfer the+-- body as a stream ("chunked transfer encoding"). See 'setContentLength' for+-- forcing the opposite. You /really/ won't need this in normal operation, but+-- some people are control freaks.+--+setTransferEncoding :: RequestBuilder ()+setTransferEncoding = do+ deleteHeader "Content-Length"+ setEntityBody Chunking+ setHeader "Transfer-Encoding" "chunked"+++--+-- | Specify that this request should set the expectation that the+-- server needs to approve the request before you send it.+--+-- This function is special: in a PUT or POST request, @http-streams@+-- will wait for the server to reply with an HTTP/1.1 100 Continue+-- status before sending the entity body. This is handled internally;+-- you will get the real response (be it successful 2xx, client error,+-- 4xx, or server error 5xx) in 'receiveResponse'. In theory, it+-- should be 417 if the expectation failed.+--+-- Only bother with this if you know the service you're talking to+-- requires clients to send an @Expect: 100-continue@ header and will+-- handle it properly. Most servers don't do any precondition checking,+-- automatically send an intermediate 100 response, and then just read+-- the body regardless, making this a bit of a no-op in most cases.+--+setExpectContinue :: RequestBuilder ()+setExpectContinue = do+ setHeader "Expect" "100-continue"+ setExpectMode Continue+
+ lib/Network/Http/Types.hs view
@@ -0,0 +1,69 @@+--+-- HTTP types for use with io-streams and pipes+--+-- 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_HADDOCK not-home #-}++--+-- | Basic types used in HTTP communications. This modules is re-exported by+-- both "Network.Http.Client" and "Pipes.Http.Client", so if you're using+-- either of those you don't need to explicitly import this module.+--++module Network.Http.Types (+ -- * Requests+ Hostname,+ Port,+ Request,+ EntityBody(..),+ ExpectMode(..),++ RequestBuilder,+ buildRequest,+ http,+ setHostname,+ setAccept,+ setAccept',+ setAuthorizationBasic,+ ContentType,+ setContentType,+ setContentLength,+ setExpectContinue,+ setTransferEncoding,+ setHeader,++ -- * Responses+ Response,+ StatusCode,+ TransferEncoding(..),+ ContentEncoding(..),+ getStatusCode,+ getStatusMessage,+ getHeader,+ Method(..),++ -- * Headers+ Headers,+ emptyHeaders,+ updateHeader,+ removeHeader,+ buildHeaders,+ lookupHeader,+ retrieveHeaders,+ HttpType (getHeaders),++ -- * Exceptions+ HttpParseException(..)++) where++import Network.Http.Internal+import Network.Http.RequestBuilder
− src/Network/Http/Internal.hs
@@ -1,454 +0,0 @@------ HTTP types for use with io-streams and pipes------ Copyright © 2012-2013 Operational Dynamics Consulting, Pty Ltd------ The code in this file, and the program it is a part of, is--- made available to you by its authors as open source software:--- you can redistribute it and/or modify it under the terms of--- the BSD licence.-----{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_HADDOCK hide, prune #-}------- | If you're not http-streams or pipes-http and you're importing this,--- you're Doing It Wrong.-----module Network.Http.Internal (- Hostname,- Port,- Request(..),- EntityBody(..),- ExpectMode(..),- Response(..),- StatusCode,- TransferEncoding(..),- ContentEncoding(..),- getStatusCode,- getStatusMessage,- getHeader,- Method(..),- Headers,- emptyHeaders,- updateHeader,- removeHeader,- buildHeaders,- lookupHeader,- retrieveHeaders,- HttpType (getHeaders),- HttpParseException(..),-- -- for testing- composeRequestBytes,- composeResponseBytes-) where--import Prelude hiding (lookup)--import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (copyByteString,- copyByteString,- fromByteString,- fromByteString,- toByteString)-import qualified Blaze.ByteString.Builder.Char8 as Builder (fromChar,- fromShow,- fromString)-import Control.Exception (Exception)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.CaseInsensitive (CI, mk, original)-import Data.HashMap.Strict (HashMap, delete, empty, foldrWithKey, insert,- insertWith, lookup, toList)-import Data.Int (Int64)-import Data.List (foldl')-import Data.Monoid (mconcat, mempty)-import Data.Typeable (Typeable)-import Data.Word (Word16)--{-- This is a String because that's what the uri package works in. There- was a fairly detailed disucssion on haskell-cafe about this, with- the conclusion that URLs are composed of characters, not octets.--}--type Hostname = ByteString--type Port = Word16------- | HTTP Methods, as per RFC 2616----data Method- = GET- | HEAD- | POST- | PUT- | DELETE- | TRACE- | OPTIONS- | CONNECT- | PATCH- | Method ByteString- deriving (Show, Read, Ord)---instance Eq Method where- GET == GET = True- HEAD == HEAD = True- POST == POST = True- PUT == PUT = True- DELETE == DELETE = True- TRACE == TRACE = True- OPTIONS == OPTIONS = True- CONNECT == CONNECT = True- PATCH == PATCH = True- GET == Method "GET" = True- HEAD == Method "HEAD" = True- POST == Method "POST" = True- PUT == Method "PUT" = True- DELETE == Method "DELETE" = True- TRACE == Method "TRACE" = True- OPTIONS == Method "OPTIONS" = True- CONNECT == Method "CONNECT" = True- PATCH == Method "PATCH" = True- Method a == Method b = a == b- m@(Method _) == other = other == m- _ == _ = False------- | A description of the request that will be sent to the server. Note--- unlike other HTTP libraries, the request body is /not/ a part of this--- object; that will be streamed out by you when actually sending the--- request with 'sendRequest'.------ 'Request' has a useful @Show@ instance that will output the request--- line and headers (as it will be sent over the wire but with the @\\r@--- characters stripped) which can be handy for debugging.------ Note that the actual @Host:@ header is not set until the request is sent,--- so you will not see it in the Show instance (unless you call 'setHostname'--- to override the value inherited from the @Connection@).----data Request- = Request {- qMethod :: !Method,- qHost :: !(Maybe ByteString),- qPath :: !ByteString,- qBody :: !EntityBody,- qExpect :: !ExpectMode,- qHeaders :: !Headers- }--instance Show Request where- show q = {-# SCC "Request.show" #-}- S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeRequestBytes q "<default>"---data EntityBody = Empty | Chunking | Static Int64--data ExpectMode = Normal | Continue--{-- The bit that builds up the actual string to be transmitted. This- is on the critical path for every request, so we'll want to revisit- this to improve performance.-- - Rewrite rule for Method?- - How can serializing the Headers be made efficient?-- This code includes the RFC compliant CR-LF sequences as line- terminators, which is why the Show instance above has to bother- with removing them.--}--composeRequestBytes :: Request -> ByteString -> Builder-composeRequestBytes q h' =- mconcat- [requestline,- hostLine,- headerFields,- crlf]- where- requestline = mconcat- [method,- sp,- uri,- sp,- version,- crlf]-- method = case qMethod q of- GET -> Builder.fromString "GET"- HEAD -> Builder.fromString "HEAD"- POST -> Builder.fromString "POST"- PUT -> Builder.fromString "PUT"- DELETE -> Builder.fromString "DELETE"- TRACE -> Builder.fromString "TRACE"- OPTIONS -> Builder.fromString "OPTIONS"- CONNECT -> Builder.fromString "CONNECT"- PATCH -> Builder.fromString "PATCH"- (Method x) -> Builder.fromByteString x-- uri = Builder.copyByteString $ qPath q-- version = Builder.fromString "HTTP/1.1"-- hostLine = mconcat- [Builder.fromString "Host: ",- hostname,- crlf]-- hostname = case qHost q of- Just x' -> Builder.copyByteString x'- Nothing -> Builder.copyByteString h'-- headerFields = joinHeaders $ unWrap $ qHeaders q---crlf = Builder.fromString "\r\n"--sp = Builder.fromChar ' '---type StatusCode = Int------- | A description of the response received from the server. Note--- unlike other HTTP libraries, the response body is /not/ a part--- of this object; that will be streamed in by you when calling--- 'receiveResponse'.------ Like 'Request', 'Response' has a @Show@ instance that will output--- the status line and response headers as they were received from the--- server.----data Response- = Response {- pStatusCode :: !StatusCode,- pStatusMsg :: !ByteString,- pTransferEncoding :: !TransferEncoding,- pContentEncoding :: !ContentEncoding,- pContentLength :: !(Maybe Int64),- pHeaders :: !Headers- }--instance Show Response where- show p = {-# SCC "Response.show" #-}- S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p---data TransferEncoding = None | Chunked--data ContentEncoding = Identity | Gzip | Deflate- deriving (Show)-------- | Get the HTTP response status code.----getStatusCode :: Response -> StatusCode-getStatusCode = pStatusCode-{-# INLINE getStatusCode #-}------- | Get the HTTP response status message. Keep in mind that this is--- /not/ normative; whereas 'getStatusCode' values are authoritative.----getStatusMessage :: Response -> ByteString-getStatusMessage = pStatusMsg-{-# INLINE getStatusMessage #-}------- | Lookup a header in the response. HTTP header field names are--- case-insensitive, so you can specify the name to lookup however you--- like. If the header is not present @Nothing@ will be returned.------ > let n = case getHeader p "Content-Length" of--- > Just x' -> read x' :: Int--- > Nothing -> 0------ which of course is essentially what goes on inside the client library when--- it receives a response from the server and has to figure out how many bytes--- to read.------ There is a fair bit of complexity in some of the other HTTP response--- fields, so there are a number of specialized functions for reading--- those values where we've found them useful.----getHeader :: Response -> ByteString -> Maybe ByteString-getHeader p k =- lookupHeader h k- where- h = pHeaders p------- | Accessors common to both the outbound and return sides of an HTTP--- connection.----class HttpType τ where-- --- -- | Get the Headers from a Request or Response. Most people do not need- -- this; for most cases you just need to get a header or two from the- -- response, for which you can use 'getHeader'. On the other hand, if you- -- do need to poke around in the raw headers,- --- -- @ import Network.Http.Types @- --- -- will give you functions like 'lookupHeader' and 'updateHeader' to to- -- work with.- --- getHeaders :: τ -> Headers--instance HttpType Request where- getHeaders q = qHeaders q--instance HttpType Response where- getHeaders p = pHeaders p---composeResponseBytes :: Response -> Builder-composeResponseBytes p =- mconcat- [statusline,- headerFields,- crlf]- where- statusline = mconcat- [version,- sp,- code,- sp,- message,- crlf]-- code = Builder.fromShow $ pStatusCode p-- message = Builder.copyByteString $ pStatusMsg p-- version = Builder.fromString "HTTP/1.1"-- headerFields = joinHeaders $ unWrap $ pHeaders p-------- | The map of headers in a 'Request' or 'Response'. Note that HTTP--- header field names are case insensitive, so if you call 'setHeader'--- on a field that's already defined but with a different capitalization--- you will replace the existing value.----{-- This is a fair bit of trouble just to avoid using a typedef here.- Probably worth it, though; every other HTTP client library out there- exposes the gory details of the underlying map implementation, and- to use it you need to figure out all kinds of crazy imports. Indeed,- this code used here in the Show instance for debugging has been- copied & pasted around various projects of mine since I started- writing Haskell. It's quite tedious, and very arcane! So, wrap it- up.--}-newtype Headers = Wrap {- unWrap :: HashMap (CI ByteString) ByteString-}--instance Show Headers where- show x = S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ joinHeaders $ unWrap x--joinHeaders :: HashMap (CI ByteString) ByteString -> Builder-joinHeaders m = foldrWithKey combine mempty m--combine :: CI ByteString -> ByteString -> Builder -> Builder-combine k v acc =- mconcat [acc, key, Builder.fromString ": ", value, crlf]- where- key = Builder.copyByteString $ original k- value = Builder.fromByteString v-{-# INLINE combine #-}--emptyHeaders :: Headers-emptyHeaders =- Wrap empty------- | Set a header field to the specified value. This will overwrite--- any existing value for the field. Remember that HTTP fields names--- are case insensitive!----updateHeader :: Headers -> ByteString -> ByteString -> Headers-updateHeader x k v =- Wrap result- where- !result = insert (mk k) v m- !m = unWrap x------- | Remove a header from the map. If a field with that name is not present,--- then this will have no effect.----removeHeader :: Headers -> ByteString -> Headers-removeHeader x k =- Wrap result- where- !result = delete (mk k) m- !m = unWrap x-------- | Given a list of field-name,field-value pairs, construct a Headers map.----{-- This is only going to be used by RequestBuilder and ResponseParser,- obviously. And yes, as usual, we go to a lot of trouble to splice out the- function doing the work, in the name of type sanity.--}-buildHeaders :: [(ByteString, ByteString)] -> Headers-buildHeaders hs =- Wrap result- where- result = foldl' addHeader empty hs--{-- insertWith is used here for the case where a header is repeated- (for example, Set-Cookie) and the values need to be intercalated- with ',' as per RFC 2616 §4.2.--}-addHeader- :: HashMap (CI ByteString) ByteString- -> (ByteString,ByteString)- -> HashMap (CI ByteString) ByteString-addHeader m (k,v) =- insertWith f (mk k) v m- where- f new old = S.concat [old, ",", new]---lookupHeader :: Headers -> ByteString -> Maybe ByteString-lookupHeader x k =- lookup (mk k) m- where- !m = unWrap x-------- | Get the headers as a field-name,field-value association list.----retrieveHeaders :: Headers -> [(ByteString, ByteString)]-retrieveHeaders x =- map down $ toList m- where- !m = unWrap x--down :: (CI ByteString, ByteString) -> (ByteString, ByteString)-down (k, v) =- (original k, v)--data HttpParseException = HttpParseException String- deriving (Typeable, Show)--instance Exception HttpParseException
− src/Network/Http/RequestBuilder.hs
@@ -1,306 +0,0 @@------ HTTP types for use with io-streams and pipes------ 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 GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_HADDOCK hide #-}--module Network.Http.RequestBuilder (- RequestBuilder,- buildRequest,- http,- setHostname,- setAccept,- setAccept',- setAuthorizationBasic,- ContentType,- setContentType,- setContentLength,- setExpectContinue,- setTransferEncoding,- setHeader-) where--import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (fromByteString,- toByteString)-import qualified Blaze.ByteString.Builder.Char8 as Builder (fromShow,- fromString)-import Control.Monad.State-import Data.ByteString (ByteString)-import qualified Data.ByteString.Base64 as BS64-import Data.ByteString.Char8 ()-import qualified Data.ByteString.Char8 as S-import Data.Int (Int64)-import Data.List (intersperse)-import Data.Monoid (mconcat)--import Network.Http.Internal------- | The RequestBuilder monad allows you to abuse do-notation to--- conveniently setup a 'Request' object.----newtype RequestBuilder α = RequestBuilder (State Request α)- deriving (Monad, MonadState Request)------- | Run a RequestBuilder, yielding a Request object you can use on the--- given connection.------ > q <- buildRequest $ do--- > http POST "/api/v1/messages"--- > setContentType "application/json"--- > setHostname "clue.example.com" 80--- > setAccept "text/html"--- > setHeader "X-WhoDoneIt" "The Butler"------ Obviously it's up to you to later actually /send/ JSON data.----buildRequest :: RequestBuilder α -> IO Request-buildRequest mm = do- let (RequestBuilder s) = (mm)- let q = Request {- qHost = Nothing,- qMethod = GET,- qPath = "/",- qBody = Empty,- qExpect = Normal,- qHeaders = emptyHeaders- }- return $ execState s q-------- | Begin constructing a Request, starting with the request line.----http :: Method -> ByteString -> RequestBuilder ()-http m p' = do- q <- get- let h1 = qHeaders q- let h2 = updateHeader h1 "Accept-Encoding" "gzip"-- let e = case m of- PUT -> Chunking- POST -> Chunking- _ -> Empty-- let h3 = case e of- Chunking -> updateHeader h2 "Transfer-Encoding" "chunked"- _ -> h2-- put q {- qMethod = m,- qPath = p',- qBody = e,- qHeaders = h3- }------- | Set the [virtual] hostname for the request. In ordinary conditions--- you won't need to call this, as the @Host:@ header is a required--- header in HTTP 1.1 and is set directly from the name of the server--- you connected to when calling 'Network.Http.Connection.openConnection'.----setHostname :: Hostname -> Port -> RequestBuilder ()-setHostname h' p = do- q <- get- put q {- qHost = Just v'- }- where- v' :: ByteString- v' = if p == 80- then h'- else Builder.toByteString $ mconcat- [Builder.fromByteString h',- Builder.fromString ":",- Builder.fromShow p]------- | Set a generic header to be sent in the HTTP request. The other--- methods in the RequestBuilder API are expressed in terms of this--- function, but we recommend you use them where offered for their--- stronger types.----setHeader :: ByteString -> ByteString -> RequestBuilder ()-setHeader k' v' = do- q <- get- let h0 = qHeaders q- let h1 = updateHeader h0 k' v'- put q {- qHeaders = h1- }--deleteHeader :: ByteString -> RequestBuilder ()-deleteHeader k' = do- q <- get- let h0 = qHeaders q- let h1 = removeHeader h0 k'- put q {- qHeaders = h1- }--{-# INLINE setEntityBody #-}-setEntityBody :: EntityBody -> RequestBuilder ()-setEntityBody e = do- q <- get- put q {- qBody = e- }--{-# INLINE setExpectMode #-}-setExpectMode :: ExpectMode -> RequestBuilder ()-setExpectMode e = do- q <- get- put q {- qExpect = e- }------- | Indicate the content type you are willing to receive in a reply--- from the server. For more complex @Accept:@ headers, use--- 'setAccept''.----setAccept :: ByteString -> RequestBuilder ()-setAccept v' = do- setHeader "Accept" v'------- | Indicate the content types you are willing to receive in a reply--- from the server in order of preference. A call of the form:------ > setAccept' [("text/html", 1.0),--- > ("application/xml", 0.8),--- > ("*/*", 0)]------ will result in an @Accept:@ header value of--- @text\/html; q=1.0, application\/xml; q=0.8, \*\/\*; q=0.0@ as you--- would expect.----setAccept' :: [(ByteString,Float)] -> RequestBuilder ()-setAccept' tqs = do- setHeader "Accept" v'- where- v' = Builder.toByteString v- v = mconcat $ intersperse (Builder.fromString ", ") $ map format tqs-- format :: (ByteString,Float) -> Builder- format (t',q) =- mconcat- [Builder.fromByteString t',- Builder.fromString "; q=",- Builder.fromShow q]-------- | Set username and password credentials per the HTTP basic--- authentication method.------ > setAuthorizationBasic "Aladdin" "open sesame"------ will result in an @Authorization:@ header value of--- @Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==@.------ Basic authentication does /not/ use a message digest function to--- encipher the password; the above string is only base-64 encoded and--- is thus plain-text visible to any observer on the wire and all--- caches and servers at the other end, making basic authentication--- completely insecure. A number of web services, however, use SSL to--- encrypt the connection that then use HTTP basic authentication to--- validate requests. Keep in mind in these cases the secret is still--- sent to the servers on the other side and passes in clear through--- all layers after the SSL termination. Do /not/ use basic--- authentication to protect secure or user-originated privacy-sensitve--- information.----{-- This would be better using Builder, right?--}-setAuthorizationBasic :: ByteString -> ByteString -> RequestBuilder ()-setAuthorizationBasic user' passwd' = do- setHeader "Authorization" v'- where- v' = S.concat ["Basic ", msg']- msg' = BS64.encode str'- str' = S.concat [user', ":", passwd']---type ContentType = ByteString-------- | Set the MIME type corresponding to the body of the request you are--- sending. Defaults to @\"text\/plain\"@, so usually you need to set--- this if 'PUT'ting.----setContentType :: ContentType -> RequestBuilder ()-setContentType v' = do- setHeader "Content-Type" v'------- | Specify the length of the request body, in bytes.------ RFC 2616 requires that we either send a @Content-Length@ header or--- use @Transfer-Encoding: chunked@. If you know the exact size ahead--- of time, then call this function; the body content will still be--- streamed out by @io-streams@ in more-or-less constant space.------ This function is special: in a PUT or POST request, @http-streams@--- will assume chunked transfer-encoding /unless/ you specify a content--- length here, in which case you need to ensure your body function--- writes precisely that many bytes.-------setContentLength :: Int64 -> RequestBuilder ()-setContentLength n = do- deleteHeader "Transfer-Encoding"- setHeader "Content-Length" (S.pack $ show n)- setEntityBody $ Static n------- | Override the default setting about how the entity body will be sent.------ This function is special: this explicitly sets the @Transfer-Encoding:@--- header to @chunked@ and will instruct the library to actually tranfer the--- body as a stream ("chunked transfer encoding"). See 'setContentLength' for--- forcing the opposite. You /really/ won't need this in normal operation, but--- some people are control freaks.----setTransferEncoding :: RequestBuilder ()-setTransferEncoding = do- deleteHeader "Content-Length"- setEntityBody Chunking- setHeader "Transfer-Encoding" "chunked"-------- | Specify that this request should set the expectation that the--- server needs to approve the request before you send it.------ This function is special: in a PUT or POST request, @http-streams@--- will wait for the server to reply with an HTTP/1.1 100 Continue--- status before sending the entity body. This is handled internally;--- you will get the real response (be it successful 2xx, client error,--- 4xx, or server error 5xx) in 'receiveResponse'. In theory, it--- should be 417 if the expectation failed.------ Only bother with this if you know the service you're talking to--- requires clients to send an @Expect: 100-continue@ header and will--- handle it properly. Most servers don't do any precondition checking,--- automatically send an intermediate 100 response, and then just read--- the body regardless, making this a bit of a no-op in most cases.----setExpectContinue :: RequestBuilder ()-setExpectContinue = do- setHeader "Expect" "100-continue"- setExpectMode Continue-
− src/Network/Http/Types.hs
@@ -1,69 +0,0 @@------ HTTP types for use with io-streams and pipes------ 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_HADDOCK not-home #-}------- | Basic types used in HTTP communications. This modules is re-exported by--- both "Network.Http.Client" and "Pipes.Http.Client", so if you're using--- either of those you don't need to explicitly import this module.-----module Network.Http.Types (- -- * Requests- Hostname,- Port,- Request,- EntityBody(..),- ExpectMode(..),-- RequestBuilder,- buildRequest,- http,- setHostname,- setAccept,- setAccept',- setAuthorizationBasic,- ContentType,- setContentType,- setContentLength,- setExpectContinue,- setTransferEncoding,- setHeader,-- -- * Responses- Response,- StatusCode,- TransferEncoding(..),- ContentEncoding(..),- getStatusCode,- getStatusMessage,- getHeader,- Method(..),-- -- * Headers- Headers,- emptyHeaders,- updateHeader,- removeHeader,- buildHeaders,- lookupHeader,- retrieveHeaders,- HttpType (getHeaders),-- -- * Exceptions- HttpParseException(..)--) where--import Network.Http.Internal-import Network.Http.RequestBuilder