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.24 name: http-common -version: 0.8.2.1 +version: 0.8.3.4 synopsis: Common types for HTTP clients and servers description: /Overview/ @@ -14,12 +14,12 @@ license-file: LICENSE author: Andrew Cowie maintainer: Andrew Cowie -copyright: © 2012-2020 Athae Eredh Siniath and Others +copyright: © 2012-2021 Athae Eredh Siniath and Others category: Web -tested-with: GHC == 8.8 +tested-with: GHC == 8.10 stability: experimental -homepage: https://github.com/istathar/http-common -bug-reports: https://github.com/istathar/http-common/issues +homepage: https://github.com/aesiniath/http-common +bug-reports: https://github.com/aesiniath/http-common/issues build-type: Simple @@ -33,6 +33,7 @@ bytestring, case-insensitive, mtl, + random, transformers, network, text, @@ -56,7 +57,7 @@ source-repository head type: git - location: git://github.com/afcowie/http-common.git + location: git://github.com/aesiniath/http-common.git -- vim: set tabstop=21 expandtab: diff --git a/lib/Network/Http/Internal.hs b/lib/Network/Http/Internal.hs --- a/lib/Network/Http/Internal.hs +++ b/lib/Network/Http/Internal.hs @@ -8,31 +8,37 @@ -- you can redistribute it and/or modify it under the terms of -- the BSD licence. -- - -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} +{-# 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. --- +{- | 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(..), + ContentType, + FieldName, + Request (..), + EntityBody (..), + ExpectMode (..), + Boundary, + unBoundary, + emptyBoundary, + randomBoundary, + packBoundary, + Response (..), StatusCode, - TransferEncoding(..), - ContentEncoding(..), + TransferEncoding (..), + ContentEncoding (..), getStatusCode, getStatusMessage, getHeader, - Method(..), + Method (..), Headers, emptyHeaders, updateHeader, @@ -41,49 +47,57 @@ lookupHeader, retrieveHeaders, HttpType (getHeaders), - HttpParseException(..), - + HttpParseException (..), + composeMultipartBytes, + composeMultipartEnding, -- for testing composeRequestBytes, - composeResponseBytes + 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 qualified Blaze.ByteString.Builder as Builder ( + copyByteString, + 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.Char (chr) +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. --} +import System.Random (newStdGen, randomRs) type Hostname = ByteString type Port = Word16 --- +type ContentType = ByteString + +type FieldName = ByteString + -- | HTTP Methods, as per RFC 2616 --- data Method = GET | HEAD @@ -95,65 +109,105 @@ | CONNECT | PATCH | Method ByteString - deriving (Show, Read, Ord) - + 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 + 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 "" +{- | +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 + , qBoundary :: !Boundary + } + 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) +newtype Boundary = Boundary ByteString deriving (Show, Eq) + +unBoundary :: Boundary -> ByteString +unBoundary (Boundary b') = b' + +emptyBoundary :: Boundary +emptyBoundary = Boundary S.empty + +represent :: Int -> Char +represent x + | x < 10 = chr (48 + x) + | x < 36 = chr (65 + x - 10) + | x < 62 = chr (97 + x - 36) + | otherwise = '@' + +{- | +Generate a random string to be used as an inter-part boundary in RFC 7578 +multipart form data. You pass this value to +'Network.Http.Client.setContentMultipart' and subsequently to +'Network.Http.Client.multipartFormBody'. +-} +randomBoundary :: IO Boundary +randomBoundary = do + gen <- newStdGen + let result = S.pack . fmap represent . take 20 . randomRs (0, 61) $ gen + pure (Boundary result) + +{- | +If you want to fix the multipart boundary to a known value (for testing +purposes) you can use this. The ideal such string, in case you are wondering, +is @\"bEacHV0113YB\@ll\"@. + +This isn't safe for use in production; you need to use an unpredictable value +as the boundary separtor so prefer 'randomBoundary'. +-} +packBoundary :: String -> Boundary +packBoundary = Boundary . S.pack + {- 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 @@ -170,41 +224,46 @@ composeRequestBytes :: Request -> ByteString -> Builder composeRequestBytes q h' = mconcat - [requestline, - hostLine, - headerFields, - crlf] + [ requestline + , hostLine + , headerFields + , crlf + ] where - requestline = mconcat - [method, - sp, - uri, - sp, - version, - crlf] + 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" + 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" + PATCH -> Builder.fromString "PATCH" (Method x) -> Builder.fromByteString x uri = case qPath q of - "" -> Builder.fromChar '/' + "" -> Builder.fromChar '/' path -> Builder.copyByteString path version = Builder.fromString "HTTP/1.1" - hostLine = mconcat - [Builder.fromString "Host: ", - hostname, - crlf] + hostLine = + mconcat + [ Builder.fromString "Host: " + , hostname + , crlf + ] hostname = case qHost q of Just x' -> Builder.copyByteString x' @@ -212,100 +271,135 @@ headerFields = joinHeaders $ unWrap $ qHeaders q - crlf = Builder.fromString "\r\n" sp = Builder.fromChar ' ' +dashdash = Builder.fromString "--" +composeMultipartBytes :: Boundary -> FieldName -> Maybe FilePath -> Maybe ContentType -> Builder +composeMultipartBytes boundary name possibleFilename possibleContentType = + mconcat + [ boundaryLine + , dispositionLine + , mimetypeLine + , crlf -- second CR LF + ] + where + boundaryLine = + crlf + <> dashdash + <> Builder.copyByteString (unBoundary boundary) + <> crlf + dispositionLine = + "Content-Disposition: form-data; name=\"" + <> Builder.copyByteString name + <> "\"" + <> case possibleFilename of + Just filename -> + "; filename=\"" + <> Builder.fromString filename + <> "\"" + Nothing -> mempty + <> crlf + mimetypeLine = + case possibleContentType of + Just mimetype -> + "Content-Type: " <> Builder.copyByteString mimetype + <> crlf + Nothing -> mempty + +composeMultipartEnding :: Boundary -> Builder +composeMultipartEnding boundary = + crlf + <> dashdash + <> Builder.copyByteString (unBoundary boundary) + <> dashdash + <> crlf + 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 +{- | +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" #-} + 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. --- +{- | +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. --- +{- | +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 +{- | +Accessors common to both the outbound and return sides of an HTTP connection. - -- - -- | 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. - -- +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. +-} +class HttpType τ where + -- | Get the Headers from a Request or Response.y getHeaders :: τ -> Headers instance HttpType Request where @@ -314,21 +408,23 @@ instance HttpType Response where getHeaders p = pHeaders p - composeResponseBytes :: Response -> Builder composeResponseBytes p = mconcat - [statusline, - headerFields, - crlf] + [ statusline + , headerFields + , crlf + ] where - statusline = mconcat - [version, - sp, - code, - sp, - message, - crlf] + statusline = + mconcat + [ version + , sp + , code + , sp + , message + , crlf + ] code = Builder.fromShow $ pStatusCode p @@ -338,13 +434,13 @@ 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. +-} --- --- | 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 @@ -355,9 +451,10 @@ writing Haskell. It's quite tedious, and very arcane! So, wrap it up. -} -newtype Headers = Wrap { - unWrap :: HashMap (CI ByteString) ByteString -} deriving (Eq) +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 @@ -377,11 +474,11 @@ 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! --- +{- | +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 @@ -389,10 +486,10 @@ !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. --- +{- | +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 @@ -400,10 +497,8 @@ !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 @@ -420,26 +515,22 @@ (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) = +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 @@ -451,6 +542,6 @@ (original k, v) data HttpParseException = HttpParseException String - deriving (Typeable, Show) + deriving (Typeable, Show) instance Exception HttpParseException diff --git a/lib/Network/Http/RequestBuilder.hs b/lib/Network/Http/RequestBuilder.hs --- a/lib/Network/Http/RequestBuilder.hs +++ b/lib/Network/Http/RequestBuilder.hs @@ -22,12 +22,12 @@ setAccept, setAccept', setAuthorizationBasic, - ContentType, setContentType, setContentLength, setExpectContinue, setTransferEncoding, - setHeader + setHeader, + setContentMultipart ) where import Blaze.ByteString.Builder (Builder) @@ -35,7 +35,6 @@ 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 @@ -43,7 +42,6 @@ import qualified Data.ByteString.Char8 as S import Data.Int (Int64) import Data.List (intersperse) -import Data.Monoid (mconcat) import Network.Http.Internal @@ -76,7 +74,8 @@ qPath = "/", qBody = Empty, qExpect = Normal, - qHeaders = emptyHeaders + qHeaders = emptyHeaders, + qBoundary = emptyBoundary } execState s q @@ -248,10 +247,6 @@ 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 @@ -262,6 +257,28 @@ setHeader "Content-Type" v' -- +-- | If sending multipart form data (RFC 7578), you need to set the MIME type +-- to @\"multipart/form-data\"@ and specify the boundary separator that will +-- be used. +-- +-- This function is special: you must subsequently use +-- 'Network.Http.Client.multipartFormBody' to sequence the individual body +-- parts. When sending the request it will separate the individual parts by +-- the boundary value set by this function. +-- +setContentMultipart :: Boundary -> RequestBuilder () +setContentMultipart boundary = do + setHeader "Content-Type" (S.append "multipart/form-data; boundary=" (unBoundary boundary)) + setBoundary boundary + +setBoundary :: Boundary -> RequestBuilder () +setBoundary boundary = do + q <- get + put q { + qBoundary = boundary + } + +-- -- | Specify the length of the request body, in bytes. -- -- RFC 2616 requires that we either send a @Content-Length@ header or @@ -318,4 +335,3 @@ setExpectContinue = do setHeader "Expect" "100-continue" setExpectMode Continue - diff --git a/lib/Network/Http/Types.hs b/lib/Network/Http/Types.hs --- a/lib/Network/Http/Types.hs +++ b/lib/Network/Http/Types.hs @@ -39,6 +39,13 @@ setContentLength, setExpectContinue, setTransferEncoding, + FieldName, + Boundary, + unBoundary, + emptyBoundary, + randomBoundary, + packBoundary, + setContentMultipart, setHeader, -- * Responses