HTTP 4000.2.11 → 4000.2.12
raw patch · 5 files changed
+61/−26 lines, 5 files
Files
- CHANGES +1/−0
- HTTP.cabal +1/−1
- Network/HTTP.hs +4/−1
- Network/HTTP/Base.hs +19/−0
- test/httpTests.hs +36/−24
CHANGES view
@@ -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.
HTTP.cabal view
@@ -1,5 +1,5 @@ Name: HTTP-Version: 4000.2.11+Version: 4000.2.12 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3
Network/HTTP.hs view
@@ -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
Network/HTTP/Base.hs view
@@ -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.)
test/httpTests.hs view
@@ -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