diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +## Req 3.0.0 + +* Dropped functions `parseUrlHttp`, `parseUrlHttps`, and `parseUrl`. Instead + we now have `useHttpURI`, `useHttpsURI`, and `useURI` take `URI`s from + `modern-uri` as their argument. You first parse your URL with the + `modern-uri` package and then pass it to those functions. This allows us + to work with typed URI representations and seamlessly convert them to + something `req` can work with. As a side effect basic auth from the `URI`s + is now taken into consideration. In the future we may also start to + respect fragments if `http-client` starts to support this. + +* Dropped support for GHC 8.2 and older. + ## Req 2.1.0 * Dropped support for GHC 7.10. diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2016–2018 Mark Karpov +Copyright © 2016–present 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–2019 Mark Karpov +-- Copyright : © 2016–present Mark Karpov -- License : BSD 3 clause -- -- Maintainer : Mark Karpov @@ -95,8 +95,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -137,9 +139,9 @@ , https , (/~) , (/:) - , parseUrlHttp - , parseUrlHttps - , parseUrl + , useHttpURI + , useHttpsURI + , useURI -- ** Body -- $body , NoReqBody (..) @@ -220,8 +222,8 @@ import Data.Data (Data) import Data.Function (on) import Data.IORef -import Data.Kind (Constraint) -import Data.List (nubBy) +import Data.Kind (Constraint, Type) +import Data.List (nubBy, foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe) import Data.Proxy @@ -231,6 +233,7 @@ import GHC.Generics import GHC.TypeLits import System.IO.Unsafe (unsafePerformIO) +import Text.URI (URI) import Web.HttpApiData (ToHttpApiData (..)) import qualified Blaze.ByteString.Builder as BB import qualified Data.Aeson as A @@ -238,15 +241,15 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Text.Read as TR 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 Text.URI as URI +import qualified Text.URI.QQ as QQ import qualified Web.Authenticate.OAuth as OAuth ---------------------------------------------------------------------------- @@ -311,6 +314,7 @@ -- > import GHC.Generics -- > import Network.HTTP.Req -- > import qualified Data.ByteString.Char8 as B +-- > import qualified Text.URI as URI -- -- We will be making requests against the service. -- @@ -369,7 +373,8 @@ -- > main = runReq defaultHttpConfig $ do -- > -- This is an example of what to do when URL is given dynamically. Of -- > -- course in a real application you may not want to use 'fromJust'. --- > let (url, options) = fromJust (parseUrlHttps "https://httpbin.org/get?foo=bar") +-- > uri <- URI.mkURI "https://httpbin.org/get?foo=bar" +-- > let (url, options) = fromJust (useHttpsURI uri) -- > response <- req GET url NoReqBody jsonResponse $ -- > "from" =: (15 :: Int) <> -- > "to" =: (67 :: Int) <> @@ -797,8 +802,7 @@ -- $url -- -- We use 'Url's which are correct by construction, see 'Url'. To build a --- 'Url' from a 'ByteString', use 'parseUrlHttp', 'parseUrlHttps', or --- generic 'parseUrl'. +-- 'Url' from a 'URI', use 'useHttpURI', 'useHttpsURI', or generic 'useURI'. -- | Request's 'Url'. Start constructing your 'Url' with 'http' or 'https' -- specifying the scheme and host at the same time. Then use the @('/~')@ @@ -853,66 +857,99 @@ Url secure path /~ segment = Url secure (NE.cons (toUrlPiece segment) path) -- | Type-constrained version of @('/~')@ to remove ambiguity in the cases --- when next URL piece is a 'Text' literal. +-- when next URL piece is a 'Data.Text.Text' literal. infixl 5 /: (/:) :: Url scheme -> Text -> Url scheme (/:) = (/~) --- | The 'parseUrlHttp' function provides an alternative method to get 'Url' --- (possibly with some 'Option's) from a 'ByteString'. This is useful when --- you are given a URL to query dynamically and don't know it beforehand. --- The function parses 'ByteString' because it's the correct type to --- represent a URL, as 'Url' cannot contain characters outside of ASCII --- range, thus we can consider every character a 'Data.Word.Word8' value. +-- | The 'useHttpURI' function provides an alternative method to get 'Url' +-- (possibly with some 'Option's) from a 'URI'. This is useful when you are +-- given a URL to query dynamically and don't know it beforehand. -- --- This function only parses 'Url' (scheme, host, path) and optional query --- parameters that are returned as 'Option'. It does not parse method name --- or authentication info from given 'ByteString'. +-- This function expects the scheme to be “http” and host to be present. -- --- This function expected scheme to be “http”. +-- @since 3.0.0 -parseUrlHttp :: ByteString -> Maybe (Url 'Http, Option scheme) -parseUrlHttp url' = do - url <- B.stripPrefix "http://" url' - (host :| path, option) <- parseUrlHelper url - return (foldl (/:) (http host) path, option) +useHttpURI :: URI -> Maybe (Url 'Http, Option scheme) +useHttpURI uri = do + guard (URI.uriScheme uri == Just [QQ.scheme|http|]) + urlHead <- http <$> uriHost uri + let url = case URI.uriPath uri of + Nothing -> urlHead + Just (_, xs) -> + foldl' (/:) urlHead (URI.unRText <$> NE.toList xs) + return (url, uriOptions uri) --- | Just like 'parseUrlHttp', but expects the “https” scheme. +-- | Just like 'useHttpURI', but expects the “https” scheme. +-- +-- @since 3.0.0 -parseUrlHttps :: ByteString -> Maybe (Url 'Https, Option scheme) -parseUrlHttps url' = do - url <- B.stripPrefix "https://" url' - (host :| path, option) <- parseUrlHelper url - return (foldl (/:) (https host) path, option) +useHttpsURI :: URI -> Maybe (Url 'Https, Option scheme) +useHttpsURI uri = do + guard (URI.uriScheme uri == Just [QQ.scheme|https|]) + urlHead <- https <$> uriHost uri + let url = case URI.uriPath uri of + Nothing -> urlHead + Just (_, xs) -> + foldl' (/:) urlHead (URI.unRText <$> NE.toList xs) + return (url, uriOptions uri) -- | A more general URI parsing function that can be used when scheme is not -- known beforehand. -- --- @since 1.2.1 +-- @since 3.0.0 -parseUrl - :: ByteString - -> Maybe (Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1)) -parseUrl url = Left <$> parseUrlHttp url <|> Right <$> parseUrlHttps url +useURI + :: URI + -> Maybe (Either (Url 'Http, Option scheme0) + (Url 'Https, Option scheme1)) +useURI uri = + (Left <$> useHttpURI uri) <|> (Right <$> useHttpsURI uri) --- | Get host\/collection of path pieces and possibly query parameters --- already converted to 'Option'. This function is not public. +-- | An internal helper function to extract host from a 'URI'. -parseUrlHelper :: ByteString -> Maybe (NonEmpty Text, Option scheme) -parseUrlHelper url = do - let (path', query') = B.break (== 0x3f) url - query = mconcat (uncurry queryParam <$> Y.parseQueryText query') - p' :| ps <- NE.nonEmpty (Y.decodePathSegments path') - (p, port') <- - case T.break (== ':') p' of - (x, "") -> return (x, mempty) - (x, prt) -> - case TR.decimal (T.drop 1 prt) of - Right (prt',"") -> return (x, port prt') - _ -> Nothing - return (p :| ps, query <> port') +uriHost :: URI -> Maybe Text +uriHost uri = case URI.uriAuthority uri of + Left _ -> Nothing + Right URI.Authority {..} -> + Just (URI.unRText authHost) +-- | An internal helper function to extract 'Option's from a 'URI'. + +uriOptions :: forall scheme. URI -> Option scheme +uriOptions uri = mconcat + [ auth + , query + , port' + -- , fragment' + ] + where + (auth, port') = + case URI.uriAuthority uri of + Left _ -> (mempty, mempty) + Right URI.Authority {..} -> + let auth0 = case authUserInfo of + Nothing -> mempty + Just URI.UserInfo {..} -> + let username = T.encodeUtf8 (URI.unRText uiUsername) + password = maybe "" (T.encodeUtf8 . URI.unRText) uiPassword + in basicAuthUnsafe username password + port0 = case authPort of + Nothing -> mempty + Just port'' -> port (fromIntegral port'') + in (auth0, port0) + query = + let liftQueryParam = \case + URI.QueryFlag t -> queryFlag (URI.unRText t) + URI.QueryParam k v -> URI.unRText k =: URI.unRText v + in mconcat (liftQueryParam <$> URI.uriQuery uri) + -- TODO Blocked on upstream: https://github.com/snoyberg/http-client/issues/424 + -- fragment' = + -- case URI.uriFragment uri of + -- Nothing -> mempty + -- Just fragment'' -> fragment (URI.unRText fragment'') + instance RequestComponent (Url scheme) where getRequestMod (Url scheme segments) = Endo $ \x -> let (host :| path) = NE.reverse segments in @@ -1616,7 +1653,7 @@ -- | The associated type is the type of body that can be extracted from an -- instance of 'HttpResponse'. - type HttpResponseBody response :: * + type HttpResponseBody response :: Type -- | The method describes how to get the underlying 'L.Response' record. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -99,13 +99,13 @@ ## Motivation and Req vs other libraries *This section is my opinion and it contains criticisms of other well-known -libraries. If you're user/fan of one of these libraries, please remember not -to react aggressively and respect the fact that I may have different views -on API design from yours.* +libraries. If you're a user/fan of one of these libraries, please remember +not to react aggressively and respect the fact that I may have different +views on API design from yours.* -I have spent time to write the library because sending HTTP requests is such -a common thing and still there is no high-level library for that in Haskell -that I could use with pleasure. I'll explain why. +I have spent time to write the library because sending HTTP requests is a +common need, but there is no high-level library for that in Haskell that I +could use with pleasure. I'll explain why. First of all, there is `http-client` and `http-client-tls`. They just work. I have no issues with the libraries except that they are too low-level for @@ -123,9 +123,9 @@ just adds `conduit`-powered functions to perform requests and allows to use global implicit `Manager` (Req does the same). If I tried to frame what exactly I don't like about `http-conduit` in words, then it would be “the -way requests are constructed”. You set, set, set instead of *being forced* -to declare necessary bits and *being allowed* to declare optional bits in a -way that their combination is certainly valid. Also, with `http-conduit` you +way requests are constructed”. You *set* parameters instead of *being +forced* to declare necessary bits and *being allowed* to declare optional +bits in a way that their combination is valid. Also, with `http-conduit` you parse request from a string without the protection of TH that otherwise saves the day as in Yesod. @@ -152,17 +152,9 @@ for sessions, but the point is that they are just too inconvenient for common tasks. -It's funny that one client I worked for had to invent 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 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 the amount of -boilerplate it requires is frightening. If you have several query -parameters, and you use just one of them, good luck passing lots of -`Nothing`s. +I used `servant-client` a couple of times but the amount of boilerplate it +requires is frightening. If you have several query parameters, and you use +just one of them, you'll have to pass lots of `Nothing`s. ## Unsolved problems @@ -205,6 +197,6 @@ ## License -Copyright © 2016–2019 Mark Karpov +Copyright © 2016–present 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 @@ -13,7 +13,6 @@ import Control.Monad.Reader import Control.Monad.Trans.Control import Data.Aeson (Value (..), ToJSON (..), object, (.=)) -import Data.Monoid ((<>)) import Data.Proxy import Data.Text (Text) import Network.HTTP.Req @@ -29,6 +28,10 @@ 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,13,0) +import Data.Semigroup ((<>)) +#endif spec :: Spec spec = do 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,8 +2,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,11 +16,12 @@ where import Control.Exception (throwIO) +import Control.Monad import Control.Retry import Data.Aeson (ToJSON (..)) import Data.ByteString (ByteString) -import Data.Maybe (isNothing, fromJust) -import Data.Monoid ((<>)) +import Data.Either (isRight) +import Data.Maybe (isNothing, fromJust, fromMaybe) import Data.Proxy import Data.Text (Text) import Data.Time @@ -27,18 +30,26 @@ import Test.Hspec import Test.Hspec.Core.Spec (SpecM) import Test.QuickCheck +import Text.URI (URI) import qualified Blaze.ByteString.Builder as BB import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.HTTP.Client as L import qualified Network.HTTP.Types as Y import qualified Network.HTTP.Types.Header as Y +import qualified Text.URI as URI +import qualified Text.URI.QQ as QQ +#if !MIN_VERSION_base(4,13,0) +import Data.Semigroup ((<>)) +#endif + spec :: Spec spec = do @@ -101,67 +112,70 @@ request <- req_ GET url' NoReqBody mempty L.host request `shouldBe` urlEncode host L.path request `shouldBe` encodePathPieces pieces - describe "parseUrlHttp" $ do + + describe "useHttpURI" $ do it "does not recognize non-http schemes" $ - parseUrlHttp "https://httpbin.org" `shouldSatisfy` isNothing - it "parses correct URLs" $ - property $ \host mport' pieces queryParams -> do - let (url', path, queryString) = - assembleUrl Http host mport' pieces queryParams - (url'', options) = fromJust (parseUrlHttp url') - request <- req_ GET url'' NoReqBody options - L.host request `shouldBe` urlEncode (unHost host) - L.port request `shouldBe` maybe 80 getNonNegative mport' - L.path request `shouldBe` path - L.queryString request `shouldBe` queryString - it "rejects gibberish in port component" $ do - parseUrlHttp "http://my-site.com:bob/far" `shouldSatisfy` isNothing - parseUrlHttp "http://my-site.com:7001uh/api" `shouldSatisfy` isNothing - parseUrlHttp "http://my-site.com:/bar" `shouldSatisfy` isNothing - describe "parseUrlHttps" $ do + property $ \uri -> + when (URI.uriScheme uri /= Just [QQ.scheme|http|]) $ + useHttpURI uri `shouldSatisfy` isNothing + it "accepts correct URLs" $ + property $ \uri' -> do + unless (isRight (URI.uriAuthority uri')) discard + let uri = uri' { URI.uriScheme = Just [QQ.scheme|http|] } + (url', options) = fromJust (useHttpURI uri) + request <- req_ GET url' NoReqBody options + L.host request `shouldBe` uriHost uri + L.port request `shouldBe` uriPort 80 uri + L.path request `shouldBe` uriPath uri + L.queryString request `shouldBe` uriQuery uri + lookup "Authorization" (L.requestHeaders request) + `shouldBe` uriBasicAuth uri + describe "useHttpsURI" $ do it "does not recognize non-https schemes" $ - parseUrlHttps "http://httpbin.org" `shouldSatisfy` isNothing + property $ \uri -> + when (URI.uriScheme uri /= Just [QQ.scheme|https|]) $ + useHttpsURI uri `shouldSatisfy` isNothing it "parses correct URLs" $ - property $ \host mport' pieces queryParams -> do - let (url', path, queryString) = - assembleUrl Https host mport' pieces queryParams - (url'', options) = fromJust (parseUrlHttps url') - request <- req_ GET url'' NoReqBody options - L.host request `shouldBe` urlEncode (unHost host) - L.port request `shouldBe` maybe 443 getNonNegative mport' - L.path request `shouldBe` path - L.queryString request `shouldBe` queryString - it "rejects gibberish in port component" $ do - parseUrlHttp "https://my-site.com:bob/far" `shouldSatisfy` isNothing - parseUrlHttp "https://my-site.com:7001uh/api" `shouldSatisfy` isNothing - parseUrlHttp "https://my-site.com:/bar" `shouldSatisfy` isNothing - describe "parseUrl" $ do + property $ \uri' -> do + unless (isRight (URI.uriAuthority uri')) discard + let uri = uri' { URI.uriScheme = Just [QQ.scheme|https|] } + (url', options) = fromJust (useHttpsURI uri) + request <- req_ GET url' NoReqBody options + L.host request `shouldBe` uriHost uri + L.port request `shouldBe` uriPort 443 uri + L.path request `shouldBe` uriPath uri + L.queryString request `shouldBe` uriQuery uri + lookup "Authorization" (L.requestHeaders request) + `shouldBe` uriBasicAuth uri + describe "useURI" $ do it "does not recognize non-http and non-https schemes" $ - parseUrl "ftp://httpbin.org" `shouldSatisfy` isNothing - it "parses correct http URLs" $ - property $ \host mport' pieces queryParams -> do - let (url', path, queryString) = - assembleUrl Http host mport' pieces queryParams - Left (url'', options) = fromJust (parseUrl url') - request <- req_ GET url'' NoReqBody options - L.host request `shouldBe` urlEncode (unHost host) - L.port request `shouldBe` maybe 80 getNonNegative mport' - L.path request `shouldBe` path - L.queryString request `shouldBe` queryString - it "parses correct https URLs" $ - property $ \host mport' pieces queryParams -> do - let (url', path, queryString) = - assembleUrl Https host mport' pieces queryParams - Right (url'', options) = fromJust (parseUrl url') - request <- req_ GET url'' NoReqBody options - L.host request `shouldBe` urlEncode (unHost host) - L.port request `shouldBe` maybe 443 getNonNegative mport' - L.path request `shouldBe` path - L.queryString request `shouldBe` queryString - it "rejects gibberish in port component" $ do - parseUrl "http://my-site.com:bob/far" `shouldSatisfy` isNothing - parseUrl "https://my-site.com:7001uh/api" `shouldSatisfy` isNothing - parseUrl "http://my-site.com:/bar" `shouldSatisfy` isNothing + property $ \uri -> + when ((URI.uriScheme uri /= Just [QQ.scheme|http|] && + (URI.uriScheme uri /= Just [QQ.scheme|https|]))) $ + useURI uri `shouldSatisfy` isNothing + it "parses correct URLs" $ + property $ \uri' -> do + unless (isRight (URI.uriAuthority uri')) discard + let uriHttp = uri' { URI.uriScheme = Just [QQ.scheme|http|] } + uriHttps = uri' { URI.uriScheme = Just [QQ.scheme|https|] } + requestHttp <- + let Left (url', options) = fromJust (useURI uriHttp) + in req_ GET url' NoReqBody options + requestHttps <- + let Right (url', options) = fromJust (useURI uriHttps) + in req_ GET url' NoReqBody options + L.host requestHttp `shouldBe` uriHost uriHttp + L.host requestHttps `shouldBe` uriHost uriHttps + L.port requestHttp `shouldBe` uriPort 80 uriHttp + L.port requestHttps `shouldBe` uriPort 443 uriHttps + L.path requestHttp `shouldBe` uriPath uriHttp + L.path requestHttps `shouldBe` uriPath uriHttps + L.queryString requestHttp `shouldBe` uriQuery uriHttp + L.queryString requestHttps `shouldBe` uriQuery uriHttps + lookup "Authorization" (L.requestHeaders requestHttp) + `shouldBe` uriBasicAuth uriHttp + lookup "Authorization" (L.requestHeaders requestHttps) + `shouldBe` uriBasicAuth uriHttps describe "bodies" $ do describe "NoReqBody" $ @@ -225,24 +239,22 @@ property $ \username password -> do request <- req_ GET url NoReqBody (basicAuth username password) lookup "Authorization" (L.requestHeaders request) `shouldBe` - pure (basicAuthHeader username password) + Just (basicAuthHeader username password) it "overwrites manual setting of header" $ property $ \username password value -> do request0 <- req_ GET url NoReqBody (basicAuth username password <> header "Authorization" value) request1 <- req_ GET url NoReqBody (header "Authorization" value <> basicAuth username password) - let result = basicAuthHeader username password - lookup "Authorization" (L.requestHeaders request0) `shouldBe` - pure result - lookup "Authorization" (L.requestHeaders request1) `shouldBe` - pure result + let result = Just (basicAuthHeader username password) + lookup "Authorization" (L.requestHeaders request0) `shouldBe` result + lookup "Authorization" (L.requestHeaders request1) `shouldBe` result it "left auth option wins" $ property $ \username0 password0 username1 password1 -> do request <- req_ GET url NoReqBody (basicAuth username0 password0 <> basicAuth username1 password1) lookup "Authorization" (L.requestHeaders request) `shouldBe` - pure (basicAuthHeader username0 password0) + Just (basicAuthHeader username0 password0) describe "oAuth2Bearer" $ do it "sets Authorization header to correct value" $ property $ \token -> do @@ -444,28 +456,47 @@ encodePathPieces :: [Text] -> ByteString encodePathPieces = BL.toStrict . BB.toLazyByteString . Y.encodePathSegments --- | Assemble a URL. +-- | Get host from a 'URI'. This function is not total. -assembleUrl - :: Scheme -- ^ Scheme - -> Host -- ^ Host - -> Maybe (NonNegative Int) -- ^ Port - -> [Text] -- ^ Path pieces - -> QueryParams -- ^ Query parameters - -> (ByteString, ByteString, ByteString) -- ^ URL, path, query string -assembleUrl scheme' (Host host') mport' pathPieces (QueryParams queryParams) = - (scheme <> host <> port' <> path <> queryString, path, queryString) - where - scheme = case scheme' of - Http -> "http://" - Https -> "https://" - host = urlEncode host' - port' = - case mport' of - Nothing -> "" - Just (NonNegative x) -> ":" <> B8.pack (show x) - path = encodePathPieces pathPieces - queryString = Y.renderQuery True (Y.queryTextToQuery queryParams) +uriHost :: URI -> ByteString +uriHost uri = fromJust $ + urlEncode . URI.unRText . URI.authHost + <$> either (const Nothing) Just (URI.uriAuthority uri) + +-- | Get part from a 'URI' defaulting to the provided value. + +uriPort :: Int -> URI -> Int +uriPort def uri = maybe def (fromIntegral) $ + either (const Nothing) Just (URI.uriAuthority uri) >>= URI.authPort + +-- | Get path from 'URI'. + +uriPath :: URI -> ByteString +uriPath uri = fromMaybe "" $ do + (_, xs) <- URI.uriPath uri + (return . encodePathPieces . fmap URI.unRText . NE.toList) xs + +-- | Get query string from 'URI'. + +uriQuery :: URI -> ByteString +uriQuery uri = do + let liftQueryParam = \case + URI.QueryFlag t -> (URI.unRText t, Nothing) + URI.QueryParam k v -> (URI.unRText k, Just (URI.unRText v)) + Y.renderQuery True (Y.queryTextToQuery (liftQueryParam <$> (URI.uriQuery uri))) + +-- | Predict the headrs that should be set if the given 'URI' has username +-- and password in it. + +uriBasicAuth :: URI -> Maybe ByteString +uriBasicAuth uri = do + auth <- either (const Nothing) Just (URI.uriAuthority uri) + URI.UserInfo {..} <- URI.authUserInfo auth + let username = T.encodeUtf8 (URI.unRText uiUsername) + password = maybe "" (T.encodeUtf8 . URI.unRText) uiPassword + return (basicAuthHeader username password) + +-- | Render a query as lazy 'BL.ByteString'. renderQuery :: [(Text, Maybe Text)] -> BL.ByteString renderQuery = BL.fromStrict . Y.renderQuery False . Y.queryTextToQuery diff --git a/req.cabal b/req.cabal --- a/req.cabal +++ b/req.cabal @@ -1,7 +1,7 @@ name: req -version: 2.1.0 +version: 3.0.0 cabal-version: 1.18 -tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 +tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 license: BSD3 license-file: LICENSE.md author: Mark Karpov @@ -29,7 +29,7 @@ library build-depends: aeson >= 0.9 && < 1.5 , authenticate-oauth >= 1.5 && < 1.7 - , base >= 4.9 && < 5.0 + , base >= 4.11 && < 5.0 , blaze-builder >= 0.3 && < 0.5 , bytestring >= 0.10.8 && < 0.11 , case-insensitive >= 0.2 && < 1.3 @@ -38,11 +38,12 @@ , http-client >= 0.5 && < 0.7 , http-client-tls >= 0.3.2 && < 0.4 , http-types >= 0.8 && < 10.0 + , modern-uri >= 0.3 && < 0.4 , monad-control >= 1.0 && < 1.1 , mtl >= 2.0 && < 3.0 , retry >= 0.8 && < 0.9 , text >= 0.2 && < 1.3 - , time >= 1.2 && < 1.9 + , time >= 1.2 && < 1.10 , transformers >= 0.4 && < 0.6 , transformers-base exposed-modules: Network.HTTP.Req @@ -55,7 +56,6 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances default-language: Haskell2010 test-suite pure-tests @@ -65,7 +65,7 @@ type: exitcode-stdio-1.0 build-depends: QuickCheck >= 2.7 && < 3.0 , aeson >= 0.9 && < 1.5 - , base >= 4.9 && < 5.0 + , base >= 4.11 && < 5.0 , blaze-builder >= 0.3 && < 0.5 , bytestring >= 0.10.8 && < 0.11 , case-insensitive >= 0.2 && < 1.3 @@ -73,11 +73,12 @@ , hspec-core >= 2.0 && < 3.0 , http-client >= 0.5 && < 0.7 , http-types >= 0.8 && < 10.0 + , modern-uri >= 0.3 && < 0.4 , mtl >= 2.0 && < 3.0 , req , retry >= 0.8 && < 0.9 , text >= 0.2 && < 1.3 - , time >= 1.2 && < 1.9 + , time >= 1.2 && < 1.10 build-tools: hspec-discover >= 2.0 && < 3.0 if flag(dev) ghc-options: -O0 -Wall -Werror @@ -92,7 +93,7 @@ type: exitcode-stdio-1.0 build-depends: QuickCheck >= 2.7 && < 3.0 , aeson >= 0.9 && < 1.5 - , base >= 4.9 && < 5.0 + , base >= 4.11 && < 5.0 , bytestring >= 0.10.8 && < 0.11 , hspec >= 2.0 && < 3.0 , http-client >= 0.5 && < 0.7