diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,6 +1,6 @@ An HTTP client for use with io-streams -Copyright © 2012 Operational Dynamics Consulting, Pty Ltd +Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd and Others All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/http-common.cabal b/http-common.cabal --- a/http-common.cabal +++ b/http-common.cabal @@ -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 maintainer: Andrew Cowie -copyright: © 2012-2013 Operational Dynamics Consulting, Pty Ltd and Others +copyright: © 2012-2014 Operational Dynamics Consulting, Pty Ltd and Others category: Web -tested-with: GHC == 7.6 +tested-with: GHC == 7.8 stability: experimental homepage: http://research.operationaldynamics.com/projects/http-streams/ bug-reports: https://github.com/afcowie/http-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 diff --git a/lib/Network/Http/Internal.hs b/lib/Network/Http/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Internal.hs @@ -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 "" + + +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 diff --git a/lib/Network/Http/RequestBuilder.hs b/lib/Network/Http/RequestBuilder.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/RequestBuilder.hs @@ -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 + diff --git a/lib/Network/Http/Types.hs b/lib/Network/Http/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Http/Types.hs @@ -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 diff --git a/src/Network/Http/Internal.hs b/src/Network/Http/Internal.hs deleted file mode 100644 --- a/src/Network/Http/Internal.hs +++ /dev/null @@ -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 "" - - -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 diff --git a/src/Network/Http/RequestBuilder.hs b/src/Network/Http/RequestBuilder.hs deleted file mode 100644 --- a/src/Network/Http/RequestBuilder.hs +++ /dev/null @@ -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 - diff --git a/src/Network/Http/Types.hs b/src/Network/Http/Types.hs deleted file mode 100644 --- a/src/Network/Http/Types.hs +++ /dev/null @@ -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