diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## Req 0.2.0 + +* Added support for multipart form data in form of `ReqBodyMultipart` body + option and `reqBodyMultipart` helper function. This also required a change + in type signature of `getRequestContentType`, which now takes `body`, not + `Proxy body` because we need to extract boundary from `body` and put it + into `Content-Type` header. This change, however, shouldn't be too + dangerous for end-users. + +* Added support for OAuth 1.0 authentication via `oAuth1` option. + ## Req 0.1.0 * Initial release. diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2016 Mark Karpov +Copyright © 2016–2017 Mark Karpov All rights reserved. diff --git a/Network/HTTP/Req.hs b/Network/HTTP/Req.hs --- a/Network/HTTP/Req.hs +++ b/Network/HTTP/Req.hs @@ -1,6 +1,6 @@ -- | -- Module : Network.HTTP.Req --- Copyright : © 2016 Mark Karpov +-- Copyright : © 2016–2017 Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -149,6 +149,8 @@ , ReqBodyLbs (..) , ReqBodyUrlEnc (..) , FormUrlEncodedParam + , ReqBodyMultipart + , reqBodyMultipart , HttpBody (..) , ProvidesBody , HttpBodyAllowed @@ -168,6 +170,7 @@ -- *** Authentication -- $authentication , basicAuth + , oAuth1 , oAuth2Bearer , oAuth2Token -- *** Other @@ -216,6 +219,7 @@ import Data.IORef import Data.List (nubBy) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) import Data.Proxy import Data.Semigroup hiding (Option, option) import Data.Typeable (Typeable) @@ -234,8 +238,10 @@ import qualified Network.Connection as NC import qualified Network.HTTP.Client as L import qualified Network.HTTP.Client.Internal as LI +import qualified Network.HTTP.Client.MultipartFormData as LM import qualified Network.HTTP.Client.TLS as L import qualified Network.HTTP.Types as Y +import qualified Web.Authenticate.OAuth as OAuth #if MIN_VERSION_base(4,9,0) import Data.Kind (Constraint) @@ -260,12 +266,11 @@ -- @method@ is an HTTP method such as 'GET' or 'POST'. The documentation has -- a dedicated section about HTTP methods below. -- --- @url@ is a URL that describes location of resource you want to interact --- with. It's of type 'Url' (if you click the link it will tell everything --- about construction of 'Url' things). +-- @url@ is a 'Url' that describes location of resource you want to interact +-- with. -- -- @body@ is a body option such as 'NoReqBody' or 'ReqBodyJson'. The --- tutorial has a section about HTTP bodies, but usage in very +-- tutorial has a section about HTTP bodies, but usage is very -- straightforward and should be clear from the examples below. -- -- @response@ is a type hint how to make and interpret response of HTTP @@ -393,7 +398,7 @@ -- “overwrite” headers when we construct a request by cons-ing. nubHeaders = Endo $ \x -> x { L.requestHeaders = nubBy ((==) `on` fst) (L.requestHeaders x) } - request = flip appEndo L.defaultRequest $ + request' = flip appEndo L.defaultRequest $ -- NOTE Order of 'mappend's matters, here method is overwritten first -- and 'options' take effect last. In particular, this means that -- 'options' can overwrite things set by other request components, @@ -406,6 +411,7 @@ getRequestMod url <> getRequestMod (Womb method :: Womb "method" method) wrappingVanilla m = catch m (throwIO . VanillaHttpException) + request <- finalizeRequest options request' (liftIO . try . wrappingVanilla) (getHttpResponse request manager) >>= either handleHttpException return @@ -778,7 +784,7 @@ instance ToJSON a => HttpBody (ReqBodyJson a) where getRequestBody (ReqBodyJson a) = L.RequestBodyLBS (A.encode a) - getRequestContentType Proxy = pure "application/json; charset=utf-8" + getRequestContentType _ = pure "application/json; charset=utf-8" -- | This body option streams request body from a file. It is expected that -- the file size does not change during the streaming. @@ -824,7 +830,7 @@ instance HttpBody ReqBodyUrlEnc where getRequestBody (ReqBodyUrlEnc (FormUrlEncodedParam params)) = (L.RequestBodyLBS . BB.toLazyByteString) (Y.renderQueryText False params) - getRequestContentType Proxy = pure "application/x-www-form-urlencoded" + getRequestContentType _ = pure "application/x-www-form-urlencoded" -- | An opaque monoidal value that allows to collect URL-encoded parameters -- to be wrapped in 'ReqBodyUrlEnc'. @@ -836,6 +842,31 @@ queryParam name mvalue = FormUrlEncodedParam [(name, toQueryParam <$> mvalue)] +-- | Multipart form data. Please consult the +-- "Network.HTTP.Client.MultipartFormData" module for how to construct +-- parts, then use 'reqBodyMultipart' to create actual request body from the +-- parts. 'reqBodyMultipart' is the only way to get a value of type +-- 'ReqBodyMultipart', as its constructor is not exported on purpose. +-- +-- @since 0.2.0 + +data ReqBodyMultipart = ReqBodyMultipart ByteString LI.RequestBody + +instance HttpBody ReqBodyMultipart where + getRequestBody (ReqBodyMultipart _ body) = body + getRequestContentType (ReqBodyMultipart boundary _) = + pure ("multipart/form-data; boundary=" <> boundary) + +-- | Create 'ReqBodyMultipart' request body from a collection of 'LM.Part's. +-- +-- @since 0.2.0 + +reqBodyMultipart :: MonadIO m => [LM.Part] -> m ReqBodyMultipart +reqBodyMultipart parts = liftIO $ do + boundary <- LM.webkitBoundary + body <- LM.renderParts boundary parts + return (ReqBodyMultipart boundary body) + -- | A type class for things that can be interpreted as HTTP -- 'L.RequestBody'. @@ -851,8 +882,8 @@ -- header that should be used with particular body option. By default it -- returns 'Nothing' and so @Content-Type@ is not set. - getRequestContentType :: Proxy body -> Maybe ByteString - getRequestContentType Proxy = Nothing + getRequestContentType :: body -> Maybe ByteString + getRequestContentType = const Nothing -- | The type function recognizes 'NoReqBody' as having 'NoBody', while any -- other body option 'CanHaveBody'. This forces user to use 'NoReqBody' with @@ -884,7 +915,7 @@ x { L.requestBody = getRequestBody body , L.requestHeaders = let old = L.requestHeaders x in - case getRequestContentType (Proxy :: Proxy body) of + case getRequestContentType body of Nothing -> old Just contentType -> (Y.hContentType, contentType) : old } @@ -905,12 +936,12 @@ -- to learn which 'Option' primitives are available. data Option (scheme :: Scheme) = - Option (Endo (Y.QueryText, L.Request)) (Maybe (Endo L.Request)) + Option (Endo (Y.QueryText, L.Request)) (Maybe (L.Request -> IO L.Request)) -- NOTE 'QueryText' is just [(Text, Maybe Text)], we keep it along with -- Request to avoid appending to existing query string in request every -- time new parameter is added. Additional Maybe (Endo Request) is a - -- finalizer that will be applied after all over options. This is for - -- authentication methods that sign requests based on data in Request. + -- finalizer that will be applied after all other transformations. This is + -- for authentication methods that sign requests based on data in Request. instance Semigroup (Option scheme) where Option er0 mr0 <> Option er1 mr1 = Option @@ -935,15 +966,21 @@ -- | A helper to create an 'Option' that adds a finalizer (request -- endomorphism that is run after all other modifications). -asFinalizer :: (L.Request -> L.Request) -> Option scheme -asFinalizer f = Option mempty (Just (Endo f)) +asFinalizer :: (L.Request -> IO L.Request) -> Option scheme +asFinalizer = Option mempty . pure instance RequestComponent (Option scheme) where - getRequestMod (Option f finalizer) = Endo $ \x -> + getRequestMod (Option f _) = Endo $ \x -> let (qparams, x') = appEndo f ([], x) query = Y.renderQuery True (Y.queryTextToQuery qparams) - in maybe id appEndo finalizer x' { L.queryString = query } + in x' { L.queryString = query } +-- | Finalize given 'L.Request' by applying a finalizer from given 'Option' +-- (if it has any). + +finalizeRequest :: MonadIO m => Option scheme -> L.Request -> m L.Request +finalizeRequest (Option _ mfinalizer) = liftIO . fromMaybe pure mfinalizer + ---------------------------------------------------------------------------- -- Request — Optional parameters — Query Parameters @@ -1053,8 +1090,26 @@ -> ByteString -- ^ Password -> Option 'Https -- ^ Auth 'Option' basicAuth username password = asFinalizer - (L.applyBasicAuth username password) + (pure . L.applyBasicAuth username password) +-- | The 'Option' adds OAuth1 authentication. +-- +-- @since 0.2.0 + +oAuth1 + :: ByteString -- ^ Consumer token + -> ByteString -- ^ Consumer secret + -> ByteString -- ^ OAuth token + -> ByteString -- ^ OAuth token secret + -> Option scheme -- ^ Auth 'Option' +oAuth1 consumerToken consumerSecret token tokenSecret = + asFinalizer (OAuth.signOAuth app creds) + where + app = OAuth.newOAuth + { OAuth.oauthConsumerKey = consumerToken + , OAuth.oauthConsumerSecret = consumerSecret } + creds = OAuth.newCredential token tokenSecret + -- | The 'Option' adds an OAuth2 bearer token. This is treated by many -- services as the equivalent of a username and password. -- @@ -1068,7 +1123,7 @@ :: ByteString -- ^ Token -> Option 'Https -- ^ Auth 'Option' oAuth2Bearer token = asFinalizer - (attachHeader "Authorization" ("Bearer " <> token)) + (pure . attachHeader "Authorization" ("Bearer " <> token)) -- | The 'Option' adds a not-quite-standard OAuth2 bearer token (that seems -- to be used only by GitHub). This will be treated by whatever services @@ -1084,7 +1139,7 @@ :: ByteString -- ^ Token -> Option 'Https -- ^ Auth 'Option' oAuth2Token token = asFinalizer - (attachHeader "Authorization" ("token " <> token)) + (pure . attachHeader "Authorization" ("token " <> token)) ---------------------------------------------------------------------------- -- Request — Optional parameters — Other @@ -1294,7 +1349,7 @@ class HttpResponse response where - -- | The associated type is type of body that can be extracted from a + -- | The associated type is the type of body that can be extracted from a -- instance of 'HttpResponse'. type HttpResponseBody response :: * @@ -1313,9 +1368,9 @@ -- | The main class for things that are “parts” of 'L.Request' in the sense -- that if we have a 'L.Request', then we know how to apply an instance of --- 'RequestComponent' changing\/overwriting something in it. 'Endo' is --- endomorphism of functions under composition, it's used to chain different --- request component easier using @('<>')@. +-- 'RequestComponent' changing\/overwriting something in it. 'Endo' is a +-- monoid of endomorphisms under composition, it's used to chain different +-- request components easier using @('<>')@. class RequestComponent a where @@ -1329,8 +1384,8 @@ -- | This wrapper is only used to attach a type-level tag to given type. -- This is necessary to define instances of 'RequestComponent' for any thing --- that implements 'HttpMethod' or 'HttpBody'. Without the tag, GHC is not --- able to see difference between @'HttpMethod' method => 'RequestComponent' +-- that implements 'HttpMethod' or 'HttpBody'. Without the tag, GHC can't +-- see the difference between @'HttpMethod' method => 'RequestComponent' -- method@ and @'HttpBody' body => 'RequestComponent' body@ when it decides -- which instance to use (i.e. constraints are taken into account later, -- when instance is already chosen). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,6 +13,36 @@ * [Contribution](#contribution) * [License](#license) +```haskell +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main (main) where + +import Control.Exception (throwIO) +import Network.HTTP.Req +import Data.Aeson + +-- Just make your monad stack an instance of MonadHttp in your application +-- and start making requests, enjoy automatic connection sharing. + +instance MonadHttp IO where + handleHttpException = throwIO + +main :: IO () +main = do + let payload = object + [ "foo" .= (10 :: Int) + , "bar" .= (20 :: Int) ] + -- One function, full power and flexibility. + r <- req POST -- method + (https "httpbin.org" /: "post") -- safe by construction URL + (ReqBodyJson payload) -- use built-in options or add your own + jsonResponse -- specify how to interpret response + mempty -- query params, headers, explicit port number, etc. + print (responseBody r :: Value) +``` + This is an easy-to-use, type-safe, expandable, high-level HTTP library that just works without any fooling around. @@ -115,7 +145,7 @@ is not all though, because you cannot really use `get` you see in the main module, because you want to have connection sharing. Wreq's author does not take the gift of automatic connection re-use `Manager` from `http-client` -provides, it invents the whole new thing of “sessions”. Only inside a +provides, he invents the whole new thing of “sessions”. Only inside a session your connections will be shared and re-used. However with the session stuff you have yet another set of per-method functions like `get` and `getWith` — these are different ones, to be used with sessions! Now if @@ -129,10 +159,10 @@ It's funny that one client I worked for had to have his own little wrapper around `http-client` just because he could not possibly use `wreq` and -`http-client` and friends were too low-level. The previous paragraph -extracted from a talk with a Haskell developer who works for that client. -Then I thought to myself “something is wrong with HTTP client libraries in -Haskell if they had to make a wrapper”. +`http-client` and friends were too low-level. The previous paragraph is +extracted from a talk with a Haskell developer who works for that client. I +thought to myself “something is wrong with HTTP client libraries in Haskell +if they had to make a wrapper”. What else? I used `servant-client` a couple of times but amount of boilerplate is too high. If you have several query parameters, and you use @@ -174,6 +204,6 @@ ## License -Copyright © 2016 Mark Karpov +Copyright © 2016–2017 Mark Karpov Distributed under BSD 3 clause license. diff --git a/httpbin-tests/Network/HTTP/ReqSpec.hs b/httpbin-tests/Network/HTTP/ReqSpec.hs --- a/httpbin-tests/Network/HTTP/ReqSpec.hs +++ b/httpbin-tests/Network/HTTP/ReqSpec.hs @@ -2,7 +2,7 @@ -- Tests for ‘req’ package. This test suite tests sending actual requests -- using the service. -- --- Copyright © 2016 Mark Karpov +-- Copyright © 2016–2017 Mark Karpov -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are @@ -60,6 +60,7 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as TIO import qualified Network.HTTP.Client as L +import qualified Network.HTTP.Client.MultipartFormData as LM import qualified Network.HTTP.Types as Y #if !MIN_VERSION_base(4,8,0) @@ -139,6 +140,33 @@ , "Content-Length" .= show (T.length reflected) ] , "files" .= emptyObject , "form" .= emptyObject ] + responseHeader r "Content-Type" `shouldBe` return "application/json" + responseStatusCode r `shouldBe` 200 + responseStatusMessage r `shouldBe` "OK" + + describe "receiving POST data back (multipart form data)" $ + it "works" $ do + body <- reqBodyMultipart + [ LM.partBS "foo" "foo data!" + , LM.partBS "bar" "bar data!" ] + r <- req POST (httpbin /: "post") body jsonResponse mempty + let Just contentType = getRequestContentType body + stripOrigin (responseBody r) `shouldBe` object + [ "args" .= emptyObject + , "json" .= Null + , "data" .= ("" :: Text) + , "url" .= ("https://httpbin.org/post" :: Text) + , "headers" .= object + [ "Content-Type" .= T.decodeUtf8 contentType + , "Accept-Encoding" .= ("gzip" :: Text) + , "Host" .= ("httpbin.org" :: Text) + , "Content-Length" .= ("242" :: Text) + ] + , "files" .= emptyObject + , "form" .= object + [ "foo" .= ("foo data!" :: Text) + , "bar" .= ("bar data!" :: Text) ] + ] responseHeader r "Content-Type" `shouldBe` return "application/json" responseStatusCode r `shouldBe` 200 responseStatusMessage r `shouldBe` "OK" diff --git a/pure-tests/Network/HTTP/ReqSpec.hs b/pure-tests/Network/HTTP/ReqSpec.hs --- a/pure-tests/Network/HTTP/ReqSpec.hs +++ b/pure-tests/Network/HTTP/ReqSpec.hs @@ -2,7 +2,7 @@ -- Tests for ‘req’ package. This test suite tests correctness of constructed -- requests. -- --- Copyright © 2016 Mark Karpov +-- Copyright © 2016–2017 Mark Karpov -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/req.cabal b/req.cabal --- a/req.cabal +++ b/req.cabal @@ -1,7 +1,7 @@ -- -- Cabal configuration for ‘req’ package. -- --- Copyright © 2016 Mark Karpov +-- Copyright © 2016–2017 Mark Karpov -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are @@ -31,7 +31,7 @@ -- POSSIBILITY OF SUCH DAMAGE. name: req -version: 0.1.0 +version: 0.2.0 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE.md @@ -58,7 +58,8 @@ default: False library - build-depends: aeson >= 0.11 && < 1.1 + build-depends: aeson >= 0.9 && < 1.2 + , authenticate-oauth >= 1.5 && < 1.7 , base >= 4.7 && < 5.0 , blaze-builder >= 0.3 && < 0.5 , bytestring >= 0.10.8 && < 0.11 @@ -71,7 +72,7 @@ , http-types >= 0.8 && < 10.0 , mtl >= 2.0 && < 3.0 , text >= 0.2 && < 1.3 - , time >= 1.2 && < 1.7 + , time >= 1.2 && < 1.8 , transformers >= 0.4 && < 0.6 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* @@ -88,7 +89,7 @@ hs-source-dirs: pure-tests type: exitcode-stdio-1.0 build-depends: QuickCheck >= 2.7 && < 3.0 - , aeson >= 0.11 && < 1.1 + , aeson >= 0.9 && < 1.2 , base >= 4.7 && < 5.0 , blaze-builder >= 0.3 && < 0.5 , bytestring >= 0.10.8 && < 0.11 @@ -98,9 +99,9 @@ , http-client >= 0.5 && < 0.6 , http-types >= 0.8 && < 10.0 , mtl >= 2.0 && < 3.0 - , req >= 0.1.0 + , req >= 0.2.0 , text >= 0.2 && < 1.3 - , time >= 1.2 && < 1.7 + , time >= 1.2 && < 1.8 if flag(dev) ghc-options: -Wall -Werror else @@ -113,7 +114,7 @@ hs-source-dirs: httpbin-tests type: exitcode-stdio-1.0 build-depends: QuickCheck >= 2.7 && < 3.0 - , aeson >= 0.11 && < 1.1 + , aeson >= 0.9 && < 1.2 , base >= 4.7 && < 5.0 , bytestring >= 0.10.8 && < 0.11 , data-default-class @@ -121,7 +122,7 @@ , http-client >= 0.5 && < 0.6 , http-types >= 0.8 && < 10.0 , mtl >= 2.0 && < 3.0 - , req >= 0.1.0 + , req >= 0.2.0 , text >= 0.2 && < 1.3 , unordered-containers >= 0.2.5 && < 0.2.8 if flag(dev)