From 2c98c42a80770ab5ebd36788e3867dae4f067e4b Mon Sep 17 00:00:00 2001 From: Ganesh Sittampalam Date: Fri, 25 Nov 2011 00:10:41 +0000 Subject: [PATCH] error out when asked to do https rather than doing http instead --- Network/Browser.hs | 1 + Network/HTTP.hs | 1 + Network/HTTP/Base.hs | 7 +++++ Network/HTTP/HandleStream.hs | 2 ++ test/httpTests.hs | 61 ++++++++++++++++++++++++++++++++++++ 5 files changed, 72 insertions(+) diff --git a/Network/Browser.hs b/Network/Browser.hs index a5ee6fa..a8c9185 100644 --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -733,6 +733,7 @@ request' :: HStream ty -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) request' nullVal rqState rq = do let uri = rqURI rq + failHTTPS uri let uria = reqURIAuth rq -- add cookies to request cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) diff --git a/Network/HTTP.hs b/Network/HTTP.hs index 3bd4d19..909d224 100644 --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -98,6 +98,7 @@ import Data.Maybe ( fromMaybe ) simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty)) simpleHTTP r = do auth <- getAuth r + failHTTPS (rqURI r) c <- openStream (host auth) (fromMaybe 80 (port auth)) let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r simpleHTTP_ c norm_r diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs index cef8cd7..d89f572 100644 --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -93,6 +93,8 @@ module Network.HTTP.Base , getResponseVersion , setRequestVersion , setResponseVersion + + , failHTTPS ) where @@ -194,6 +196,11 @@ uriAuthPort mbURI u = default_http = 80 default_https = 443 +failHTTPS :: Monad m => URI -> m () +failHTTPS uri + | map toLower (uriScheme uri) == "https:" = fail "https not supported" + | otherwise = return () + -- Fish out the authority from a possibly normalized Request, i.e., -- the information may either be in the request's URI or inside -- the Host: header. diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs index 366f457..1dbf7f3 100644 --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -53,6 +53,7 @@ import Control.Monad (when) simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty)) simpleHTTP r = do auth <- getAuth r + failHTTPS (rqURI r) c <- openStream (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r @@ -61,6 +62,7 @@ simpleHTTP r = do simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty)) simpleHTTP_debug httpLogFile r = do auth <- getAuth r + failHTTPS (rqURI r) c0 <- openStream (host auth) (fromMaybe 80 (port auth)) c <- debugByteStream httpLogFile c0 simpleHTTP_ c r diff --git a/test/httpTests.hs b/test/httpTests.hs index 286661a..ef5f049 100644 --- a/test/httpTests.hs +++ b/test/httpTests.hs @@ -3,9 +3,11 @@ import Control.Concurrent import Control.Applicative ((<$)) import Control.Concurrent (threadDelay) +import Control.Exception (try) import Data.Char (isSpace) import Data.List.Split (splitOn) import Data.Maybe (fromJust) +import System.IO.Error (userError) import qualified Network.Shed.Httpd as Httpd @@ -32,6 +34,12 @@ basicGetRequest = do body <- getResponseBody response assertEqual "Receiving expected response" "It works." body +secureGetRequest :: Assertion +secureGetRequest = do + response <- try $ simpleHTTP (getRequest (secureTestUrl "/anything")) + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show response) -- fmap show because Response isn't in Eq basicAuthFailure :: Assertion basicAuthFailure = do @@ -212,6 +220,41 @@ browserBothReversed = do ((2, 0, 0), "This is the alternate server.") (rspCode response2, rspBody response2) +browserSecureRequest :: Assertion +browserSecureRequest = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + + request $ getRequest (secureTestUrl "/anything") + + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show res) -- fmap show because Response isn't in Eq + +-- in case it tries to reuse the connection +browserSecureRequestAfterInsecure :: Assertion +browserSecureRequestAfterInsecure = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + + request $ getRequest (testUrl "/basic/get") + request $ getRequest (secureTestUrl "/anything") + + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show res) -- fmap show because Response isn't in Eq + +browserRedirectToSecure :: Assertion +browserRedirectToSecure = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + setErrHandler fail + + request $ getRequest (testUrl "/browser/redirect/secure/301/anything") + + assertEqual "Threw expected exception" + (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ secureTestUrl "/anything")) + (fmap show res) -- fmap show because Response isn't in Eq browserTwoRequests :: Assertion browserTwoRequests = do @@ -353,6 +396,10 @@ processRequest req = do Nothing -> return $ Httpd.Response 500 [] (show $ Httpd.reqHeaders req) ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> return $ Httpd.Response n [("Location", rest)] "" + ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.Response n [("Location", testUrl rest)] "" + ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.Response n [("Location", secureTestUrl rest)] "" _ -> return $ Httpd.Response 500 [] "Unknown request" altProcessRequest :: Httpd.Request -> IO Httpd.Response @@ -372,6 +419,7 @@ maybeTestGroup False name _ = testGroup name [] tests port80Server = [ testGroup "Basic tests" [ testCase "Basic GET request" basicGetRequest + , testCase "Secure GET request" secureGetRequest , testCase "Basic Auth failure" basicAuthFailure , testCase "Basic Auth success" basicAuthSuccess ] @@ -381,6 +429,12 @@ tests port80Server = -- github issue 14 -- testCase "Two requests" browserTwoRequests ] + , testGroup "Secure" + [ + testCase "Secure request" browserSecureRequest + , testCase "After insecure" browserSecureRequestAfterInsecure + , testCase "Redirection" browserRedirectToSecure + ] , testGroup "Cookies" [ testCase "No cookie header" browserNoCookie , testCase "One cookie" browserOneCookie @@ -432,12 +486,19 @@ urlRoot :: Int -> String urlRoot 80 = "http://localhost" urlRoot n = "http://localhost:" ++ show n +secureRoot :: Int -> String +secureRoot 443 = "https://localhost" +secureRoot n = "https://localhost:" ++ show n + testUrl :: String -> String testUrl p = urlRoot portNum ++ p altTestUrl :: String -> String altTestUrl p = urlRoot altPortNum ++ p +secureTestUrl :: String -> String +secureTestUrl p = secureRoot portNum ++ p + main :: IO () main = do args <- getArgs