diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,4 @@ + * If the URI contains "user:pass@" part, use it for Basic Authorization * Add a test harness. * Don't leak a socket when getHostAddr throws an exception. * Send cookies in request format, not response format. diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.2.11 +Version: 4000.2.12 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -32,7 +32,10 @@ -- -- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission. -- Normalization such as having the request path be in the expected form and, possibly, --- introduce a default @Host:@ header if one isn't already present. If you do not +-- introduce a default @Host:@ header if one isn't already present. +-- Normalization also takes the @"user:pass\@"@ portion out of the the URI, +-- if it was supplied, and converts it into @Authorization: Basic$ header. +-- If you do not -- want the requests tampered with, but sent as-is, please import and use the -- the "Network.HTTP.HandleStream" or "Network.HTTP.Stream" modules instead. They -- export the same functions, but leaves construction and any normalization of diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -120,6 +120,7 @@ import Network.BufferType ( BufferOp(..), BufferType(..) ) import Network.HTTP.Headers import Network.HTTP.Utils ( trim, crlf, sp, readsOne ) +import qualified Network.HTTP.Base64 as Base64 (encode) import Text.Read.Lex (readDecP) import Text.ParserCombinators.ReadP @@ -756,6 +757,7 @@ --normalizers :: [RequestNormalizer ty] normalizers = ( normalizeHostURI + : normalizeBasicAuth : normalizeConnectionClose : normalizeUserAgent : normCustoms opts @@ -780,6 +782,23 @@ normalizeConnectionClose opts req | normDoClose opts = replaceHeader HdrConnection "close" req | otherwise = req + +-- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@ +-- if the "user:pass@" part is present in the "http://user:pass@host/path" +-- of the URI. If Authorization header was present already it is not replaced. +normalizeBasicAuth :: RequestNormalizer ty +normalizeBasicAuth _ req = + case getAuth req of + Just uriauth -> + case (user uriauth, password uriauth) of + (Just u, Just p) -> + insertHeaderIfMissing HdrAuthorization astr req + where + astr = "Basic " ++ base64encode (u ++ ":" ++ p) + base64encode = Base64.encode . stringToOctets :: String -> String + stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8] + (_, _) -> req + Nothing ->req -- | @normalizeHostURI forProxy req@ rewrites your request to have it -- follow the expected formats by the receiving party (proxy or server.) diff --git a/test/httpTests.hs b/test/httpTests.hs --- a/test/httpTests.hs +++ b/test/httpTests.hs @@ -82,6 +82,22 @@ (show (Just "text/plain", Just "4", sendBody)) body +userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion +userpwAuthFailure = do + response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic")) + code <- getResponseCode response + body <- getResponseBody response + assertEqual "HTTP status code" ((4, 0, 1), + "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body) + -- in case of 401, the server returns the contents of the Authz header + +userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion +userpwAuthSuccess = do + response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic")) + code <- getResponseCode response + body <- getResponseBody response + assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) + basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion basicAuthFailure = do response <- simpleHTTP (getRequest (?testUrl "/auth/basic")) @@ -151,7 +167,6 @@ browserOneCookie = do (_, response) <- browse $ do setOutHandler (const $ return ()) - setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 -- This first requests returns a single Set-Cookie: hello=world _ <- request $ getRequest (?testUrl "/browser/one-cookie/1") @@ -166,7 +181,6 @@ browserTwoCookies = do (_, response) <- browse $ do setOutHandler (const $ return ()) - setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 -- This first request returns two cookies _ <- request $ getRequest (?testUrl "/browser/two-cookies/1") @@ -182,7 +196,6 @@ browserFollowsRedirect n = do (_, response) <- browse $ do setOutHandler (const $ return ()) - setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") assertEqual "Receiving expected response from server" ((2, 0, 0), "It works.") @@ -192,7 +205,6 @@ browserReturnsRedirect n = do (_, response) <- browse $ do setOutHandler (const $ return ()) - setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") assertEqual "Receiving expected response from server" ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "") @@ -205,7 +217,6 @@ browserBasicAuth = do (_, response) <- browse $ do setOutHandler (const $ return ()) - setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 setAuthorityGen authGenBasic @@ -222,7 +233,6 @@ browserDigestAuth = do (_, response) <- browse $ do setOutHandler (const $ return ()) - setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 setAuthorityGen authGenDigest @@ -524,6 +534,8 @@ , testCase "Secure GET request" secureGetRequest , testCase "Basic POST request" basicPostRequest , testCase "Basic HEAD request" basicHeadRequest + , testCase "URI user:pass Auth failure" userpwAuthFailure + , testCase "URI user:pass Auth success" userpwAuthSuccess , testCase "Basic Auth failure" basicAuthFailure , testCase "Basic Auth success" basicAuthSuccess , testCase "UTF-8 urlEncode" utf8URLEncode @@ -534,9 +546,8 @@ testGroup "Browser tests" [ testGroup "Basic" [ - -- github issue 14 - -- testCase "Two requests" browserTwoRequests testCase "Network.Browser example code" browserExample + , testCase "Two requests" browserTwoRequests ] , testGroup "Secure" [ @@ -581,24 +592,23 @@ [ testCase "Alternate server" browserAlt , testCase "Both servers" browserBoth , testCase "Both servers (reversed)" browserBothReversed - -- github issue 14 - -- , testCase "Two requests - alternate server" browserTwoRequestsAlt - -- , testCase "Two requests - both servers" browserTwoRequestsBoth + , testCase "Two requests - alternate server" browserTwoRequestsAlt + , testCase "Two requests - both servers" browserTwoRequestsBoth ] -urlRoot :: Int -> String -urlRoot 80 = "http://localhost" -urlRoot n = "http://localhost:" ++ show n +urlRoot :: String -> Int -> String +urlRoot userpw 80 = "http://" ++ userpw ++ "localhost" +urlRoot userpw n = "http://" ++ userpw ++ "localhost:" ++ show n -secureRoot :: Int -> String -secureRoot 443 = "https://localhost" -secureRoot n = "https://localhost:" ++ show n +secureRoot :: String -> Int -> String +secureRoot userpw 443 = "https://" ++ userpw ++ "localhost" +secureRoot userpw n = "https://" ++ userpw ++ "localhost:" ++ show n type ServerAddress = String -> String -httpAddress, httpsAddress :: Int -> ServerAddress -httpAddress port p = urlRoot port ++ p -httpsAddress port p = secureRoot port ++ p +httpAddress, httpsAddress :: String -> Int -> ServerAddress +httpAddress userpw port p = urlRoot userpw port ++ p +httpsAddress userpw port p = secureRoot userpw port ++ p main :: IO () main = do @@ -612,15 +622,17 @@ let setupNormalTests = do flip mapM numberedServers $ \(portNum, (serverName, server)) -> do - let ?testUrl = httpAddress portNum - ?secureTestUrl = httpsAddress portNum + let ?testUrl = httpAddress "" portNum + ?userpwUrl = httpAddress "test:password@" portNum + ?baduserpwUrl = httpAddress "test:wrongpwd@" portNum + ?secureTestUrl = httpsAddress "" portNum _ <- forkIO $ server portNum processRequest return $ testGroup serverName [basicTests, browserTests] let setupAltTests = do let (portNum, (_, server)) = head numberedServers - let ?testUrl = httpAddress portNum - ?altTestUrl = httpAddress altPortNum + let ?testUrl = httpAddress "" portNum + ?altTestUrl = httpAddress "" altPortNum _ <- forkIO $ server altPortNum altProcessRequest return port80Tests