Hello community, here is the log from the commit of package ghc-HTTP for openSUSE:Factory checked in at 2015-05-21 08:10:58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-HTTP (Old) and /work/SRC/openSUSE:Factory/.ghc-HTTP.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-HTTP" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-HTTP/ghc-HTTP.changes 2014-11-26 20:54:52.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-HTTP.new/ghc-HTTP.changes 2015-05-21 08:11:00.000000000 +0200 @@ -1,0 +2,6 @@ +Sat Apr 11 20:34:01 UTC 2015 - [email protected] + +- update to 4000.2.19 +* no upstream changelog + +------------------------------------------------------------------- Old: ---- HTTP-4000.2.10.tar.gz New: ---- HTTP-4000.2.19.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-HTTP.spec ++++++ --- /var/tmp/diff_new_pack.EpyfuS/_old 2015-05-21 08:11:01.000000000 +0200 +++ /var/tmp/diff_new_pack.EpyfuS/_new 2015-05-21 08:11:01.000000000 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-HTTP # -# Copyright (c) 2014 SUSE LINUX Products GmbH, Nuernberg, Germany. +# Copyright (c) 2015 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name HTTP Name: ghc-HTTP -Version: 4000.2.10 +Version: 4000.2.19 Release: 0 Summary: A library for client-side HTTP License: BSD-3-Clause @@ -36,6 +36,7 @@ BuildRequires: ghc-bytestring-devel BuildRequires: ghc-mtl-devel BuildRequires: ghc-network-devel +BuildRequires: ghc-network-uri-devel BuildRequires: ghc-old-time-devel BuildRequires: ghc-parsec-devel # End cabal-rpm deps ++++++ HTTP-4000.2.10.tar.gz -> HTTP-4000.2.19.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/CHANGES new/HTTP-4000.2.19/CHANGES --- old/HTTP-4000.2.10/CHANGES 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/CHANGES 2014-12-18 22:12:40.000000000 +0100 @@ -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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/HTTP.cabal new/HTTP-4000.2.19/HTTP.cabal --- old/HTTP-4000.2.10/HTTP.cabal 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/HTTP.cabal 2014-12-18 22:12:40.000000000 +0100 @@ -1,11 +1,11 @@ Name: HTTP -Version: 4000.2.10 +Version: 4000.2.19 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE Author: Warrick Gray <[email protected]> -Maintainer: Ganesh Sittampalam <[email protected]> +Maintainer: Ganesh Sittampalam <[email protected]> Homepage: https://github.com/haskell/HTTP Category: Network Synopsis: A library for client-side HTTP @@ -24,7 +24,7 @@ . The representation of the bytes flowing across is extensible via the use of a type class, letting you pick the representation of requests and responses that best fits your use. - Some pre-packaged, common instances are provided for you (@ByteString@, @String@.) + Some pre-packaged, common instances are provided for you (@ByteString@, @String@). . Here's an example use: . @@ -47,10 +47,6 @@ type: git location: https://github.com/haskell/HTTP.git -Flag old-base - description: Old, monolithic base - default: False - Flag mtl1 description: Use the old mtl version 1. default: False @@ -58,11 +54,25 @@ Flag warn-as-error default: False description: Build with warnings-as-errors + manual: True Flag network23 description: Use version 2.3.x or below of the network package default: False +Flag conduit10 + description: Use version 1.0.x or below of the conduit package (for the test suite) + default: False + +Flag warp-tests + description: Test against warp + default: True + manual: True + +flag network-uri + description: Get Network.URI from the network-uri package + default: True + Library Exposed-modules: Network.BufferType, @@ -85,50 +95,78 @@ Network.HTTP.Utils Paths_HTTP GHC-options: -fwarn-missing-signatures -Wall - Build-depends: base >= 2 && < 4.8, network < 2.5, parsec + + -- note the test harness constraints should be kept in sync with these + -- where dependencies are shared + Build-depends: base >= 4.3.0.0 && < 4.9, parsec >= 2.0 && < 3.2 + Build-depends: array >= 0.3.0.2 && < 0.6, old-time >= 1.0.0.0 && < 1.2, bytestring >= 0.9.1.5 && < 0.11 + Extensions: FlexibleInstances - if flag(old-base) - Build-depends: base < 3 - else - Build-depends: base >= 3, array, old-time, bytestring if flag(mtl1) - Build-depends: mtl >= 1.1 && < 1.2 + Build-depends: mtl >= 1.1.1.0 && < 1.2 CPP-Options: -DMTL1 else - Build-depends: mtl >= 2.0 && < 2.2 + Build-depends: mtl >= 2.0 && < 2.3 + + if flag(network-uri) + Build-depends: network-uri == 2.6.*, network == 2.6.* + else + Build-depends: network >= 2.2.1.5 && < 2.6 + + build-tools: ghc >= 7.0 && < 7.12 if flag(warn-as-error) ghc-options: -Werror if os(windows) - Build-depends: Win32 + Build-depends: Win32 >= 2.2.0.0 && < 2.4 Test-Suite test type: exitcode-stdio-1.0 - build-tools: ghc >= 6.10 && < 7.10 + build-tools: ghc >= 7.0 && < 7.12 hs-source-dirs: test main-is: httpTests.hs - -- note: version constraints are inherited from HTTP library stanza + other-modules: + Httpd + UnitTests + + -- note: version constraints for dependencies shared with the library + -- should be the same build-depends: HTTP, - HUnit, - httpd-shed, - mtl >= 2.0 && < 2.2, - bytestring >= 0.9 && < 0.11, - case-insensitive >= 0.4 && < 1.2, - deepseq >= 1.3 && < 1.4, - http-types >= 0.6 && < 0.9, - conduit >= 0.4 && < 1.1, - wai >= 1.2 && < 1.4, - -- compile failure with warp 1.3.10 - warp >= 1.2 && < 1.3.10, - pureMD5 >= 2.1 && < 2.2, - base >= 2 && < 4.8, - network, - split >= 0.1 && < 0.3, - test-framework, - test-framework-hunit + HUnit >= 1.2.0.1 && < 1.3, + httpd-shed >= 0.4 && < 0.5, + mtl >= 1.1.1.0 && < 2.3, + bytestring >= 0.9.1.5 && < 0.11, + deepseq >= 1.3.0.0 && < 1.5, + pureMD5 >= 0.2.4 && < 2.2, + base >= 4.3.0.0 && < 4.9, + split >= 0.1.3 && < 0.3, + test-framework >= 0.2.0 && < 0.9, + test-framework-hunit >= 0.3.0 && <0.4 + + if flag(network-uri) + Build-depends: network-uri == 2.6.*, network == 2.6.* + else + Build-depends: network >= 2.2.1.5 && < 2.6 + + if flag(warp-tests) + CPP-Options: -DWARP_TESTS + build-depends: + case-insensitive >= 0.4.0.1 && < 1.3, + http-types >= 0.8.0 && < 0.9, + wai >= 2.1.0 && < 3.1, + warp >= 2.1.0 && < 3.1 + + if flag(conduit10) + build-depends: + conduit >= 1.0.8 && < 1.1 + else + build-depends: + conduit >= 1.1 && < 1.3, + conduit-extra >= 1.1 && < 1.2 + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/Browser.hs new/HTTP-4000.2.19/Network/Browser.hs --- old/HTTP-4000.2.10/Network/Browser.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/Browser.hs 2014-12-18 22:12:40.000000000 +0100 @@ -1,11 +1,11 @@ -{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-} +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-} {- | Module : Network.Browser Copyright : See LICENSE file License : BSD -Maintainer : Ganesh Sittampalam <[email protected]> +Maintainer : Ganesh Sittampalam <[email protected]> Stability : experimental Portability : non-portable (not tested) @@ -139,9 +139,9 @@ import Data.Maybe (fromMaybe, listToMaybe, catMaybes ) import Control.Applicative (Applicative (..), (<$>)) #ifdef MTL1 -import Control.Monad (filterM, when, ap) +import Control.Monad (filterM, forM_, when, ap) #else -import Control.Monad (filterM, when) +import Control.Monad (filterM, forM_, when) #endif import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..)) @@ -820,6 +820,8 @@ -- add new cookies to browser state handleCookies uri (uriAuthToString $ reqURIAuth rq) (retrieveHeaders HdrSetCookie rsp) + -- Deal with "Connection: close" in response. + handleConnectionClose (reqURIAuth rq) (retrieveHeaders HdrConnection rsp) mbMxAuths <- getMaxAuthAttempts case rspCode rsp of (4,0,1) -- Credentials not sent or refused. @@ -1000,6 +1002,18 @@ defaultMaxPoolSize :: Int defaultMaxPoolSize = 5 +cleanConnectionPool :: HStream hTy + => URIAuth -> BrowserAction (HandleStream hTy) () +cleanConnectionPool uri = do + let ep = EndPoint (uriRegName uri) (uriAuthPort Nothing uri) + pool <- gets bsConnectionPool + bad <- liftIO $ mapM (\c -> c `isTCPConnectedTo` ep) pool + let tmp = zip bad pool + newpool = map snd $ filter (not . fst) tmp + toclose = map snd $ filter fst tmp + liftIO $ forM_ toclose close + modify (\b -> b { bsConnectionPool = newpool }) + handleCookies :: URI -> String -> [Header] -> BrowserAction t () handleCookies _ _ [] = return () -- cut short the silliness. handleCookies uri dom cookieHeaders = do @@ -1015,6 +1029,15 @@ where (errs, newCookies) = processCookieHeaders dom cookieHeaders +handleConnectionClose :: HStream hTy + => URIAuth -> [Header] + -> BrowserAction (HandleStream hTy) () +handleConnectionClose _ [] = return () +handleConnectionClose uri headers = do + let doClose = any (== "close") $ map headerToConnType headers + when doClose $ cleanConnectionPool uri + where headerToConnType (Header _ t) = map toLower t + ------------------------------------------------------------------ ----------------------- Miscellaneous ---------------------------- ------------------------------------------------------------------ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/BufferType.hs new/HTTP-4000.2.19/Network/BufferType.hs --- old/HTTP-4000.2.10/Network/BufferType.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/BufferType.hs 2014-12-18 22:12:40.000000000 +0100 @@ -6,7 +6,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP/Auth.hs new/HTTP-4000.2.19/Network/HTTP/Auth.hs --- old/HTTP-4000.2.10/Network/HTTP/Auth.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP/Auth.hs 2014-12-18 22:12:40.000000000 +0100 @@ -5,7 +5,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP/Base.hs new/HTTP-4000.2.19/Network/HTTP/Base.hs --- old/HTTP-4000.2.10/Network/HTTP/Base.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP/Base.hs 2014-12-18 22:12:40.000000000 +0100 @@ -5,7 +5,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- @@ -120,10 +120,11 @@ 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 - ( ReadP, readP_to_S, char, (<++), look, munch ) + ( ReadP, readP_to_S, char, (<++), look, munch, munch1 ) import Control.Exception as Exception (catch, IOException) @@ -155,11 +156,19 @@ 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 u <- orNothing (munch (`notElem` ":@")) @@ -756,6 +765,7 @@ --normalizers :: [RequestNormalizer ty] normalizers = ( normalizeHostURI + : normalizeBasicAuth : normalizeConnectionClose : normalizeUserAgent : normCustoms opts @@ -781,6 +791,23 @@ | 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.) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP/Cookie.hs new/HTTP-4000.2.19/Network/HTTP/Cookie.hs --- old/HTTP-4000.2.10/Network/HTTP/Cookie.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP/Cookie.hs 2014-12-18 22:12:40.000000000 +0100 @@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP/HandleStream.hs new/HTTP-4000.2.19/Network/HTTP/HandleStream.hs --- old/HTTP-4000.2.10/Network/HTTP/HandleStream.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP/HandleStream.hs 2014-12-18 22:12:40.000000000 +0100 @@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP/Headers.hs new/HTTP-4000.2.19/Network/HTTP/Headers.hs --- old/HTTP-4000.2.10/Network/HTTP/Headers.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP/Headers.hs 2014-12-18 22:12:40.000000000 +0100 @@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP/Proxy.hs new/HTTP-4000.2.19/Network/HTTP/Proxy.hs --- old/HTTP-4000.2.10/Network/HTTP/Proxy.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP/Proxy.hs 2014-12-18 22:12:40.000000000 +0100 @@ -5,7 +5,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- @@ -19,13 +19,21 @@ , parseProxy -- :: String -> Maybe Proxy ) where +{- +#if !defined(WIN32) && defined(mingw32_HOST_OS) +#define WIN32 1 +#endif +-} + import Control.Monad ( when, mplus, join, liftM2) +#if defined(WIN32) import Network.HTTP.Base ( catchIO ) +#endif import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) import Network.HTTP.Auth import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI ) + ( URI(..), URIAuth(..), parseAbsoluteURI, unEscapeString ) import System.IO ( hPutStrLn, stderr ) import System.Environment @@ -154,7 +162,7 @@ auth = case auth' of [] -> Nothing - as -> Just (AuthBasic "" usr pwd uri) + as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri) where (usr,pwd) = chopAtDelim ':' as diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP/Stream.hs new/HTTP-4000.2.19/Network/HTTP/Stream.hs --- old/HTTP-4000.2.10/Network/HTTP/Stream.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP/Stream.hs 2014-12-18 22:12:40.000000000 +0100 @@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP/Utils.hs new/HTTP-4000.2.19/Network/HTTP/Utils.hs --- old/HTTP-4000.2.10/Network/HTTP/Utils.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP/Utils.hs 2014-12-18 22:12:40.000000000 +0100 @@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/HTTP.hs new/HTTP-4000.2.19/Network/HTTP.hs --- old/HTTP-4000.2.10/Network/HTTP.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/HTTP.hs 2014-12-18 22:12:40.000000000 +0100 @@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/Stream.hs new/HTTP-4000.2.19/Network/Stream.hs --- old/HTTP-4000.2.10/Network/Stream.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/Stream.hs 2014-12-18 22:12:40.000000000 +0100 @@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/StreamDebugger.hs new/HTTP-4000.2.19/Network/StreamDebugger.hs --- old/HTTP-4000.2.10/Network/StreamDebugger.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/StreamDebugger.hs 2014-12-18 22:12:40.000000000 +0100 @@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/StreamSocket.hs new/HTTP-4000.2.19/Network/StreamSocket.hs --- old/HTTP-4000.2.10/Network/StreamSocket.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/StreamSocket.hs 2014-12-18 22:12:40.000000000 +0100 @@ -5,7 +5,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/Network/TCP.hs new/HTTP-4000.2.19/Network/TCP.hs --- old/HTTP-4000.2.10/Network/TCP.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/Network/TCP.hs 2014-12-18 22:12:40.000000000 +0100 @@ -5,7 +5,7 @@ -- Copyright : See LICENSE file -- License : BSD -- --- Maintainer : Ganesh Sittampalam <[email protected]> +-- Maintainer : Ganesh Sittampalam <[email protected]> -- Stability : experimental -- Portability : non-portable (not tested) -- @@ -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) - - getHostByName_safe h = - catchIO (getHostByName h) - (\ _ -> fail ("openTCPConnection: host lookup failure for " ++ show h)) +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 + + + -- 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/test/Httpd.hs new/HTTP-4000.2.19/test/Httpd.hs --- old/HTTP-4000.2.10/test/Httpd.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/HTTP-4000.2.19/test/Httpd.hs 2014-12-18 22:12:40.000000000 +0100 @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP #-} + +module Httpd + ( Request, Response, Server + , mkResponse + , reqMethod, reqURI, reqHeaders, reqBody + , shed +#ifdef WARP_TESTS + , warp +#endif + ) + where + +import Control.Applicative +import Control.Arrow ( (***) ) +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans ( liftIO ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +#ifdef WARP_TESTS +import qualified Data.CaseInsensitive as CI +#endif +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, SocketOption(ReuseAddr) + ) +#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 + ) +#ifdef WARP_TESTS +#if !MIN_VERSION_wai(3,0,0) +import qualified Data.Conduit.Lazy as Warp +#endif + +import qualified Network.HTTP.Types as Warp + ( Status(..) ) +import qualified Network.Wai as Warp +import qualified Network.Wai.Handler.Warp as Warp + ( runSettingsSocket, defaultSettings, setPort ) +#endif + +data Request = Request + { + reqMethod :: String, + reqURI :: URI, + reqHeaders :: [(String, String)], + reqBody :: String + } + +data Response = Response + { + respStatus :: Int, + respHeaders :: [(String, String)], + respBody :: String + } + +mkResponse :: Int -> [(String, String)] -> String -> Response +mkResponse = Response + +type Server = Int -> (Request -> IO Response) -> IO () + +shed :: Server +shed port handler = + () <$ Shed.initServer + port + (liftM responseToShed . handler . requestFromShed) + where + responseToShed (Response status hdrs body) = + Shed.Response status hdrs body + chomp = reverse . strip '\r' . reverse + strip c (c':str) | c == c' = str + strip c str = str + requestFromShed request = + Request + { + reqMethod = Shed.reqMethod request, + reqURI = Shed.reqURI request, + reqHeaders = map (id *** chomp) $ Shed.reqHeaders request, + reqBody = Shed.reqBody request + } + +#if !MIN_VERSION_bytestring(0,10,0) +instance NFData B.ByteString where + rnf = rnf . B.length +#endif + +#ifdef WARP_TESTS +#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 + setSocketOption sock ReuseAddr 1 + bind sock (addrAddress addri) + listen sock 5 +#if MIN_VERSION_wai(3,0,0) + Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do + request <- requestFromWarp warpRequest + response <- handler request + warpRespond (responseToWarp response) +#else + Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do + request <- requestFromWarp warpRequest + response <- handler request + return (responseToWarp response) +#endif + where + responseToWarp (Response status hdrs body) = + Warp.responseLBS + (Warp.Status status B.empty) + (map headerToWarp hdrs) + (BLC.pack body) + headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value) + headerFromWarp (name, value) = + (BC.unpack (CI.original name), BC.unpack value) + requestFromWarp request = do +#if MIN_VERSION_wai(3,0,1) + body <- fmap BLC.unpack $ Warp.strictRequestBody request +#else + body <- fmap BLC.unpack $ Warp.lazyRequestBody request + body `deepseq` return () +#endif + return $ + Request + { + reqMethod = BC.unpack (Warp.requestMethod request), + reqURI = fromJust . parseRelativeReference . + BC.unpack . Warp.rawPathInfo $ + request, + reqHeaders = map headerFromWarp (Warp.requestHeaders request), + reqBody = body + } +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/test/UnitTests.hs new/HTTP-4000.2.19/test/UnitTests.hs --- old/HTTP-4000.2.10/test/UnitTests.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/HTTP-4000.2.19/test/UnitTests.hs 2014-12-18 22:12:40.000000000 +0100 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.10/test/httpTests.hs new/HTTP-4000.2.19/test/httpTests.hs --- old/HTTP-4000.2.10/test/httpTests.hs 2013-12-09 21:07:19.000000000 +0100 +++ new/HTTP-4000.2.19/test/httpTests.hs 2014-12-18 22:12:40.000000000 +0100 @@ -1,4 +1,4 @@ -{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction #-} +{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-} import Control.Concurrent import Control.Applicative ((<$)) @@ -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) @@ -82,6 +84,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 +169,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 +183,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 +198,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 +207,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 +219,6 @@ browserBasicAuth = do (_, response) <- browse $ do setOutHandler (const $ return ()) - setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 setAuthorityGen authGenBasic @@ -222,7 +235,6 @@ browserDigestAuth = do (_, response) <- browse $ do setOutHandler (const $ return ()) - setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 setAuthorityGen authGenDigest @@ -413,7 +425,7 @@ -- first bits of result text from haskell.org (just to give some representative text) haskellOrgText = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\";>\ -\<html xmlns=\"http://www.w3.org/1999/xhtml\"; xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\ +\\t<html xmlns=\"http://www.w3.org/1999/xhtml\"; xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\ \\t<head>\ \\t\t<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\ \\t\t\t\t<meta name=\"keywords\" content=\"Haskell,Applications and libraries,Books,Foreign Function Interface,Functional programming,Hac Boston,HakkuTaikai,HaskellImplementorsWorkshop/2011,Haskell Communities and Activities Report,Haskell in education,Haskell in industry\" />" @@ -524,6 +536,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 +548,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,46 +594,59 @@ [ 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 - -secureRoot :: Int -> String -secureRoot 443 = "https://localhost"; -secureRoot n = "https://localhost:"; ++ show n +data InetFamily = IPv4 | IPv6 + +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 :: Int -> ServerAddress -httpAddress port p = urlRoot port ++ p -httpsAddress port p = secureRoot 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), ("warp", Httpd.warp)] + let servers = + [ ("httpd-shed", Httpd.shed, IPv4) +#ifdef WARP_TESTS + , ("warp.v6", Httpd.warp True, IPv6) + , ("warp.v4", Httpd.warp False, IPv4) +#endif + ] basePortNum, altPortNum :: Int basePortNum = 5812 altPortNum = 80 numberedServers = zip [basePortNum..] servers let setupNormalTests = do - flip mapM numberedServers $ \(portNum, (serverName, server)) -> do - let ?testUrl = httpAddress 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 @@ -635,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
