f8f6d14 · typeable/req

git.iko.soy/typeable/req

on master help sign in

Use ‘modern-uri’ for URL parsing

f8f6d14mrkkrp7 years ago

CHANGELOG.md+10−1

compare with master

unifiedsplit

@@ -1,4 +1,13 @@

1−## Unreleased

1+## Req 3.0.0

3+* Dropped functions `parseUrlHttp`, `parseUrlHttps`, and `parseUrl`. Instead

4+ we now have `useHttpURI`, `useHttpsURI`, and `useURI` take `URI`s from

5+ `modern-uri` as their argument. You first parse your URL with the

6+ `modern-uri` package and then pass it to those functions. This allows us

7+ to work with typed URI representations and seamlessly convert them to

8+ something `req` can work with. As a side effect basic auth from the `URI`s

9+ is now taken into consideration. In the future we may also start to

10+ respect fragments if `http-client` starts to support this.

3* Dropped support for GHC 8.2 and older.

12* Dropped support for GHC 8.2 and older.

Network/HTTP/Req.hs+90−53

@@ -95,8 +95,10 @@

95{-# LANGUAGE FlexibleInstances #-}

96{-# LANGUAGE GeneralizedNewtypeDeriving #-}

97{-# LANGUAGE KindSignatures #-}

98+{-# LANGUAGE LambdaCase #-}

98{-# LANGUAGE MultiParamTypeClasses #-}

99{-# LANGUAGE MultiParamTypeClasses #-}

99{-# LANGUAGE OverloadedStrings #-}

100{-# LANGUAGE OverloadedStrings #-}

101+{-# LANGUAGE QuasiQuotes #-}

100{-# LANGUAGE RankNTypes #-}

102{-# LANGUAGE RankNTypes #-}

101{-# LANGUAGE RecordWildCards #-}

103{-# LANGUAGE RecordWildCards #-}

102{-# LANGUAGE ScopedTypeVariables #-}

104{-# LANGUAGE ScopedTypeVariables #-}

@@ -137,9 +139,9 @@ module Network.HTTP.Req

137 , https

139 , https

138 , (/~)

140 , (/~)

139 , (/:)

141 , (/:)

140− , parseUrlHttp

142+ , useHttpURI

141− , parseUrlHttps

143+ , useHttpsURI

142− , parseUrl

144+ , useURI

143 -- ** Body

145 -- ** Body

144 -- $body

146 -- $body

145 , NoReqBody (..)

147 , NoReqBody (..)

@@ -221,7 +223,7 @@ import Data.Data (Data)

221import Data.Function (on)

223import Data.Function (on)

222import Data.IORef

224import Data.IORef

223import Data.Kind (Constraint, Type)

225import Data.Kind (Constraint, Type)

224−import Data.List (nubBy)

226+import Data.List (nubBy, foldl')

225import Data.List.NonEmpty (NonEmpty (..))

227import Data.List.NonEmpty (NonEmpty (..))

226import Data.Maybe (fromMaybe)

228import Data.Maybe (fromMaybe)

227import Data.Proxy

229import Data.Proxy

@@ -231,6 +233,7 @@ import Data.Typeable (Typeable)

231import GHC.Generics

233import GHC.Generics

232import GHC.TypeLits

234import GHC.TypeLits

233import System.IO.Unsafe (unsafePerformIO)

235import System.IO.Unsafe (unsafePerformIO)

236+import Text.URI (URI)

234import Web.HttpApiData (ToHttpApiData (..))

237import Web.HttpApiData (ToHttpApiData (..))

235import qualified Blaze.ByteString.Builder as BB

238import qualified Blaze.ByteString.Builder as BB

236import qualified Data.Aeson as A

239import qualified Data.Aeson as A

@@ -238,15 +241,15 @@ import qualified Data.ByteString as B

238import qualified Data.ByteString.Lazy as BL

241import qualified Data.ByteString.Lazy as BL

239import qualified Data.CaseInsensitive as CI

242import qualified Data.CaseInsensitive as CI

240import qualified Data.List.NonEmpty as NE

243import qualified Data.List.NonEmpty as NE

241−import qualified Data.Text as T

242import qualified Data.Text.Encoding as T

244import qualified Data.Text.Encoding as T

243−import qualified Data.Text.Read as TR

244import qualified Network.Connection as NC

245import qualified Network.Connection as NC

245import qualified Network.HTTP.Client as L

246import qualified Network.HTTP.Client as L

246import qualified Network.HTTP.Client.Internal as LI

247import qualified Network.HTTP.Client.Internal as LI

247import qualified Network.HTTP.Client.MultipartFormData as LM

248import qualified Network.HTTP.Client.MultipartFormData as LM

248import qualified Network.HTTP.Client.TLS as L

249import qualified Network.HTTP.Client.TLS as L

249import qualified Network.HTTP.Types as Y

250import qualified Network.HTTP.Types as Y

251+import qualified Text.URI as URI

252+import qualified Text.URI.QQ as QQ

250import qualified Web.Authenticate.OAuth as OAuth

253import qualified Web.Authenticate.OAuth as OAuth

251

254

252----------------------------------------------------------------------------

255----------------------------------------------------------------------------

@@ -311,6 +314,7 @@ import qualified Web.Authenticate.OAuth as OAuth

311-- > import GHC.Generics

314-- > import GHC.Generics

312-- > import Network.HTTP.Req

315-- > import Network.HTTP.Req

313-- > import qualified Data.ByteString.Char8 as B

316-- > import qualified Data.ByteString.Char8 as B

317+-- > import qualified Text.URI as URI

314--

318--

315-- We will be making requests against the <https://httpbin.org> service.

319-- We will be making requests against the <https://httpbin.org> service.

316--

320--

@@ -369,7 +373,8 @@ import qualified Web.Authenticate.OAuth as OAuth

369-- > main = runReq defaultHttpConfig $ do

373-- > main = runReq defaultHttpConfig $ do

370-- > -- This is an example of what to do when URL is given dynamically. Of

374-- > -- This is an example of what to do when URL is given dynamically. Of

371-- > -- course in a real application you may not want to use 'fromJust'.

375-- > -- course in a real application you may not want to use 'fromJust'.

372−-- > let (url, options) = fromJust (parseUrlHttps "https://httpbin.org/get?foo=bar")

376+-- > uri <- URI.mkURI "https://httpbin.org/get?foo=bar"

377+-- > let (url, options) = fromJust (useHttpsURI uri)

373-- > response <- req GET url NoReqBody jsonResponse $

378-- > response <- req GET url NoReqBody jsonResponse $

374-- > "from" =: (15 :: Int) <>

379-- > "from" =: (15 :: Int) <>

375-- > "to" =: (67 :: Int) <>

380-- > "to" =: (67 :: Int) <>

@@ -797,8 +802,7 @@ instance HttpMethod method => RequestComponent (Womb "method" method) where

797-- $url

802-- $url

798--

803--

799-- We use 'Url's which are correct by construction, see 'Url'. To build a

804-- We use 'Url's which are correct by construction, see 'Url'. To build a

800−-- 'Url' from a 'ByteString', use 'parseUrlHttp', 'parseUrlHttps', or

805+-- 'Url' from a 'URI', use 'useHttpURI', 'useHttpsURI', or generic 'useURI'.

801−-- generic 'parseUrl'.

802

806

803-- | Request's 'Url'. Start constructing your 'Url' with 'http' or 'https'

807-- | Request's 'Url'. Start constructing your 'Url' with 'http' or 'https'

804-- specifying the scheme and host at the same time. Then use the @('/~')@

808-- specifying the scheme and host at the same time. Then use the @('/~')@

@@ -859,59 +863,92 @@ infixl 5 /:

859(/:) :: Url scheme -> Text -> Url scheme

863(/:) :: Url scheme -> Text -> Url scheme

860(/:) = (/~)

864(/:) = (/~)

861

865

862−-- | The 'parseUrlHttp' function provides an alternative method to get 'Url'

866+-- | The 'useHttpURI' function provides an alternative method to get 'Url'

863−-- (possibly with some 'Option's) from a 'ByteString'. This is useful when

867+-- (possibly with some 'Option's) from a 'URI'. This is useful when you are

864−-- you are given a URL to query dynamically and don't know it beforehand.

868+-- given a URL to query dynamically and don't know it beforehand.

865−-- The function parses 'ByteString' because it's the correct type to

866−-- represent a URL, as 'Url' cannot contain characters outside of ASCII

867−-- range, thus we can consider every character a 'Data.Word.Word8' value.

868--

869--

869−-- This function only parses 'Url' (scheme, host, path) and optional query

870+-- This function expects the scheme to be “http” and host to be present.

870−-- parameters that are returned as 'Option'. It does not parse method name

871−-- or authentication info from given 'ByteString'.

872--

871--

873−-- This function expected scheme to be “http”.

872+-- @since 3.0.0

874

873

875−parseUrlHttp :: ByteString -> Maybe (Url 'Http, Option scheme)

874+useHttpURI :: URI -> Maybe (Url 'Http, Option scheme)

876−parseUrlHttp url' = do

875+useHttpURI uri = do

877− url <- B.stripPrefix "http://" url'

876+ guard (URI.uriScheme uri == Just [QQ.scheme|http|])

878− (host :| path, option) <- parseUrlHelper url

877+ urlHead <- http <$> uriHost uri

879− return (foldl (/:) (http host) path, option)

878+ let url = case URI.uriPath uri of

879+ Nothing -> urlHead

880+ Just (_, xs) ->

881+ foldl' (/:) urlHead (URI.unRText <$> NE.toList xs)

882+ return (url, uriOptions uri)

880

883

881−-- | Just like 'parseUrlHttp', but expects the “https” scheme.

884+-- | Just like 'useHttpURI', but expects the “https” scheme.

885+--

886+-- @since 3.0.0

882

887

883−parseUrlHttps :: ByteString -> Maybe (Url 'Https, Option scheme)

888+useHttpsURI :: URI -> Maybe (Url 'Https, Option scheme)

884−parseUrlHttps url' = do

889+useHttpsURI uri = do

885− url <- B.stripPrefix "https://" url'

890+ guard (URI.uriScheme uri == Just [QQ.scheme|https|])

886− (host :| path, option) <- parseUrlHelper url

891+ urlHead <- https <$> uriHost uri

887− return (foldl (/:) (https host) path, option)

892+ let url = case URI.uriPath uri of

893+ Nothing -> urlHead

894+ Just (_, xs) ->

895+ foldl' (/:) urlHead (URI.unRText <$> NE.toList xs)

896+ return (url, uriOptions uri)

888

897

889-- | A more general URI parsing function that can be used when scheme is not

898-- | A more general URI parsing function that can be used when scheme is not

890-- known beforehand.

899-- known beforehand.

891--

900--

892−-- @since 1.2.1

901+-- @since 3.0.0

893−

902+

894−parseUrl

903+useURI

895− :: ByteString

904+ :: URI

896− -> Maybe (Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))

905+ -> Maybe (Either (Url 'Http, Option scheme0)

897−parseUrl url = Left <$> parseUrlHttp url <|> Right <$> parseUrlHttps url

906+ (Url 'Https, Option scheme1))

898−

907+useURI uri =

899−-- | Get host\/collection of path pieces and possibly query parameters

908+ (Left <$> useHttpURI uri) <|> (Right <$> useHttpsURI uri)

900−-- already converted to 'Option'. This function is not public.

909+

901−

910+-- | An internal helper function to extract host from a 'URI'.

902−parseUrlHelper :: ByteString -> Maybe (NonEmpty Text, Option scheme)

911+

903−parseUrlHelper url = do

912+uriHost :: URI -> Maybe Text

904− let (path', query') = B.break (== 0x3f) url

913+uriHost uri = case URI.uriAuthority uri of

905− query = mconcat (uncurry queryParam <$> Y.parseQueryText query')

914+ Left _ -> Nothing

906− p' :| ps <- NE.nonEmpty (Y.decodePathSegments path')

915+ Right URI.Authority {..} ->

907− (p, port') <-

916+ Just (URI.unRText authHost)

908− case T.break (== ':') p' of

917+

909− (x, "") -> return (x, mempty)

918+-- | An internal helper function to extract 'Option's from a 'URI'.

910− (x, prt) ->

919+

911− case TR.decimal (T.drop 1 prt) of

920+uriOptions :: forall scheme. URI -> Option scheme

912− Right (prt',"") -> return (x, port prt')

921+uriOptions uri = mconcat

913− _ -> Nothing

922+ [ auth

914− return (p :| ps, query <> port')

923+ , query

924+ , port'

925+ -- , fragment'

926+ ]

927+ where

928+ (auth, port') =

929+ case URI.uriAuthority uri of

930+ Left _ -> (mempty, mempty)

931+ Right URI.Authority {..} ->

932+ let auth0 = case authUserInfo of

933+ Nothing -> mempty

934+ Just URI.UserInfo {..} ->

935+ let username = T.encodeUtf8 (URI.unRText uiUsername)

936+ password = maybe "" (T.encodeUtf8 . URI.unRText) uiPassword

937+ in basicAuthUnsafe username password

938+ port0 = case authPort of

939+ Nothing -> mempty

940+ Just port'' -> port (fromIntegral port'')

941+ in (auth0, port0)

942+ query =

943+ let liftQueryParam = \case

944+ URI.QueryFlag t -> queryFlag (URI.unRText t)

945+ URI.QueryParam k v -> URI.unRText k =: URI.unRText v

946+ in mconcat (liftQueryParam <$> URI.uriQuery uri)

947+ -- TODO Blocked on upstream: https://github.com/snoyberg/http-client/issues/424

948+ -- fragment' =

949+ -- case URI.uriFragment uri of

950+ -- Nothing -> mempty

951+ -- Just fragment'' -> fragment (URI.unRText fragment'')

915

952

916instance RequestComponent (Url scheme) where

953instance RequestComponent (Url scheme) where

917 getRequestMod (Url scheme segments) = Endo $ \x ->

954 getRequestMod (Url scheme segments) = Endo $ \x ->

pure-tests/Network/HTTP/ReqSpec.hs+115−87

@@ -2,8 +2,10 @@

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE NoMonomorphismRestriction #-}

6{-# LANGUAGE NoMonomorphismRestriction #-}

6{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE QuasiQuotes #-}

7{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE RecordWildCards #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

@@ -14,10 +16,12 @@ module Network.HTTP.ReqSpec

14where

16where

16import Control.Exception (throwIO)

18import Control.Exception (throwIO)

19+import Control.Monad

17import Control.Retry

20import Control.Retry

18import Data.Aeson (ToJSON (..))

21import Data.Aeson (ToJSON (..))

19import Data.ByteString (ByteString)

22import Data.ByteString (ByteString)

23+import Data.Either (isRight)

20−import Data.Maybe (isNothing, fromJust)

24+import Data.Maybe (isNothing, fromJust, fromMaybe)

21import Data.Proxy

25import Data.Proxy

22import Data.Text (Text)

26import Data.Text (Text)

23import Data.Time

27import Data.Time

@@ -26,17 +30,21 @@ import Network.HTTP.Req

26import Test.Hspec

30import Test.Hspec

27import Test.Hspec.Core.Spec (SpecM)

31import Test.Hspec.Core.Spec (SpecM)

28import Test.QuickCheck

32import Test.QuickCheck

33+import Text.URI (URI)

29import qualified Blaze.ByteString.Builder as BB

34import qualified Blaze.ByteString.Builder as BB

30import qualified Data.Aeson as A

35import qualified Data.Aeson as A

31import qualified Data.ByteString as B

36import qualified Data.ByteString as B

32import qualified Data.ByteString.Char8 as B8

37import qualified Data.ByteString.Char8 as B8

33import qualified Data.ByteString.Lazy as BL

38import qualified Data.ByteString.Lazy as BL

34import qualified Data.CaseInsensitive as CI

39import qualified Data.CaseInsensitive as CI

40+import qualified Data.List.NonEmpty as NE

35import qualified Data.Text as T

41import qualified Data.Text as T

36import qualified Data.Text.Encoding as T

42import qualified Data.Text.Encoding as T

37import qualified Network.HTTP.Client as L

43import qualified Network.HTTP.Client as L

38import qualified Network.HTTP.Types as Y

44import qualified Network.HTTP.Types as Y

39import qualified Network.HTTP.Types.Header as Y

45import qualified Network.HTTP.Types.Header as Y

46+import qualified Text.URI as URI

47+import qualified Text.URI.QQ as QQ

41#if !MIN_VERSION_base(4,13,0)

49#if !MIN_VERSION_base(4,13,0)

42import Data.Semigroup ((<>))

50import Data.Semigroup ((<>))

@@ -104,67 +112,70 @@ spec = do

104 request <- req_ GET url' NoReqBody mempty

112 request <- req_ GET url' NoReqBody mempty

105 L.host request `shouldBe` urlEncode host

113 L.host request `shouldBe` urlEncode host

106 L.path request `shouldBe` encodePathPieces pieces

114 L.path request `shouldBe` encodePathPieces pieces

115+

107− describe "parseUrlHttp" $ do

116+ describe "useHttpURI" $ do

108 it "does not recognize non-http schemes" $

117 it "does not recognize non-http schemes" $

118+ property $ \uri ->

119+ when (URI.uriScheme uri /= Just [QQ.scheme|http|]) $

109− parseUrlHttp "https://httpbin.org" `shouldSatisfy` isNothing

120+ useHttpURI uri `shouldSatisfy` isNothing

110− it "parses correct URLs" $

121+ it "accepts correct URLs" $

111− property $ \host mport' pieces queryParams -> do

122+ property $ \uri' -> do

112− let (url', path, queryString) =

123+ unless (isRight (URI.uriAuthority uri')) discard

113− assembleUrl Http host mport' pieces queryParams

124+ let uri = uri' { URI.uriScheme = Just [QQ.scheme|http|] }

114− (url'', options) = fromJust (parseUrlHttp url')

125+ (url', options) = fromJust (useHttpURI uri)

115− request <- req_ GET url'' NoReqBody options

126+ request <- req_ GET url' NoReqBody options

116− L.host request `shouldBe` urlEncode (unHost host)

127+ L.host request `shouldBe` uriHost uri

117− L.port request `shouldBe` maybe 80 getNonNegative mport'

128+ L.port request `shouldBe` uriPort 80 uri

118− L.path request `shouldBe` path

129+ L.path request `shouldBe` uriPath uri

119− L.queryString request `shouldBe` queryString

130+ L.queryString request `shouldBe` uriQuery uri

120− it "rejects gibberish in port component" $ do

131+ lookup "Authorization" (L.requestHeaders request)

121− parseUrlHttp "http://my-site.com:bob/far" `shouldSatisfy` isNothing

132+ `shouldBe` uriBasicAuth uri

122− parseUrlHttp "http://my-site.com:7001uh/api" `shouldSatisfy` isNothing

123− parseUrlHttp "http://my-site.com:/bar" `shouldSatisfy` isNothing

124− describe "parseUrlHttps" $ do

133+ describe "useHttpsURI" $ do

125 it "does not recognize non-https schemes" $

134 it "does not recognize non-https schemes" $

135+ property $ \uri ->

136+ when (URI.uriScheme uri /= Just [QQ.scheme|https|]) $

126− parseUrlHttps "http://httpbin.org" `shouldSatisfy` isNothing

137+ useHttpsURI uri `shouldSatisfy` isNothing

127 it "parses correct URLs" $

138 it "parses correct URLs" $

128− property $ \host mport' pieces queryParams -> do

139+ property $ \uri' -> do

129− let (url', path, queryString) =

140+ unless (isRight (URI.uriAuthority uri')) discard

130− assembleUrl Https host mport' pieces queryParams

141+ let uri = uri' { URI.uriScheme = Just [QQ.scheme|https|] }

131− (url'', options) = fromJust (parseUrlHttps url')

142+ (url', options) = fromJust (useHttpsURI uri)

132− request <- req_ GET url'' NoReqBody options

143+ request <- req_ GET url' NoReqBody options

133− L.host request `shouldBe` urlEncode (unHost host)

144+ L.host request `shouldBe` uriHost uri

134− L.port request `shouldBe` maybe 443 getNonNegative mport'

145+ L.port request `shouldBe` uriPort 443 uri

135− L.path request `shouldBe` path

146+ L.path request `shouldBe` uriPath uri

136− L.queryString request `shouldBe` queryString

147+ L.queryString request `shouldBe` uriQuery uri

137− it "rejects gibberish in port component" $ do

148+ lookup "Authorization" (L.requestHeaders request)

138− parseUrlHttp "https://my-site.com:bob/far" `shouldSatisfy` isNothing

149+ `shouldBe` uriBasicAuth uri

139− parseUrlHttp "https://my-site.com:7001uh/api" `shouldSatisfy` isNothing

140− parseUrlHttp "https://my-site.com:/bar" `shouldSatisfy` isNothing

141− describe "parseUrl" $ do

150+ describe "useURI" $ do

142 it "does not recognize non-http and non-https schemes" $

151 it "does not recognize non-http and non-https schemes" $

152+ property $ \uri ->

153+ when ((URI.uriScheme uri /= Just [QQ.scheme|http|] &&

154+ (URI.uriScheme uri /= Just [QQ.scheme|https|]))) $

143− parseUrl "ftp://httpbin.org" `shouldSatisfy` isNothing

155+ useURI uri `shouldSatisfy` isNothing

144− it "parses correct http URLs" $

156+ it "parses correct URLs" $

145− property $ \host mport' pieces queryParams -> do

157+ property $ \uri' -> do

146− let (url', path, queryString) =

158+ unless (isRight (URI.uriAuthority uri')) discard

147− assembleUrl Http host mport' pieces queryParams

159+ let uriHttp = uri' { URI.uriScheme = Just [QQ.scheme|http|] }

160+ uriHttps = uri' { URI.uriScheme = Just [QQ.scheme|https|] }

161+ requestHttp <-

148− Left (url'', options) = fromJust (parseUrl url')

162+ let Left (url', options) = fromJust (useURI uriHttp)

163+ in req_ GET url' NoReqBody options

164+ requestHttps <-

165+ let Right (url', options) = fromJust (useURI uriHttps)

149− request <- req_ GET url'' NoReqBody options

166+ in req_ GET url' NoReqBody options

150− L.host request `shouldBe` urlEncode (unHost host)

167+ L.host requestHttp `shouldBe` uriHost uriHttp

151− L.port request `shouldBe` maybe 80 getNonNegative mport'

168+ L.host requestHttps `shouldBe` uriHost uriHttps

152− L.path request `shouldBe` path

169+ L.port requestHttp `shouldBe` uriPort 80 uriHttp

153− L.queryString request `shouldBe` queryString

170+ L.port requestHttps `shouldBe` uriPort 443 uriHttps

154− it "parses correct https URLs" $

155− property $ \host mport' pieces queryParams -> do

156− let (url', path, queryString) =

157− assembleUrl Https host mport' pieces queryParams

158− Right (url'', options) = fromJust (parseUrl url')

159− request <- req_ GET url'' NoReqBody options

160− L.host request `shouldBe` urlEncode (unHost host)

161− L.port request `shouldBe` maybe 443 getNonNegative mport'

162− L.path request `shouldBe` path

171+ L.path requestHttp `shouldBe` uriPath uriHttp

163− L.queryString request `shouldBe` queryString

172+ L.path requestHttps `shouldBe` uriPath uriHttps

164− it "rejects gibberish in port component" $ do

173+ L.queryString requestHttp `shouldBe` uriQuery uriHttp

165− parseUrl "http://my-site.com:bob/far" `shouldSatisfy` isNothing

174+ L.queryString requestHttps `shouldBe` uriQuery uriHttps

166− parseUrl "https://my-site.com:7001uh/api" `shouldSatisfy` isNothing

175+ lookup "Authorization" (L.requestHeaders requestHttp)

167− parseUrl "http://my-site.com:/bar" `shouldSatisfy` isNothing

176+ `shouldBe` uriBasicAuth uriHttp

177+ lookup "Authorization" (L.requestHeaders requestHttps)

178+ `shouldBe` uriBasicAuth uriHttps

168

179

169 describe "bodies" $ do

180 describe "bodies" $ do

170 describe "NoReqBody" $

181 describe "NoReqBody" $

@@ -228,24 +239,22 @@ spec = do

228 property $ \username password -> do

239 property $ \username password -> do

229 request <- req_ GET url NoReqBody (basicAuth username password)

240 request <- req_ GET url NoReqBody (basicAuth username password)

230 lookup "Authorization" (L.requestHeaders request) `shouldBe`

241 lookup "Authorization" (L.requestHeaders request) `shouldBe`

231− pure (basicAuthHeader username password)

242+ Just (basicAuthHeader username password)

232 it "overwrites manual setting of header" $

243 it "overwrites manual setting of header" $

233 property $ \username password value -> do

244 property $ \username password value -> do

234 request0 <- req_ GET url NoReqBody

245 request0 <- req_ GET url NoReqBody

235 (basicAuth username password <> header "Authorization" value)

246 (basicAuth username password <> header "Authorization" value)

236 request1 <- req_ GET url NoReqBody

247 request1 <- req_ GET url NoReqBody

237 (header "Authorization" value <> basicAuth username password)

248 (header "Authorization" value <> basicAuth username password)

238− let result = basicAuthHeader username password

249+ let result = Just (basicAuthHeader username password)

239− lookup "Authorization" (L.requestHeaders request0) `shouldBe`

250+ lookup "Authorization" (L.requestHeaders request0) `shouldBe` result

240− pure result

241− lookup "Authorization" (L.requestHeaders request1) `shouldBe`

251+ lookup "Authorization" (L.requestHeaders request1) `shouldBe` result

242− pure result

243 it "left auth option wins" $

252 it "left auth option wins" $

244 property $ \username0 password0 username1 password1 -> do

253 property $ \username0 password0 username1 password1 -> do

245 request <- req_ GET url NoReqBody

254 request <- req_ GET url NoReqBody

246 (basicAuth username0 password0 <> basicAuth username1 password1)

255 (basicAuth username0 password0 <> basicAuth username1 password1)

247 lookup "Authorization" (L.requestHeaders request) `shouldBe`

256 lookup "Authorization" (L.requestHeaders request) `shouldBe`

248− pure (basicAuthHeader username0 password0)

257+ Just (basicAuthHeader username0 password0)

249 describe "oAuth2Bearer" $ do

258 describe "oAuth2Bearer" $ do

250 it "sets Authorization header to correct value" $

259 it "sets Authorization header to correct value" $

251 property $ \token -> do

260 property $ \token -> do

@@ -447,28 +456,47 @@ urlEncode = Y.urlEncode False . T.encodeUtf8

447encodePathPieces :: [Text] -> ByteString

456encodePathPieces :: [Text] -> ByteString

448encodePathPieces = BL.toStrict . BB.toLazyByteString . Y.encodePathSegments

457encodePathPieces = BL.toStrict . BB.toLazyByteString . Y.encodePathSegments

449

458

450−-- | Assemble a URL.

459+-- | Get host from a 'URI'. This function is not total.

451−

460+

452−assembleUrl

461+uriHost :: URI -> ByteString

453− :: Scheme -- ^ Scheme

462+uriHost uri = fromJust $

454− -> Host -- ^ Host

463+ urlEncode . URI.unRText . URI.authHost

455− -> Maybe (NonNegative Int) -- ^ Port

464+ <$> either (const Nothing) Just (URI.uriAuthority uri)

456− -> [Text] -- ^ Path pieces

465+

457− -> QueryParams -- ^ Query parameters

466+-- | Get part from a 'URI' defaulting to the provided value.

458− -> (ByteString, ByteString, ByteString) -- ^ URL, path, query string

467+

459−assembleUrl scheme' (Host host') mport' pathPieces (QueryParams queryParams) =

468+uriPort :: Int -> URI -> Int

460− (scheme <> host <> port' <> path <> queryString, path, queryString)

469+uriPort def uri = maybe def (fromIntegral) $

461− where

470+ either (const Nothing) Just (URI.uriAuthority uri) >>= URI.authPort

462− scheme = case scheme' of

471+

463− Http -> "http://"

472+-- | Get path from 'URI'.

464− Https -> "https://"

473+

465− host = urlEncode host'

474+uriPath :: URI -> ByteString

466− port' =

475+uriPath uri = fromMaybe "" $ do

467− case mport' of

476+ (_, xs) <- URI.uriPath uri

468− Nothing -> ""

469− Just (NonNegative x) -> ":" <> B8.pack (show x)

470− path = encodePathPieces pathPieces

477+ (return . encodePathPieces . fmap URI.unRText . NE.toList) xs

478+

479+-- | Get query string from 'URI'.

480+

481+uriQuery :: URI -> ByteString

482+uriQuery uri = do

483+ let liftQueryParam = \case

484+ URI.QueryFlag t -> (URI.unRText t, Nothing)

485+ URI.QueryParam k v -> (URI.unRText k, Just (URI.unRText v))

471− queryString = Y.renderQuery True (Y.queryTextToQuery queryParams)

486+ Y.renderQuery True (Y.queryTextToQuery (liftQueryParam <$> (URI.uriQuery uri)))

487+

488+-- | Predict the headrs that should be set if the given 'URI' has username

489+-- and password in it.

490+

491+uriBasicAuth :: URI -> Maybe ByteString

492+uriBasicAuth uri = do

493+ auth <- either (const Nothing) Just (URI.uriAuthority uri)

494+ URI.UserInfo {..} <- URI.authUserInfo auth

495+ let username = T.encodeUtf8 (URI.unRText uiUsername)

496+ password = maybe "" (T.encodeUtf8 . URI.unRText) uiPassword

497+ return (basicAuthHeader username password)

498+

499+-- | Render a query as lazy 'BL.ByteString'.

472

500

473renderQuery :: [(Text, Maybe Text)] -> BL.ByteString

501renderQuery :: [(Text, Maybe Text)] -> BL.ByteString

474renderQuery = BL.fromStrict . Y.renderQuery False . Y.queryTextToQuery

502renderQuery = BL.fromStrict . Y.renderQuery False . Y.queryTextToQuery

req.cabal+2

@@ -38,6 +38,7 @@ library

38 , http-client >= 0.5 && < 0.7

39 , http-client-tls >= 0.3.2 && < 0.4

40 , http-types >= 0.8 && < 10.0

41+ , modern-uri >= 0.3 && < 0.4

41 , monad-control >= 1.0 && < 1.1

42 , monad-control >= 1.0 && < 1.1

42 , mtl >= 2.0 && < 3.0

43 , mtl >= 2.0 && < 3.0

43 , retry >= 0.8 && < 0.9

44 , retry >= 0.8 && < 0.9

@@ -72,6 +73,7 @@ test-suite pure-tests

72 , hspec-core >= 2.0 && < 3.0

73 , hspec-core >= 2.0 && < 3.0

73 , http-client >= 0.5 && < 0.7

74 , http-client >= 0.5 && < 0.7

74 , http-types >= 0.8 && < 10.0

75 , http-types >= 0.8 && < 10.0

76+ , modern-uri >= 0.3 && < 0.4

75 , mtl >= 2.0 && < 3.0

77 , mtl >= 2.0 && < 3.0

76 , req

78 , req

77 , retry >= 0.8 && < 0.9

79 , retry >= 0.8 && < 0.9