http-common 0.8.2.1 → 0.8.3.4

raw patch · 4 files changed

+340/−225 lines, 4 filesdep +randomPVP ok

version bump matches the API change (PVP)

Dependencies added: random

API changes (from Hackage documentation)

Files

• http-common.cabal +7/−6
• lib/Network/Http/Internal.hs +300/−209
• lib/Network/Http/RequestBuilder.hs +26/−10
• lib/Network/Http/Types.hs +7/−0

@@ -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 <istathar@gmail.com> maintainer:          Andrew Cowie <istathar@gmail.com>-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:

@@ -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 "<default>"+{- |+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 "<to be determined>"+ 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

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

@@ -39,6 +39,13 @@     setContentLength,     setExpectContinue,     setTransferEncoding,+    FieldName,+    Boundary,+    unBoundary,+    emptyBoundary,+    randomBoundary,+    packBoundary,+    setContentMultipart,     setHeader,      -- * Responses