HTTP 4000.2.16.1 → 4000.2.17
raw patch · 6 files changed
+150/−74 lines, 6 filesdep −network-uridep ~case-insensitivedep ~conduitdep ~http-typesPVP ok
version bump matches the API change (PVP)
Dependencies removed: network-uri
Dependency ranges changed: case-insensitive, conduit, http-types, network, wai, warp
API changes (from Hackage documentation)
Files
- HTTP.cabal +11/−20
- Network/HTTP/Base.hs +10/−2
- Network/TCP.hs +33/−24
- test/Httpd.hs +34/−7
- test/UnitTests.hs +32/−0
- test/httpTests.hs +30/−21
HTTP.cabal view
@@ -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,
Network/HTTP/Base.hs view
@@ -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
Network/TCP.hs view
@@ -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
test/Httpd.hs view
@@ -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
+ test/UnitTests.hs view
@@ -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+ ]+ ]+ ]
test/httpTests.hs view
@@ -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