diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for http-client +## 0.6.0 + +* Generalize `renderParts` over arbitrary applicative functors. One particular + use case that is enabled by this change is that now `renderParts` can be used + in pure code by using it in combination with `runIdentity`. + ## 0.5.14 * Omit port for `getUri` when protocol is `http` and port is `80`, or when diff --git a/Network/HTTP/Client/MultipartFormData.hs b/Network/HTTP/Client/MultipartFormData.hs --- a/Network/HTTP/Client/MultipartFormData.hs +++ b/Network/HTTP/Client/MultipartFormData.hs @@ -24,6 +24,7 @@ ( -- * Part type Part + ,PartM ,partName ,partFilename ,partContentType @@ -77,17 +78,19 @@ import Control.Monad import Data.ByteString.Lazy.Internal (defaultChunkSize) +type Part = PartM IO + -- | A single part of a multipart message. -data Part = Part +data PartM m = Part { partName :: Text -- ^ Name of the corresponding \ , partFilename :: Maybe String -- ^ A file name, if this is an attached file , partContentType :: Maybe MimeType -- ^ Content type , partHeaders :: [Header] -- ^ List of additional headers - , partGetBody :: IO RequestBody -- ^ Action in m which returns the body + , partGetBody :: m RequestBody -- ^ Action in m which returns the body -- of a message. } -instance Show Part where +instance Show (PartM m) where showsPrec d (Part n f c h _) = showParen (d>=11) $ showString "Part " . showsPrec 11 n @@ -104,19 +107,21 @@ -- -- The 'Part' does not have a file name or content type associated -- with it. -partBS :: Text -- ^ Name of the corresponding \. +partBS :: Applicative m + => Text -- ^ Name of the corresponding \. -> BS.ByteString -- ^ The body for this 'Part'. - -> Part -partBS n b = Part n Data.Monoid.mempty mempty mempty $ return $ RequestBodyBS b + -> PartM m +partBS n b = Part n Data.Monoid.mempty mempty mempty $ pure $ RequestBodyBS b -- | Make a 'Part' whose content is a lazy 'BL.ByteString'. -- -- The 'Part' does not have a file name or content type associated -- with it. -partLBS :: Text -- ^ Name of the corresponding \. +partLBS :: Applicative m + => Text -- ^ Name of the corresponding \. -> BL.ByteString -- ^ The body for this 'Part'. - -> Part -partLBS n b = Part n mempty mempty mempty $ return $ RequestBodyLBS b + -> PartM m +partLBS n b = Part n mempty mempty mempty $ pure $ RequestBodyLBS b -- | Make a 'Part' from a file. -- @@ -179,12 +184,13 @@ -- > partFileRequestBody "file" mempty mempty -- -- The 'Part' does not have a content type associated with it. -partFileRequestBody :: Text -- ^ Name of the corresponding \. +partFileRequestBody :: Applicative m + => Text -- ^ Name of the corresponding \. -> FilePath -- ^ File name to supply to the server. -> RequestBody -- ^ Data to upload. - -> Part + -> PartM m partFileRequestBody n f rqb = - partFileRequestBodyM n f $ return rqb + partFileRequestBodyM n f $ pure rqb -- | Construct a 'Part' from action returning the 'RequestBody' -- @@ -195,8 +201,8 @@ -- The 'Part' does not have a content type associated with it. partFileRequestBodyM :: Text -- ^ Name of the corresponding \. -> FilePath -- ^ File name to supply to the server. - -> IO RequestBody -- ^ Action that will supply data to upload. - -> Part + -> m RequestBody -- ^ Action that will supply data to upload. + -> PartM m partFileRequestBodyM n f rqb = Part n (Just f) (Just $ defaultMimeLookup $ pack f) mempty rqb @@ -205,12 +211,13 @@ cp bs = RequestBodyBuilder (fromIntegral $ BS.length bs) $ copyByteString bs -- | Add a list of additional headers to this 'Part'. -addPartHeaders :: Part -> [Header] -> Part +addPartHeaders :: PartM m -> [Header] -> PartM m addPartHeaders p hs = p { partHeaders = partHeaders p <> hs } -renderPart :: BS.ByteString -- ^ Boundary between parts. - -> Part -> IO RequestBody -renderPart boundary (Part name mfilename mcontenttype hdrs get) = liftM render get +renderPart :: Functor m + => BS.ByteString -- ^ Boundary between parts. + -> PartM m -> m RequestBody +renderPart boundary (Part name mfilename mcontenttype hdrs get) = render <$> get where render renderBody = cp "--" <> cp boundary <> cp "\r\n" <> cp "Content-Disposition: form-data; name=\"" @@ -234,9 +241,10 @@ <> renderBody <> cp "\r\n" -- | Combine the 'Part's to form multipart/form-data body -renderParts :: BS.ByteString -- ^ Boundary between parts. - -> [Part] -> IO RequestBody -renderParts boundary parts = (fin . mconcat) `liftM` mapM (renderPart boundary) parts +renderParts :: Applicative m + => BS.ByteString -- ^ Boundary between parts. + -> [PartM m] -> m RequestBody +renderParts boundary parts = (fin . mconcat) <$> traverse (renderPart boundary) parts where fin = (<> cp "--" <> cp boundary <> cp "--\r\n") -- | Generate a boundary simillar to those generated by WebKit-based browsers. @@ -273,13 +281,12 @@ formDataBodyWithBoundary boundary a b -- | Add form data with supplied boundary -formDataBodyWithBoundary :: BS.ByteString -> [Part] -> Request -> IO Request +formDataBodyWithBoundary :: Applicative m => BS.ByteString -> [PartM m] -> Request -> m Request formDataBodyWithBoundary boundary parts req = do - body <- renderParts boundary parts - return $ req + (\ body -> req { method = methodPost , requestHeaders = (hContentType, "multipart/form-data; boundary=" <> boundary) : Prelude.filter (\(x, _) -> x /= hContentType) (requestHeaders req) , requestBody = body - } + }) <$> renderParts boundary parts diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -1,5 +1,5 @@ name: http-client -version: 0.5.14 +version: 0.6.0 synopsis: An HTTP client engine description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/snoyberg/http-client