From 3b25a067d57346c07da86b8b18d68f694153a763 Mon Sep 17 00:00:00 2001 From: Nebula Lavelle Date: Fri, 10 Apr 2026 16:49:05 -0400 Subject: [PATCH 1/2] beeline-http-client supports multipart/form-data --- beeline-http-client/beeline-http-client.cabal | 2 +- beeline-http-client/package.yaml | 2 +- .../src/Beeline/HTTP/Client/ContentType.hs | 19 ++++++ beeline-http-client/test/Main.hs | 58 +++++++++++++++++++ 4 files changed, 79 insertions(+), 2 deletions(-) diff --git a/beeline-http-client/beeline-http-client.cabal b/beeline-http-client/beeline-http-client.cabal index 5fcabc2..5f07bad 100644 --- a/beeline-http-client/beeline-http-client.cabal +++ b/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 homepage: https://github.com/flipstone/beeline#readme bug-reports: https://github.com/flipstone/beeline/issues diff --git a/beeline-http-client/package.yaml b/beeline-http-client/package.yaml index 7da8dac..e14fb54 100644 --- a/beeline-http-client/package.yaml +++ b/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 diff --git a/beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs b/beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs index 3acc5ad..f63697d 100644 --- a/beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs +++ b/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) a = + HTTP.RequestBodyIO (Multipart.renderParts boundary (toParts a)) diff --git a/beeline-http-client/test/Main.hs b/beeline-http-client/test/Main.hs index e8c0af9..dbcd322 100644 --- a/beeline-http-client/test/Main.hs +++ b/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 From 135da92b069d5c25d58539fd9b1ade538a4fbb67 Mon Sep 17 00:00:00 2001 From: Nebula Lavelle Date: Fri, 10 Apr 2026 16:52:42 -0400 Subject: [PATCH 2/2] Pointfree multipart `toRequestBody` --- beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs b/beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs index f63697d..006fdde 100644 --- a/beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs +++ b/beeline-http-client/src/Beeline/HTTP/Client/ContentType.hs @@ -195,5 +195,5 @@ instance ContentTypeEncoder MultipartFormData where toRequestContentType (MultipartFormData boundary) _ = BS8.pack "multipart/form-data; boundary=" <> boundary - toRequestBody (MultipartFormData boundary) (MultipartEncoder toParts) a = - HTTP.RequestBodyIO (Multipart.renderParts boundary (toParts a)) + toRequestBody (MultipartFormData boundary) (MultipartEncoder toParts) = + HTTP.RequestBodyIO . Multipart.renderParts boundary . toParts