beeline-http-client supports multipart/form-data

beeline-http-client/beeline-http-client.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           beeline-http-client
-version:        0.9.0.1
+version:        0.9.0.2
 description:    Please see the README on GitHub at <https://github.com/githubuser/json-fleece-http#readme>
 homepage:       https://github.com/flipstone/beeline#readme
 bug-reports:    https://github.com/flipstone/beeline/issues

beeline-http-client/package.yaml

@@ -1,5 +1,5 @@
 name: beeline-http-client
-version: 0.9.0.1
+version: 0.9.0.2
 github: "flipstone/beeline/beeline-http-client"
 author: Flipstone Technology Partners
 maintainer: development@flipstone.com

beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs

@@ -17,6 +17,8 @@ module Beeline.HTTP.Client.ContentType
   , OctetStreamEncoding (Bytes, LazyBytes)
   , FormURLEncoded (FormURLEncoded)
   , FormEncoder (FormEncoder)
+  , MultipartFormData (MultipartFormData, multipartFormDataBoundary)
+  , MultipartEncoder (MultipartEncoder)
   ) where
 
 import qualified Control.Exception as Exc
@@ -29,6 +31,7 @@ import qualified Data.Text.Encoding as Enc
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LEnc
 import qualified Network.HTTP.Client as HTTP
+import qualified Network.HTTP.Client.MultipartFormData as Multipart
 
 import Beeline.Params (QueryEncoder, encodeQueryBare)
 
@@ -178,3 +181,19 @@ instance ContentTypeEncoder FormURLEncoded where
 formURLEncodedContentType :: BS.ByteString
 formURLEncodedContentType =
   BS8.pack "application/x-www-form-urlencoded"
+
+newtype MultipartFormData = MultipartFormData
+  { multipartFormDataBoundary :: BS.ByteString
+  }
+
+newtype MultipartEncoder a
+  = MultipartEncoder (a -> [Multipart.Part])
+
+instance ContentTypeEncoder MultipartFormData where
+  type EncodeSchema MultipartFormData = MultipartEncoder
+
+  toRequestContentType (MultipartFormData boundary) _ =
+    BS8.pack "multipart/form-data; boundary=" <> boundary
+
+  toRequestBody (MultipartFormData boundary) (MultipartEncoder toParts) =
+    HTTP.RequestBodyIO . Multipart.renderParts boundary . toParts

beeline-http-client/test/Main.hs

@@ -21,6 +21,7 @@ import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Main as HHM
 import qualified Hedgehog.Range as Range
 import qualified Network.HTTP.Client as HTTP
+import qualified Network.HTTP.Client.MultipartFormData as Multipart
 import qualified Network.HTTP.Types as HTTPTypes
 import qualified Network.Wai as Wai
 import qualified Network.Wai.Handler.Warp as Warp
@@ -53,6 +54,7 @@ tests =
   , ("prop_headers", prop_headers)
   , ("prop_additionalHeaders", prop_additionalHeaders)
   , ("prop_parseBaseURI", prop_parseBaseURI)
+  , ("prop_httpPostMultipart", prop_httpPostMultipart)
   ]
 
 newtype FooBarId
@@ -646,6 +648,62 @@ prop_parseBaseURI =
 
     Right expected === BHC.parseBaseURI input
 
+postMultipart ::
+  BHC.Operation
+    BHC.ContentTypeDecodingError
+    BHC.NoPathParams
+    BHC.NoQueryParams
+    BHC.NoHeaderParams
+    (T.Text, BS.ByteString)
+    BHC.NoResponseBody
+postMultipart =
+  let
+    boundary = "test-boundary-1234"
+    encoder = BHC.MultipartEncoder $ \(name, content) ->
+      [Multipart.partBS name content]
+  in
+    BHC.defaultOperation
+      { BHC.requestRoute = R.post (R.make BHC.NoPathParams)
+      , BHC.requestBodySchema =
+          BHC.requestBody (BHC.MultipartFormData boundary) encoder
+      }
+
+prop_httpPostMultipart :: HH.Property
+prop_httpPostMultipart =
+  HH.withTests 1 . HH.property $ do
+    withAssertLater $ \assertLater -> do
+      let
+        expectedName = "fieldname"
+        expectedContent = "field value"
+
+        handleRequest request = do
+          body <- fmap LBS.toStrict (Wai.consumeRequestBodyStrict request)
+
+          assertLater $ do
+            Wai.requestMethod request === HTTPTypes.methodPost
+            lookup "Content-Type" (Wai.requestHeaders request)
+              === Just "multipart/form-data; boundary=test-boundary-1234"
+            let
+              bodyStr = BS8.unpack body
+            HH.assert (List.isInfixOf "fieldname" bodyStr)
+            HH.assert (List.isInfixOf "field value" bodyStr)
+
+          pure $ Wai.responseLBS HTTPTypes.ok200 [] ""
+
+        issueRequest port = do
+          let
+            request =
+              BHC.defaultRequest
+                { BHC.baseURI = BHC.defaultBaseURI {BHC.port = port}
+                , BHC.body = (expectedName, expectedContent)
+                }
+
+          manager <- HTTP.newManager HTTP.defaultManagerSettings
+          BHC.httpRequestThrow postMultipart request manager
+
+      response <- HH.evalIO (withTestServer handleRequest issueRequest)
+      response === BHC.NoResponseBody
+
 withAssertLater ::
   ((HH.PropertyT IO () -> IO ()) -> HH.PropertyT IO a) ->
   HH.PropertyT IO a