http-client 0.4.12 → 0.4.13
raw patch · 4 files changed
+71/−7 lines, 4 filesdep ~network-uri
Dependency ranges changed: network-uri
Files
- ChangeLog.md +4/−0
- Network/HTTP/Client/Request.hs +28/−5
- http-client.cabal +2/−1
- test-nonet/Network/HTTP/Client/RequestSpec.hs +37/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.4.13++* Support for auth via url [#124](https://github.com/snoyberg/http-client/pull/124)+ ## 0.4.12 * Added `IsString RequestBody` instance [#126](https://github.com/snoyberg/http-client/pull/126)
Network/HTTP/Client/Request.hs view
@@ -23,6 +23,8 @@ , setQueryString , streamFile , observedStreamFile+ , username+ , password ) where import Data.Int (Int64)@@ -45,7 +47,7 @@ import Data.ByteString.Lazy.Internal (defaultChunkSize) import qualified Network.HTTP.Types as W-import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI)+import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI, isReserved) import Control.Monad.IO.Class (liftIO) import Control.Exception (Exception, toException, throw, throwIO, IOException)@@ -114,16 +116,37 @@ , uriFragment = "" } +applyAnyUriBasedAuth :: URI -> Request -> Request+applyAnyUriBasedAuth uri req =+ if hasAuth+ then applyBasicAuth (S8.pack theuser) (S8.pack thepass) req+ else req+ where+ hasAuth = (notEmpty theuser) && (notEmpty thepass)+ notEmpty = not . null+ theuser = username authInfo+ thepass = password authInfo+ authInfo = maybe "" uriUserInfo $ uriAuthority uri++username :: String -> String+username = encode . takeWhile (/=':') . authPrefix++password :: String -> String+password = encode . takeWhile (/='@') . drop 1 . dropWhile (/=':')++encode :: String -> String+encode = escapeURIString (not . isReserved)++authPrefix :: String -> String+authPrefix u = if '@' `elem` u then takeWhile (/= '@') u else ""+ -- | Validate a 'URI', then add it to the request. setUri :: MonadThrow m => Request -> URI -> m Request setUri req uri = do sec <- parseScheme uri auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri- if not . null $ uriUserInfo auth- then failUri "URL auth not supported; use applyBasicAuth instead"- else return () port' <- parsePort sec auth- return req+ return $ applyAnyUriBasedAuth uri req { host = S8.pack $ uriRegName auth , port = port' , secure = sec
http-client.cabal view
@@ -1,5 +1,5 @@ name: http-client-version: 0.4.12+version: 0.4.13 synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages. description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-client>. homepage: https://github.com/snoyberg/http-client@@ -109,6 +109,7 @@ , blaze-builder , time , network+ , network-uri , containers , transformers , deepseq
test-nonet/Network/HTTP/Client/RequestSpec.hs view
@@ -5,9 +5,10 @@ import Control.Applicative ((<$>)) import Control.Monad (join, forM_) import Data.IORef-import Data.Maybe (isJust, fromMaybe)+import Data.Maybe (isJust, fromMaybe, fromJust) import Network.HTTP.Client (parseUrl, requestHeaders, applyBasicProxyAuth) import Network.HTTP.Client.Internal+import Network.URI (URI(..), URIAuth(..)) --(parseURI, relativeTo, escapeURIString, isAllowedInURI) import Test.Hspec spec :: Spec@@ -22,6 +23,20 @@ Nothing -> return () :: IO () Just req -> error $ show req + describe "authentication in url" $ do+ it "passes validation" $ do+ case parseUrl "http://agent:topsecret@example.com" of+ Nothing -> error "failed"+ Just _ -> return () :: IO ()++ it "add username/password to headers section" $ do+ let request = parseUrl "http://user:pass@example.com"+ field = join $ lookup "Authorization" . requestHeaders <$> request+ requestHostnameWithoutAuth = "example.com"+ (uriRegName $ fromJust $ uriAuthority $ getUri $ fromJust request) `shouldBe` requestHostnameWithoutAuth+ field `shouldSatisfy` isJust+ field `shouldBe` Just "Basic dXNlcjpwYXNz"+ describe "applyBasicProxyAuth" $ do let request = applyBasicProxyAuth "user" "pass" <$> parseUrl "http://example.org" field = join $ lookup "Proxy-Authorization" . requestHeaders <$> request@@ -30,6 +45,26 @@ it "Should add a proxy-authorization header with the specified username and password." $ do field `shouldBe` Just "Basic dXNlcjpwYXNz" + describe "extract credentials from a URI" $ do+ it "fetches non-empty username before the first ':'" $ do+ username "agent:secret@example.com" `shouldBe` "agent"++ it "extra colons do not delimit username" $ do+ username "agent:006:supersecret@example.com" `shouldBe` "agent"++ it "after ':' is considered password" $ do+ password "agent007:shakenNotStirred@example.com" `shouldBe` "shakenNotStirred"++ it "encodes username special characters per RFC3986" $ do+ username "/?#[]!$&'()*+,;=:therealpassword@example.com" `shouldBe` "%2F%3F%23%5B%5D%21%24%26%27%28%29%2A%2B%2C%3B%3D"++ it "encodes password special characters per RFC3986" $ do+ password "therealusername:?#[]!$&'()*+,;=/@example.com" `shouldBe` "%3F%23%5B%5D%21%24%26%27%28%29%2A%2B%2C%3B%3D%2F"++ it "no auth is empty" $ do+ username "example.com" `shouldBe` ""+ password "example.com" `shouldBe` ""+ describe "requestBuilder" $ do it "sends the full request, combining headers and body in the non-streaming case" $ do let Just req = parseUrl "http://localhost"@@ -83,3 +118,4 @@ case xs of (x:xs') -> (xs', x) [] -> ([], "")+