diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.2.16.1 +Version: 4000.2.17 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 @@ -69,10 +69,6 @@ default: True manual: True -flag network-uri - description: Get Network.URI from the network-uri package - default: True - Library Exposed-modules: Network.BufferType, @@ -114,10 +110,7 @@ -- GHC 6.10 and later versions of network Build-depends: network >= 2.2.0.1 && < 2.3 else - if flag(network-uri) - Build-depends: network-uri == 2.6.*, network == 2.6.* - else - Build-depends: network >= 2.2.0.1 && < 2.6 + Build-depends: network >= 2.2.0.1 && < 2.6 build-tools: ghc >= 6.10 && < 7.10 @@ -135,7 +128,9 @@ hs-source-dirs: test main-is: httpTests.hs - other-modules: Httpd + other-modules: + Httpd + UnitTests -- note: version constraints for dependencies shared with the library -- should be the same @@ -147,26 +142,22 @@ deepseq >= 1.3.0.0 && < 1.4, pureMD5 >= 0.2.4 && < 2.2, base >= 3.0.3.1 && < 4.8, + network >= 2.2.0.1 && < 2.6, split >= 0.1.3 && < 0.3, test-framework >= 0.2.0 && < 0.9, test-framework-hunit >= 0.2.0 && <0.4 - if flag(network-uri) - Build-depends: network-uri == 2.6.*, network == 2.6.* - else - Build-depends: network >= 2.2.0.1 && < 2.6 - if flag(warp-tests) CPP-Options: -DWARP_TESTS build-depends: - case-insensitive >= 0.2 && < 1.3, - http-types >= 0.6.1 && < 0.9, - wai >= 1.2.0 && < 2.2, - warp >= 1.2.0 && < 2.2 + case-insensitive >= 0.4.0.1 && < 1.3, + http-types >= 0.8.0 && < 0.9, + wai >= 2.1.0 && < 2.2, + warp >= 2.1.0 && < 2.2 if flag(conduit10) build-depends: - conduit >= 0.4.0 && < 1.1 + conduit >= 1.0.8 && < 1.1 else build-depends: conduit >= 1.1 && < 1.2, diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -124,7 +124,7 @@ import Text.Read.Lex (readDecP) import Text.ParserCombinators.ReadP - ( ReadP, readP_to_S, char, (<++), look, munch ) + ( ReadP, readP_to_S, char, (<++), look, munch, munch1 ) import Control.Exception as Exception (catch, IOException) @@ -156,10 +156,18 @@ pURIAuthority = do (u,pw) <- (pUserInfo `before` char '@') <++ return (Nothing, Nothing) - h <- munch (/=':') + h <- rfc2732host <++ munch (/=':') p <- orNothing (char ':' >> readDecP) look >>= guard . null return URIAuthority{ user=u, password=pw, host=h, port=p } + +-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL +rfc2732host :: ReadP String +rfc2732host = do + _ <- char '[' + res <- munch1 (/=']') + _ <- char ']' + return res pUserInfo :: ReadP (Maybe String, Maybe String) pUserInfo = do diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -34,13 +34,14 @@ ) where -import Network.BSD (getHostByName, hostAddresses) import Network.Socket - ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive) - , SocketType(Stream), inet_addr, connect + ( Socket, SocketOption(KeepAlive) + , SocketType(Stream), connect , shutdown, ShutdownCmd(..) , sClose, setSocketOption, getPeerName - , socket, Family(AF_INET) + , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo + , defaultHints, addrFamily, withSocketsDo + , addrSocketType, addrAddress ) import qualified Network.Stream as Stream ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) @@ -213,27 +214,35 @@ openTCPConnection uri port = openTCPConnection_ uri port False openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) -openTCPConnection_ uri port stashInput = withSocket $ \s -> do - setSocketOption s KeepAlive 1 - hostA <- getHostAddr uri - let a = SockAddrInet (toEnum port) hostA - connect s a - socketConnection_ uri port s stashInput - where - withSocket action = do - s <- socket AF_INET Stream 6 - onException (action s) (sClose s) - getHostAddr h = do - catchIO (inet_addr uri) -- handles ascii IP numbers - (\ _ -> do - host <- getHostByName_safe uri - case hostAddresses host of - [] -> fail ("openTCPConnection: no addresses in host entry for " ++ show h) - (ha:_) -> return ha) +openTCPConnection_ uri port stashInput = do + -- HACK: uri is sometimes obtained by calling Network.URI.uriRegName, and this includes + -- the surrounding square brackets for an RFC 2732 host like [::1]. It's not clear whether + -- it should, or whether all call sites should be using something different instead, but + -- the simplest short-term fix is to strip any surrounding square brackets here. + -- It shouldn't affect any as this is the only situation they can occur - see RFC 3986. + let fixedUri = + case uri of + '[':(rest@(c:_)) | last rest == ']' + -> if c == 'v' || c == 'V' + then error $ "Unsupported post-IPv6 address " ++ uri + else init rest + _ -> uri - getHostByName_safe h = - catchIO (getHostByName h) - (\ _ -> fail ("openTCPConnection: host lookup failure for " ++ show h)) + + -- use withSocketsDo here in case the caller hasn't used it, which would make getAddrInfo fail on Windows + -- although withSocketsDo is supposed to wrap the entire program, in practice it is safe to use it locally + -- like this as it just does a once-only installation of a shutdown handler to run at program exit, + -- rather than actually shutting down after the action + addrinfos <- withSocketsDo $ getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) (Just fixedUri) (Just . show $ port) + case addrinfos of + [] -> fail "openTCPConnection: getAddrInfo returned no address information" + (a:_) -> do + s <- socket (addrFamily a) Stream defaultProtocol + onException (do + setSocketOption s KeepAlive 1 + connect s (addrAddress a) + socketConnection_ fixedUri port s stashInput + ) (sClose s) -- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. socketConnection :: BufferType ty diff --git a/test/Httpd.hs b/test/Httpd.hs --- a/test/Httpd.hs +++ b/test/Httpd.hs @@ -25,6 +25,19 @@ import Data.Maybe ( fromJust ) import Network.URI ( URI, parseRelativeReference ) +import Network.Socket + ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily + , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6) + , defaultProtocol, SocketType(Stream), listen, setSocketOption + ) +#ifdef WARP_TESTS +#if MIN_VERSION_network(2,4,0) +import Network.Socket ( bind ) +#else +import Network.Socket ( bindSocket, Socket, SockAddr ) +#endif +#endif + import qualified Network.Shed.Httpd as Shed ( Request, Response(Response), initServer , reqMethod, reqURI, reqHeaders, reqBody @@ -38,7 +51,7 @@ ( Request(requestMethod, requestHeaders, rawPathInfo, requestBody) , responseLBS ) import qualified Network.Wai.Handler.Warp as Warp - ( run ) + ( runSettingsSocket, defaultSettings, setPort ) #endif data Request = Request @@ -87,12 +100,26 @@ #endif #ifdef WARP_TESTS -warp :: Server -warp port handler = - Warp.run port $ \warpRequest -> do - request <- requestFromWarp warpRequest - response <- liftIO $ handler request - return (responseToWarp response) +#if !MIN_VERSION_network(2,4,0) +bind :: Socket -> SockAddr -> IO () +bind = bindSocket +#endif + +warp :: Bool -> Server +warp ipv6 port handler = do + addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) + (Just $ if ipv6 then "::1" else "127.0.0.1") + (Just . show $ port) + case addrinfos of + [] -> fail "Couldn't obtain address information in warp" + (addri:_) -> do + sock <- socket (addrFamily addri) Stream defaultProtocol + bind sock (addrAddress addri) + listen sock 5 + Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do + request <- requestFromWarp warpRequest + response <- handler request + return (responseToWarp response) where responseToWarp (Response status hdrs body) = Warp.responseLBS diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -0,0 +1,32 @@ +module UnitTests ( unitTests ) where + +import Network.HTTP.Base +import Network.URI + +import Data.Maybe ( fromJust ) + +import Test.Framework ( testGroup ) +import Test.Framework.Providers.HUnit +import Test.HUnit + +parseIPv4Address :: Assertion +parseIPv4Address = + assertEqual "127.0.0.1 address is recognised" + (Just (URIAuthority {user = Nothing, password = Nothing, host = "127.0.0.1", port = Just 5313})) + (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://127.0.0.1:5313/foo")))) + + +parseIPv6Address :: Assertion +parseIPv6Address = + assertEqual "::1 address" + (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313})) + (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo")))) + +unitTests = + [testGroup "Unit tests" + [ testGroup "URI parsing" + [ testCase "Parse IPv4 address" parseIPv4Address + , testCase "Parse IPv6 address" parseIPv6Address + ] + ] + ] diff --git a/test/httpTests.hs b/test/httpTests.hs --- a/test/httpTests.hs +++ b/test/httpTests.hs @@ -12,6 +12,7 @@ import System.IO.Error (userError) import qualified Httpd +import qualified UnitTests import Network.Browser import Network.HTTP @@ -22,6 +23,7 @@ import Network.URI (uriPath, parseURI) import System.Environment (getArgs) +import System.Info (os) import System.IO (getChar) import Test.Framework (defaultMainWithArgs, testGroup) @@ -596,28 +598,35 @@ , testCase "Two requests - both servers" browserTwoRequestsBoth ] -urlRoot :: String -> Int -> String -urlRoot userpw 80 = "http://" ++ userpw ++ "localhost" -urlRoot userpw n = "http://" ++ userpw ++ "localhost:" ++ show n +data InetFamily = IPv4 | IPv6 -secureRoot :: String -> Int -> String -secureRoot userpw 443 = "https://" ++ userpw ++ "localhost" -secureRoot userpw n = "https://" ++ userpw ++ "localhost:" ++ show n +familyToLocalhost :: InetFamily -> String +familyToLocalhost IPv4 = "127.0.0.1" +familyToLocalhost IPv6 = "[::1]" +urlRoot :: InetFamily -> String -> Int -> String +urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam +urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n + +secureRoot :: InetFamily -> String -> Int -> String +secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam +secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n + type ServerAddress = String -> String -httpAddress, httpsAddress :: String -> Int -> ServerAddress -httpAddress userpw port p = urlRoot userpw port ++ p -httpsAddress userpw port p = secureRoot userpw port ++ p +httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress +httpAddress fam userpw port p = urlRoot fam userpw port ++ p +httpsAddress fam userpw port p = secureRoot fam userpw port ++ p main :: IO () main = do args <- getArgs let servers = - [ ("httpd-shed", Httpd.shed) + [ ("httpd-shed", Httpd.shed, IPv4) #ifdef WARP_TESTS - , ("warp", Httpd.warp) + , ("warp.v6", Httpd.warp True, IPv6) + , ("warp.v4", Httpd.warp False, IPv4) #endif ] basePortNum, altPortNum :: Int @@ -626,18 +635,18 @@ numberedServers = zip [basePortNum..] servers let setupNormalTests = do - flip mapM numberedServers $ \(portNum, (serverName, server)) -> do - let ?testUrl = httpAddress "" portNum - ?userpwUrl = httpAddress "test:password@" portNum - ?baduserpwUrl = httpAddress "test:wrongpwd@" portNum - ?secureTestUrl = httpsAddress "" portNum + flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do + let ?testUrl = httpAddress family "" portNum + ?userpwUrl = httpAddress family "test:password@" portNum + ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum + ?secureTestUrl = httpsAddress family "" 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 (portNum, (_, server,family)) = head numberedServers + let ?testUrl = httpAddress family "" portNum + ?altTestUrl = httpAddress family "" altPortNum _ <- forkIO $ server altPortNum altProcessRequest return port80Tests @@ -652,8 +661,8 @@ normalTests <- setupNormalTests altTests <- setupAltTests _ <- threadDelay 1000000 -- Give the server time to start :-( - defaultMainWithArgs (normalTests ++ [altTests]) args + defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args args -> do -- run the test harness as normal normalTests <- setupNormalTests _ <- threadDelay 1000000 -- Give the server time to start :-( - defaultMainWithArgs normalTests args + defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args