error out when asked to do https rather than doing http instead

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)

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

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.

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

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