HTTP 4000.1.2 → 4000.2.0

raw patch · 15 files changed

+953/−310 lines, 15 filesdep +HTTPdep +HUnitdep +httpd-sheddep ~basedep ~mtldep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: HTTP, HUnit, httpd-shed, split, test-framework, test-framework-hunit

Dependency ranges changed: base, mtl, network

API changes (from Hackage documentation)

Files

• CHANGES +20/−2
• HTTP.cabal +110/−91
• LICENSE +11/−1
• Network/Browser.hs +114/−111
• Network/HTTP.hs +16/−0
• Network/HTTP/Auth.hs +6/−9
• Network/HTTP/Base.hs +36/−2
• Network/HTTP/Base64.hs +4/−1
• Network/HTTP/Cookie.hs +29/−33
• Network/HTTP/HandleStream.hs +2/−0
• Network/HTTP/MD5.hs +0/−43
• Network/StreamDebugger.hs +3/−1
• Network/StreamSocket.hs +1/−0
• Network/TCP.hs +27/−16
• test/httpTests.hs +574/−0

@@ -1,6 +1,24 @@+ * Add a test harness.+ * Don't leak a socket when getHostAddr throws an exception.+ * Send cookies in request format, not response format.+ * Moved BrowserAction to be a StateT IO, with instances for+   Applicative, MonadIO, MonadState.+ * Add method to control size of connection pool.+ * Consider both host and port when reusing connections.+ * Handle response code 304 "not modified" properly.+ * Fix digest authentication by fixing md5 output string rep.+ * Make the default user agent string follow the package version.+ * Document lack of HTTPS support and fail when clients try+   to use it instead of silently falling back to HTTP.+ * Add helper to set the request type and body.++Version 4000.1.2: release 2011-08-11+ * Turn off buffering for the debug log.+ * Update installation instructions.+ * Bump base dependency to support GHC 7.2.+ Version 4000.1.1: release 2010-11-28- * Be tolerant of LF (instead of CRLF which is the spec) in responses-   Patch by Chris Pettitt <cpettitt@gmail.com>.+ * Be tolerant of LF (instead of CRLF which is the spec) in responses.  Version 4000.1.0: release 2010-11-09  * Retroactively fixed CHANGES to refer to 4000.x.x instead of

@@ -1,91 +1,110 @@-Name: HTTP
-Version: 4000.1.2
-Cabal-Version: >= 1.2
-Build-type: Simple
-License: BSD3
-License-file: LICENSE
-Copyright: 
-  Copyright (c) 2002, Warrick Gray
-  Copyright (c) 2002-2005, Ian Lynagh
-  Copyright (c) 2003-2006, Bjorn Bringert
-  Copyright (c) 2004, Andre Furtado
-  Copyright (c) 2004, Ganesh Sittampalam
-  Copyright (c) 2004-2005, Dominic Steinitz
-  Copyright 2007 Robin Bate Boerop
-  Copyright 2008- Sigbjorn Finne
-Author: Warrick Gray <warrick.gray@hotmail.com>
-Maintainer: Ganesh Sittampalam <ganesh@earth.li>
-Homepage: http://projects.haskell.org/http/
-Category: Network
-Synopsis: A library for client-side HTTP
-Description: 
-
- The HTTP package supports client-side web programming in Haskell. It lets you set up 
- HTTP connections, transmitting requests and processing the responses coming back, all
- from within the comforts of Haskell. It's dependent on the network package to operate,
- but other than that, the implementation is all written in Haskell.
- .
- A basic API for issuing single HTTP requests + receiving responses is provided. On top
- of that, a session-level abstraction is also on offer  (the @BrowserAction@ monad);
- it taking care of handling the management of persistent connections, proxies,
- state (cookies) and authentication credentials required to handle multi-step
- interactions with a web server.
- .
- 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@.)
- .
- Here's an example use:
- .
- >
- >    do
- >      rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/")
- >              -- fetch document and return it (as a 'String'.)
- >      fmap (take 100) (getResponseBody rsp)
- >
- >    do 
- >      rsp <- Network.Browser.browse $ do
- >               setAllowRedirects True -- handle HTTP redirects
- >               request $ getRequest "http://google.com/"
- >      fmap (take 100) (getResponseBody rsp)
- > 
- .
- Git repository available at <git://github.com/haskell/HTTP.git>
-
-Extra-Source-Files: CHANGES
-
-Flag old-base
-  description: Old, monolithic base
-  default: False
-
-Library
-  Exposed-modules: 
-                 Network.BufferType,
-                 Network.Stream,
-                 Network.StreamDebugger,
-                 Network.StreamSocket,
-                 Network.TCP,                
-                 Network.HTTP,
-                 Network.HTTP.Headers,
-                 Network.HTTP.Base,
-                 Network.HTTP.Stream,
-                 Network.HTTP.Auth,
-                 Network.HTTP.Cookie,
-                 Network.HTTP.Proxy,
-                 Network.HTTP.HandleStream,
-                 Network.Browser
-  Other-modules:
-                 Network.HTTP.Base64,
-                 Network.HTTP.MD5,
-                 Network.HTTP.MD5Aux,
-                 Network.HTTP.Utils
-  GHC-options: -fwarn-missing-signatures -Wall
-  Build-depends: base >= 2 && < 4.5, network, parsec, mtl
-  Extensions: FlexibleInstances
-  if flag(old-base)
-    Build-depends: base < 3
-  else
-    Build-depends: base >= 3, array, old-time, bytestring
-
-  if os(windows)
-    Build-depends: Win32
+Name: HTTP+Version: 4000.2.0+Cabal-Version: >= 1.8+Build-type: Simple+License: BSD3+License-file: LICENSE+Author: Warrick Gray <warrick.gray@hotmail.com>+Maintainer: Ganesh Sittampalam <http@projects.haskell.org>+Homepage: https://github.com/haskell/HTTP+Category: Network+Synopsis: A library for client-side HTTP+Description: ++ The HTTP package supports client-side web programming in Haskell. It lets you set up + HTTP connections, transmitting requests and processing the responses coming back, all+ from within the comforts of Haskell. It's dependent on the network package to operate,+ but other than that, the implementation is all written in Haskell.+ .+ A basic API for issuing single HTTP requests + receiving responses is provided. On top+ of that, a session-level abstraction is also on offer  (the @BrowserAction@ monad);+ it taking care of handling the management of persistent connections, proxies,+ state (cookies) and authentication credentials required to handle multi-step+ interactions with a web server.+ .+ 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@.)+ .+ Here's an example use:+ .+ >+ >    do+ >      rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/")+ >              -- fetch document and return it (as a 'String'.)+ >      fmap (take 100) (getResponseBody rsp)+ >+ >    do + >      rsp <- Network.Browser.browse $ do+ >               setAllowRedirects True -- handle HTTP redirects+ >               request $ getRequest "http://google.com/"+ >      fmap (take 100) (getResponseBody rsp)+ > ++Extra-Source-Files: CHANGES++Source-Repository head+  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++Library+  Exposed-modules: +                 Network.BufferType,+                 Network.Stream,+                 Network.StreamDebugger,+                 Network.StreamSocket,+                 Network.TCP,                +                 Network.HTTP,+                 Network.HTTP.Headers,+                 Network.HTTP.Base,+                 Network.HTTP.Stream,+                 Network.HTTP.Auth,+                 Network.HTTP.Cookie,+                 Network.HTTP.Proxy,+                 Network.HTTP.HandleStream,+                 Network.Browser+  Other-modules:+                 Network.HTTP.Base64,+                 Network.HTTP.MD5Aux,+                 Network.HTTP.Utils+                 Paths_HTTP+  GHC-options: -fwarn-missing-signatures -Wall+  Build-depends: base >= 2 && < 4.5, network, parsec+  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+    CPP-Options: -DMTL1+  else+    Build-depends: mtl >= 2.0 && < 2.1++  if os(windows)+    Build-depends: Win32++Test-Suite test+  type: exitcode-stdio-1.0++  build-tools: ghc >= 6.10 && < 7.4++  hs-source-dirs: test+  main-is: httpTests.hs++  build-depends:     HTTP,+                     HUnit,+                     httpd-shed,+                     base >= 2 && < 4.5,+                     network,+                     split >= 0.1 && < 0.2,+                     test-framework,+                     test-framework-hunit

@@ -2,8 +2,18 @@ Copyright (c) 2002-2005, Ian Lynagh Copyright (c) 2003-2006, Bjorn Bringert Copyright (c) 2004, Andre Furtado-Copyright (c) 2004, Ganesh Sittampalam Copyright (c) 2004-2005, Dominic Steinitz+Copyright (c) 2007, Robin Bate Boerop+Copyright (c) 2008-2010, Sigbjorn Finne+Copyright (c) 2009, Eric Kow+Copyright (c) 2010, Antoine Latter+Copyright (c) 2004, 2010-2011, Ganesh Sittampalam+Copyright (c) 2011, Duncan Coutts+Copyright (c) 2011, Matthew Gruen+Copyright (c) 2011, Jeremy Yallop+Copyright (c) 2011, Eric Hesselink+Copyright (c) 2011, Yi Huang+Copyright (c) 2011, Tom Lokhorst  All rights reserved. 

@@ -1,3 +1,4 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-} {- |  Module      :  Network.Browser@@ -26,11 +27,12 @@  Example use: ->    do ->      rsp <- Network.Browser.browse $ do+>    do+>      (_, rsp)+>         <- Network.Browser.browse $ do >               setAllowRedirects True -- handle HTTP redirects->               request $ getRequest "http://google.com/"->      fmap (take 100) (getResponseBody rsp)+>               request $ getRequest "http://www.haskell.org/"+>      return (take 100 (rspBody rsp))   -} module Network.Browser @@ -66,6 +68,9 @@        , setMaxErrorRetries  -- :: Maybe Int -> BrowserAction t ()        , getMaxErrorRetries  -- :: BrowserAction t (Maybe Int) +       , setMaxPoolSize     -- :: Int -> BrowserAction t ()+       , getMaxPoolSize     -- :: BrowserAction t (Maybe Int)+        , setMaxAuthAttempts  -- :: Maybe Int -> BrowserAction t ()        , getMaxAuthAttempts  -- :: BrowserAction t (Maybe Int) @@ -132,7 +137,13 @@ import Data.Char (toLower) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe, listToMaybe, catMaybes )-import Control.Monad (filterM, liftM, when)+import Control.Applicative (Applicative (..), (<$>))+#ifdef MTL1+import Control.Monad (filterM, when, ap)+#else+import Control.Monad (filterM, when)+#endif+import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..))  import qualified System.IO    ( hSetBuffering, hPutStr, stdout, stdin, hGetChar@@ -172,18 +183,18 @@  -- | @addCookie c@ adds a cookie to the browser state, removing duplicates. addCookie :: Cookie -> BrowserAction t ()-addCookie c = alterBS (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) })+addCookie c = modify (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) })  -- | @setCookies cookies@ replaces the set of cookies known to -- the browser to @cookies@. Useful when wanting to restore cookies -- used across 'browse' invocations. setCookies :: [Cookie] -> BrowserAction t ()-setCookies cs = alterBS (\b -> b { bsCookies=cs })+setCookies cs = modify (\b -> b { bsCookies=cs })  -- | @getCookies@ returns the current set of cookies known to -- the browser. getCookies :: BrowserAction t [Cookie]-getCookies = getBS bsCookies+getCookies = gets bsCookies  -- ...get domain specific cookies... -- ... this needs changing for consistency with rfc2109...@@ -199,11 +210,11 @@  -- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()-setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f })+setCookieFilter f = modify (\b -> b { bsCookieFilter=f })  -- | @getCookieFilter@ returns the current cookie acceptance filter. getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool)-getCookieFilter = getBS bsCookieFilter+getCookieFilter = gets bsCookieFilter  ------------------------------------------------------------------ ----------------------- Authorisation Stuff ----------------------@@ -264,55 +275,55 @@ -- | @getAuthorities@ return the current set of @Authority@s known -- to the browser. getAuthorities :: BrowserAction t [Authority]-getAuthorities = getBS bsAuthorities+getAuthorities = gets bsAuthorities  -- @setAuthorities as@ replaces the Browser's known set -- of 'Authority's to @as@. setAuthorities :: [Authority] -> BrowserAction t ()-setAuthorities as = alterBS (\b -> b { bsAuthorities=as })+setAuthorities as = modify (\b -> b { bsAuthorities=as })  -- @addAuthority a@ adds 'Authority' @a@ to the Browser's -- set of known authorities. addAuthority :: Authority -> BrowserAction t ()-addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b })+addAuthority a = modify (\b -> b { bsAuthorities=a:bsAuthorities b })  -- | @getAuthorityGen@ returns the current authority generator getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String)))-getAuthorityGen = getBS bsAuthorityGen+getAuthorityGen = gets bsAuthorityGen  -- | @setAuthorityGen genAct@ sets the auth generator to @genAct@. setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t ()-setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f })+setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f })  -- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication. setAllowBasicAuth :: Bool -> BrowserAction t ()-setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba })+setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba })  getAllowBasicAuth :: BrowserAction t Bool-getAllowBasicAuth = getBS bsAllowBasicAuth+getAllowBasicAuth = gets bsAllowBasicAuth  -- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts -- to do. If @Nothing@, rever to default max. setMaxAuthAttempts :: Maybe Int -> BrowserAction t () setMaxAuthAttempts mb   | fromMaybe 0 mb < 0 = return ()- | otherwise          = alterBS (\ b -> b{bsMaxAuthAttempts=mb})+ | otherwise          = modify (\ b -> b{bsMaxAuthAttempts=mb})  -- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@, -- the browser's default is used. getMaxAuthAttempts :: BrowserAction t (Maybe Int)-getMaxAuthAttempts = getBS bsMaxAuthAttempts+getMaxAuthAttempts = gets bsMaxAuthAttempts  -- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at -- transmitting a request. If @Nothing@, rever to default max. setMaxErrorRetries :: Maybe Int -> BrowserAction t () setMaxErrorRetries mb  | fromMaybe 0 mb < 0 = return ()- | otherwise          = alterBS (\ b -> b{bsMaxErrorRetries=mb})+ | otherwise          = modify (\ b -> b{bsMaxErrorRetries=mb})  -- | @getMaxErrorRetries@ returns the current max number of error retries. getMaxErrorRetries :: BrowserAction t (Maybe Int)-getMaxErrorRetries = getBS bsMaxErrorRetries+getMaxErrorRetries = gets bsMaxErrorRetries  -- TO BE CHANGED!!! pickChallenge :: Bool -> [Challenge] -> Maybe Challenge@@ -335,7 +346,7 @@  | otherwise = do       -- prompt user for authority     prompt <- getAuthorityGen-    userdetails <- ioAction $ prompt uri (chRealm ch)+    userdetails <- liftIO $ prompt uri (chRealm ch)     case userdetails of      Nothing    -> return Nothing      Just (u,p) -> return (Just $ buildAuth ch u p)@@ -385,6 +396,7 @@       , bsMaxRedirects    :: Maybe Int       , bsMaxErrorRetries :: Maybe Int       , bsMaxAuthAttempts :: Maybe Int+      , bsMaxPoolSize     :: Maybe Int       , bsConnectionPool  :: [connection]       , bsCheckProxy      :: Bool       , bsProxy           :: Proxy@@ -401,22 +413,25 @@             ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ")  -- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'.-data BrowserAction conn a - = BA { lift :: BrowserState conn -> IO (BrowserState conn,a) }+newtype BrowserAction conn a+ = BA { unBA :: StateT (BrowserState conn) IO a }+#ifdef MTL1+ deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn)) -instance Monad (BrowserAction conn) where-    a >>= f  =  BA (\b -> do { (nb,v) <- lift a b ; lift (f v) nb})-    return x =  BA (\b -> return (b,x))-    fail x   =  BA (\_ -> fail x)+instance Applicative (BrowserAction conn) where+  pure  = return+  (<*>) = ap+#else+ deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn))+#endif -instance Functor (BrowserAction conn) where-    fmap f   = liftM f+runBA :: BrowserState conn -> BrowserAction conn a -> IO a+runBA bs = flip evalStateT bs . unBA  -- | @browse act@ is the toplevel action to perform a 'BrowserAction'. -- Example use: @browse (request (getRequest yourURL))@. browse :: BrowserAction conn a -> IO a-browse act = do x <- lift act defaultBrowserState-                return (snd x)+browse = runBA defaultBrowserState  -- | The default browser state has the settings  defaultBrowserState :: BrowserState t@@ -428,8 +443,7 @@      , bsCookies          = []      , bsCookieFilter     = defaultCookieFilter      , bsAuthorityGen     = \ _uri _realm -> do-          bsErr res "No action for prompting/generating user+password credentials \-                     \ provided (use: setAuthorityGen); returning Nothing"+          bsErr res "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing"           return Nothing      , bsAuthorities      = []      , bsAllowRedirects   = True@@ -437,6 +451,7 @@      , bsMaxRedirects     = Nothing      , bsMaxErrorRetries  = Nothing      , bsMaxAuthAttempts  = Nothing+     , bsMaxPoolSize      = Nothing      , bsConnectionPool   = []      , bsCheckProxy       = defaultAutoProxyDetect      , bsProxy            = noProxy@@ -446,21 +461,15 @@      , bsUserAgent        = Nothing      } --- | Alter browser state-alterBS :: (BrowserState t -> BrowserState t) -> BrowserAction t ()-alterBS f = BA (\b -> return (f b,()))--getBS :: (BrowserState t -> a) -> BrowserAction t a-getBS f = BA (\b -> return (b,f b))-+{-# DEPRECATED getBrowserState "Use Control.Monad.State.get instead." #-} -- | @getBrowserState@ returns the current browser config. Useful -- for restoring state across 'BrowserAction's. getBrowserState :: BrowserAction t (BrowserState t)-getBrowserState = getBS id+getBrowserState = get  -- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@. withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a-withBrowserState bs act = BA $ \ _ -> lift act bs+withBrowserState bs = BA . withStateT (const bs) . unBA  -- | @nextRequest act@ performs the browser action @act@ as -- the next request, i.e., setting up a new request context@@ -472,37 +481,38 @@         rid = succ (bsRequestID st)        in        rid `seq` st{bsRequestID=rid}-  alterBS updReqID+  modify updReqID   act  -- | Lifts an IO action into the 'BrowserAction' monad.+{-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-} ioAction :: IO a -> BrowserAction t a-ioAction a = BA (\b -> a >>= \v -> return (b,v))+ioAction = liftIO  -- | @setErrHandler@ sets the IO action to call when -- the browser reports running errors. To disable any -- such, set it to @const (return ())@. setErrHandler :: (String -> IO ()) -> BrowserAction t ()-setErrHandler h = alterBS (\b -> b { bsErr=h })+setErrHandler h = modify (\b -> b { bsErr=h })  -- | @setErrHandler@ sets the IO action to call when -- the browser chatters info on its running. To disable any -- such, set it to @const (return ())@. setOutHandler :: (String -> IO ()) -> BrowserAction t ()-setOutHandler h = alterBS (\b -> b { bsOut=h })+setOutHandler h = modify (\b -> b { bsOut=h })  out, err :: String -> BrowserAction t ()-out s = do { f <- getBS bsOut ; ioAction $ f s }-err s = do { f <- getBS bsErr ; ioAction $ f s }+out s = do { f <- gets bsOut ; liftIO $ f s }+err s = do { f <- gets bsErr ; liftIO $ f s }  -- | @setAllowRedirects onOff@ toggles the willingness to -- follow redirects (HTTP responses with 3xx status codes). setAllowRedirects :: Bool -> BrowserAction t ()-setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl})+setAllowRedirects bl = modify (\b -> b {bsAllowRedirects=bl})  -- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag. getAllowRedirects :: BrowserAction t Bool-getAllowRedirects = getBS bsAllowRedirects+getAllowRedirects = gets bsAllowRedirects  -- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops -- we are willing to jump through. A no-op if the count is negative; if zero,@@ -512,13 +522,24 @@ setMaxRedirects :: Maybe Int -> BrowserAction t () setMaxRedirects c   | fromMaybe 0 c < 0  = return ()- | otherwise          = alterBS (\b -> b{bsMaxRedirects=c})+ | otherwise          = modify (\b -> b{bsMaxRedirects=c})  -- | @getMaxRedirects@ returns the current setting for the max-redirect count. -- If @Nothing@, the "Network.Browser"'s default is used. getMaxRedirects :: BrowserAction t (Maybe Int)-getMaxRedirects = getBS bsMaxRedirects+getMaxRedirects = gets bsMaxRedirects +-- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool+-- that is used to cache connections between requests+setMaxPoolSize :: Maybe Int -> BrowserAction t ()+setMaxPoolSize c = modify (\b -> b{bsMaxPoolSize=c})++-- | @getMaxPoolSize@ gets the maximum size of the connection pool+-- that is used to cache connections between requests.+-- If @Nothing@, the "Network.Browser"'s default is used.+getMaxPoolSize :: BrowserAction t (Maybe Int)+getMaxPoolSize = gets bsMaxPoolSize+ -- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@. -- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted -- as the URL of the proxy to use, possibly authenticating via @@ -527,24 +548,24 @@ setProxy p =    -- Note: if user _explicitly_ sets the proxy, we turn    -- off any auto-detection of proxies.-  alterBS (\b -> b {bsProxy = p, bsCheckProxy=False})+  modify (\b -> b {bsProxy = p, bsCheckProxy=False})  -- | @getProxy@ returns the current proxy settings. If -- the auto-proxy flag is set to @True@, @getProxy@ will -- perform the necessary  getProxy :: BrowserAction t Proxy getProxy = do-  p <- getBS bsProxy+  p <- gets bsProxy   case p of       -- Note: if there is a proxy, no need to perform any auto-detect.       -- Presumably this is the user's explicit and preferred proxy server.     Proxy{} -> return p     NoProxy{} -> do-     flg <- getBS bsCheckProxy+     flg <- gets bsCheckProxy      if not flg       then return p        else do-       np <- ioAction $ fetchProxy True{-issue warning on stderr if ill-formed...-}+       np <- liftIO $ fetchProxy True{-issue warning on stderr if ill-formed...-}         -- note: this resets the check-proxy flag; a one-off affair.        setProxy np        return np@@ -554,7 +575,7 @@ -- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy' -- for details of how this done. setCheckForProxy :: Bool -> BrowserAction t ()-setCheckForProxy flg = alterBS (\ b -> b{bsCheckProxy=flg})+setCheckForProxy flg = modify (\ b -> b{bsCheckProxy=flg})  -- | @getCheckForProxy@ returns the current check-proxy setting. -- Notice that this may not be equal to @True@ if the session has@@ -563,24 +584,31 @@ -- whether a proxy will be checked for again before any future protocol -- interactions. getCheckForProxy :: BrowserAction t Bool-getCheckForProxy = getBS bsCheckProxy+getCheckForProxy = gets bsCheckProxy  -- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@ -- is @Nothing@. If set to @Just fStem@, logs of browser activity -- is appended to files of the form @fStem-url-authority@, i.e., -- @fStem@ is just the prefix for a set of log files, one per host/authority. setDebugLog :: Maybe String -> BrowserAction t ()-setDebugLog v = alterBS (\b -> b {bsDebug=v})+setDebugLog v = modify (\b -> b {bsDebug=v})  -- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It -- will be used if no explicit user agent header is found in subsequent requests.+--+-- A common form of user agent string is @\"name\/version (details)\"@. For+-- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version+-- of this HTTP package can be helpful if you ever need to track down HTTP+-- compatability quirks. This version is available via 'httpPackageVersion'.+-- For more info see <http://en.wikipedia.org/wiki/User_agent>.+-- setUserAgent :: String -> BrowserAction t ()-setUserAgent ua = alterBS (\b -> b{bsUserAgent=Just ua})+setUserAgent ua = modify (\b -> b{bsUserAgent=Just ua})  -- | @getUserAgent@ returns the current @User-Agent:@ default string. getUserAgent :: BrowserAction t String getUserAgent  = do-  n <- getBS bsUserAgent+  n <- gets bsUserAgent   return (maybe defaultUserAgent id n)  -- | @RequestState@ is an internal tallying type keeping track of various @@ -636,7 +664,7 @@ -- notified of browser events during the processing of a request -- by the Browser pipeline. setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty ()-setEventHandler mbH = alterBS (\b -> b { bsEvent=mbH})+setEventHandler mbH = modify (\b -> b { bsEvent=mbH})  buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent buildBrowserEvent bt uri reqID = do@@ -650,11 +678,11 @@  reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () reportEvent bt uri = do-  st <- getBrowserState+  st <- get   case bsEvent st of     Nothing -> return ()     Just evH -> do-       evt <- ioAction $ buildBrowserEvent bt uri (bsRequestID st)+       evt <- liftIO $ buildBrowserEvent bt uri (bsRequestID st)        evH evt -- if it fails, we fail.  -- | The default number of hops we are willing not to go beyond for @@ -706,6 +734,7 @@ 	 -> 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)@@ -733,9 +762,9 @@        case auth of          Nothing -> return rq          Just x  -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)-   let rq'' = insertHeaders (map cookieToHeader cookies) rq'+   let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq'    p <- getProxy-   def_ua <- getBS bsUserAgent+   def_ua <- gets bsUserAgent    let defaultOpts =           case p of  	   NoProxy     -> defaultNormalizeRequestOptions{normUserAgent=def_ua}@@ -832,7 +861,7 @@               case au of                Nothing  -> return (Right (uri,rsp))  {- do nothing -}                Just au' -> do-                 pxy <- getBS bsProxy+                 pxy <- gets bsProxy                  case pxy of                    NoProxy -> do                      err "Proxy authentication required without proxy!"@@ -846,7 +875,7 @@ 				     } 			      rq -      (3,0,x) | x /= 5  ->  do+      (3,0,x) | x `elem` [2,3,1,7]  ->  do         out ("30" ++ show x ++  " - redirect") 	allow_redirs <- allowRedirect rqState 	case allow_redirs of@@ -903,35 +932,8 @@ 				     , reqStopOnDeny = True 				     } 				     rq-      (3,_,_) -> redirect uri rsp       _       -> return (Right (uri,rsp)) -   where      -     redirect uri rsp = do-       rd   <- getAllowRedirects-       mbMxRetries <- getMaxRedirects-       if not rd || reqRedirects rqState > fromMaybe defaultMaxRetries mbMxRetries-        then return (Right (uri,rsp))-	else do-         case retrieveHeaders HdrLocation rsp of-          [] -> do -	    err "No Location header in redirect response."-            return (Right (uri,rsp))-          (Header _ u:_) -> -	    case parseURIReference u of-              Just newURI -> do-                let newURI_abs = maybe newURI id (newURI `relativeTo` uri)-                out ("Redirecting to " ++ show newURI_abs ++ " ...") -                request' nullVal-		         rqState{ reqDenies     = 0-			        , reqRedirects  = succ (reqRedirects rqState)-			        , reqStopOnDeny = True-				}-		         rq{rqURI=newURI_abs}-              Nothing -> do-                err ("Parse of Location header in a redirect response failed: " ++ u)-                return (Right (uri,rsp))- -- | The internal request handling state machine. dorequest :: (HStream ty)           => URIAuth@@ -939,15 +941,15 @@ 	  -> BrowserAction (HandleStream ty) 	                   (Result (Response ty)) dorequest hst rqst = do-  pool <- getBS bsConnectionPool-  conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool+  pool <- gets bsConnectionPool+  let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst+  conn <- liftIO $ filterM (\c -> c `isTCPConnectedTo` EndPoint (uriRegName hst) uPort) pool   rsp <-      case conn of       [] -> do          out ("Creating new connection to " ++ uriAuthToString hst)-        let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst 	reportEvent OpenConnection (show (rqURI rqst))-        c <- ioAction $ openStream (uriRegName hst) uPort+        c <- liftIO $ openStream (uriRegName hst) uPort 	updateConnectionPool c 	dorequest2 c rqst       (c:_) -> do@@ -960,17 +962,17 @@   return rsp  where   dorequest2 c r = do-    dbg <- getBS bsDebug-    st  <- getBrowserState+    dbg <- gets bsDebug+    st  <- get     let       onSendComplete =        maybe (return ())              (\evh -> do 	        x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)-		(lift (evh x)) st+		runBA st (evh x) 		return ())              (bsEvent st)-    ioAction $ +    liftIO $        maybe (sendHTTP_notify c r onSendComplete)             (\ f -> do                c' <- debugByteStream (f++'-': uriAuthToString hst) c@@ -981,19 +983,20 @@                      => HandleStream hTy 		     -> BrowserAction (HandleStream hTy) () updateConnectionPool c = do-   pool <- getBS bsConnectionPool+   pool <- gets bsConnectionPool    let len_pool = length pool+   maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize    when (len_pool > maxPoolSize)-        (ioAction $ close (last pool))+        (liftIO $ close (last pool))    let pool'  	| len_pool > maxPoolSize = init pool 	| otherwise              = pool-   alterBS (\b -> b { bsConnectionPool=c:pool' })+   when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' })    return ()                              --- | Maximum number of open connections we are willing to have active.-maxPoolSize :: Int-maxPoolSize = 5+-- | Default maximum number of open connections we are willing to have active.+defaultMaxPoolSize :: Int+defaultMaxPoolSize = 5  handleCookies :: URI -> String -> [Header] -> BrowserAction t () handleCookies _   _              [] = return () -- cut short the silliness.@@ -1003,7 +1006,7 @@   when (not $ null newCookies)        (out $ foldl (\x y -> x ++ "\n  " ++ show y) "Cookies received:" newCookies)   filterfn    <- getCookieFilter-  newCookies' <- ioAction (filterM (filterfn uri) newCookies)+  newCookies' <- liftIO (filterM (filterfn uri) newCookies)   when (not $ null newCookies')        (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies'))   mapM_ addCookie newCookies'

@@ -38,6 +38,8 @@ -- export the same functions, but leaves construction and any normalization of  -- @Request@s to the user. --+-- /NOTE:/ This package only supports HTTP; it does not support HTTPS.+-- Attempts to use HTTPS result in an error. ----------------------------------------------------------------------------- module Network.HTTP         ( module Network.HTTP.Base@@ -58,6 +60,7 @@                , getRequest      -- :: String -> Request_String        , postRequest     -- :: String -> Request_String+       , postRequestWithBody -- :: String -> String -> String -> Request_String                , getResponseBody -- :: Requesty ty -> ty        ) where@@ -97,6 +100,7 @@ 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@@ -153,6 +157,18 @@   case parseURI urlString of     Nothing -> error ("postRequest: Not a valid URL - " ++ urlString)     Just u  -> mkRequest POST u++-- | @postRequestWithBody urlString typ body@ is convenience constructor for+-- POST 'Request's. It constructs a request and sets the body as well as+-- the Content-Type and Content-Length headers. The contents of the body+-- are forced to calculate the value for the Content-Length header.+-- If @urlString@ isn\'t a syntactically valid URL, the function raises+-- an error.+postRequestWithBody :: String -> String -> String -> Request_String+postRequestWithBody urlString typ body = +  case parseURI urlString of+    Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString)+    Just u  -> setRequestBody (mkRequest POST u) (typ, body)  -- | @getResponseBody response@ takes the response of a HTTP requesting action and -- tries to extricate the body of the 'Response' @response@. If the request action

@@ -26,7 +26,7 @@ import Network.HTTP.Base import Network.HTTP.Utils import Network.HTTP.Headers ( Header(..) )-import qualified Network.HTTP.MD5 as MD5 (hash)+import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str)) import qualified Network.HTTP.Base64 as Base64 (encode) import Text.ParserCombinators.Parsec    ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 )@@ -122,14 +122,11 @@ stringToOctets :: String -> [Octet] stringToOctets = map (fromIntegral . fromEnum) -octetsToString :: [Octet] -> String-octetsToString = map (toEnum . fromIntegral)- base64encode :: String -> String base64encode = Base64.encode . stringToOctets  md5 :: String -> String-md5 = octetsToString . MD5.hash . stringToOctets+md5 = MD5.md5s . MD5.Str  kd :: String -> String -> String kd a b = md5 (a ++ ":" ++ b)@@ -158,11 +155,11 @@          cprops = sepBy1 cprop comma -        comma = do { spaces ; char ',' ; spaces }+        comma = do { spaces ; _ <- char ',' ; spaces }          cprop =             do { nm <- word-               ; char '='+               ; _ <- char '='                ; val <- quotedstring                ; return (map toLower nm,val)                }@@ -210,9 +207,9 @@  word, quotedstring :: Parser String quotedstring =-    do { char '"'  -- "+    do { _ <- char '"'  -- "        ; str <- many (satisfy $ not . (=='"'))-       ; char '"'+       ; _ <- char '"'        ; return str        } 

@@ -80,8 +80,10 @@        , defaultGETRequest        , defaultGETRequest_        , mkRequest+       , setRequestBody         , defaultUserAgent+       , httpPackageVersion        , libUA  {- backwards compatibility, will disappear..soon -}                , catchIO@@ -92,6 +94,8 @@        , getResponseVersion        , setRequestVersion        , setResponseVersion++       , failHTTPS                ) where @@ -120,6 +124,9 @@  import Control.Exception as Exception (IOException) +import qualified Paths_HTTP as Self (version)+import Data.Version (showVersion)+ ----------------------------------------------------------------- ------------------ URI Authority parsing ------------------------ -----------------------------------------------------------------@@ -190,6 +197,11 @@   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.@@ -336,12 +348,26 @@ ------------------------------------------------------------------ ------------------ Request Building ------------------------------ ------------------------------------------------------------------++-- | Deprecated. Use 'defaultUserAgent' libUA :: String libUA = "hs-HTTP-4000.0.9"+{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-} +-- | A default user agent string. The string is @\"haskell-HTTP/$version\"@+-- where @$version@ is the version of this HTTP package.+-- defaultUserAgent :: String-defaultUserAgent = libUA+defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion +-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This+-- may be useful to include in a user agent string so that you can determine+-- from server logs what version of this package HTTP clients are using.+-- This can be useful for tracking down HTTP compatibility quirks.+--+httpPackageVersion :: String+httpPackageVersion = showVersion Self.version+ defaultGETRequest :: URI -> Request_String defaultGETRequest uri = defaultGETRequest_ uri @@ -367,6 +393,14 @@    empty = buf_empty (toBufOps req) +-- set rqBody, Content-Type and Content-Length headers.+setRequestBody :: Request_String -> (String, String) -> Request_String+setRequestBody req (typ, body) = req' { rqBody=body }+  where+    req' = replaceHeader HdrContentType typ .+           replaceHeader HdrContentLength (show $ length body) $+           req+ {-     -- stub out the user info.   updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri)@@ -800,7 +834,7 @@ 	 case some of 	   Left e -> return (Left e) 	   Right cdata -> do-	       readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?+	       _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.? 	       chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size)      where       size 

@@ -196,11 +196,13 @@     let n = (a `shiftL` 18 .|. b `shiftL` 12)     in [ (chr (n `shiftR` 16 .&. 0xff)) ] -int4_char3 [] = []     +int4_char3 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints." +int4_char3 [] = []   + -- Convert triplets of characters to -- 4 base64 integers.  The last entries -- in the list may not produce 4 integers,@@ -242,6 +244,7 @@ quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t quadruplets [a,b,c]     = [a,b,c,'=']      -- 16bit tail unit quadruplets [a,b]       = [a,b,'=','=']    -- 8bit tail unit+quadruplets [_]         = error "Network.HTTP.Base64.quadruplets: impossible number of characters." quadruplets []          = []               -- 24bit tail unit  

@@ -17,7 +17,7 @@        , cookieMatch          -- :: (String,String) -> Cookie -> Bool            -- functions for translating cookies and headers.-       , cookieToHeader       -- :: Cookie -> Header+       , cookiesToHeader      -- :: [Cookie] -> Header        , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie])        ) where @@ -54,18 +54,16 @@             && ckName a == ckName b              && ckPath a == ckPath b --- | @cookieToHeader ck@ serialises a @Cookie@ to an HTTP request header.-cookieToHeader :: Cookie -> Header-cookieToHeader ck = Header HdrCookie text-    where-        path = maybe "" (";$Path="++) (ckPath ck)-        text = "$Version=" ++ fromMaybe "0" (ckVersion ck)-             ++ ';' : ckName ck ++ "=" ++ ckValue ck ++ path-             ++ (case ckPath ck of-                     Nothing -> ""-                     Just x  -> ";$Path=" ++ x)-             ++ ";$Domain=" ++ ckDomain ck+-- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header.+cookiesToHeader :: [Cookie] -> Header+cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs) +-- | Turn a list of cookies into a key=value pair list, separated by+-- semicolons.+mkCookieHeaderValue :: [Cookie] -> String+mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1+  where+    mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c  -- | @cookieMatch (domain,path) ck@ performs the standard cookie -- match wrt the given domain and path. @@ -93,14 +91,13 @@     cookie :: Parser Cookie    cookie =-       do { name <- word-          ; spaces_l-          ; char '='-          ; spaces_l-          ; val1 <- cvalue-          ; args <- cdetail-          ; return $ mkCookie name val1 args-          }+       do name <- word+          _    <- spaces_l+          _    <- char '='+          _    <- spaces_l+          val1 <- cvalue+          args <- cdetail+          return $ mkCookie name val1 args     cvalue :: Parser String    @@ -111,14 +108,14 @@    -- all keys in the result list MUST be in lower case    cdetail :: Parser [(String,String)]    cdetail = many $-       try (do { spaces_l-          ; char ';'-          ; spaces_l-          ; s1 <- word-          ; spaces_l-          ; s2 <- option "" (do { char '=' ; spaces_l ; v <- cvalue ; return v })-          ; return (map toLower s1,s2)-          })+       try (do _  <- spaces_l+               _  <- char ';'+               _  <- spaces_l+               s1 <- word+               _  <- spaces_l+               s2 <- option "" (char '=' >> spaces_l >> cvalue)+               return (map toLower s1,s2)+           )     mkCookie :: String -> String -> [(String,String)] -> Cookie    mkCookie nm cval more = @@ -136,10 +133,9 @@  word, quotedstring :: Parser String quotedstring =-    do { char '"'  -- "-       ; str <- many (satisfy $ not . (=='"'))-       ; char '"'-       ; return str-       }+    do _   <- char '"'  -- "+       str <- many (satisfy $ not . (=='"'))+       _   <- char '"'+       return str  word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))

@@ -53,6 +53,7 @@ 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_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

@@ -1,43 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Digest.MD5--- Copyright   :  (c) Dominic Steinitz 2004--- License     :  BSD-style (see the file ReadMe.tex)--- --- Maintainer  :  dominic.steinitz@blueyonder.co.uk--- Stability   :  experimental--- Portability :  portable------ Takes the MD5 module supplied by Ian Lynagh and wraps it so it--- takes [Octet] and returns [Octet] where the length of the result--- is always 16.--- See <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>--- and <http://www.ietf.org/rfc/rfc1321.txt>.-----------------------------------------------------------------------------------module Network.HTTP.MD5-   ( hash-   , Octet-   ) where--import Data.List (unfoldr)-import Data.Word (Word8)-import Numeric (readHex)--import Network.HTTP.MD5Aux (md5s, Str(Str))--type Octet = Word8---- | Take [Octet] and return [Octet] according to the standard.---   The length of the result is always 16 octets or 128 bits as required---   by the standard.--hash :: [Octet] -> [Octet]-hash xs = -   unfoldr f $ md5s $ Str $ map (toEnum . fromIntegral) xs-      where f :: String -> Maybe (Octet,String)-            f []       = Nothing-	    f [x]      = f ['0',x]-            f (x:y:zs) = Just (a,zs)-                         where [(a,_)] = readHex (x:y:[])

@@ -23,7 +23,8 @@  import Network.Stream (Stream(..)) import System.IO-   ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile+   ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile,+     hSetBuffering, BufferMode(NoBuffering)    ) import Network.TCP ( HandleStream, HStream,         		     StreamHooks(..), setStreamHooks, getStreamHooks )@@ -75,6 +76,7 @@       | hook_name h == file -> return stream -- reuse the stream hooks.      _ -> do        h <- openFile file AppendMode+       hSetBuffering h NoBuffering        hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")        setStreamHooks stream (debugStreamHooks h file)        return stream

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module      :  Network.StreamSocket

@@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- module Network.TCP    ( Connection+   , EndPoint(..)    , openTCPPort    , isConnectedTo @@ -77,12 +78,18 @@  newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} +data EndPoint = EndPoint { epHost :: String, epPort :: Int }++instance Eq EndPoint where+   EndPoint host1 port1 == EndPoint host2 port2 =+     map toLower host1 == map toLower host2 && port1 == port2+ data Conn a   = MkConn { connSock      :: ! Socket 	  , connHandle    :: Handle           , connBuffer    :: BufferOp a 	  , connInput     :: Maybe a-          , connHost      :: String+          , connEndPoint  :: EndPoint 	  , connHooks     :: Maybe (StreamHooks a) 	  , connCloseEOF  :: Bool -- True => close socket upon reaching end-of-stream.           }@@ -135,7 +142,7 @@ --  class BufferType bufType => HStream bufType where   openStream       :: String -> Int -> IO (HandleStream bufType)-  openSocketStream :: String -> Socket -> IO (HandleStream bufType)+  openSocketStream :: String -> Int -> Socket -> IO (HandleStream bufType)   readLine         :: HandleStream bufType -> IO (Result bufType)   readBlock        :: HandleStream bufType -> Int -> IO (Result bufType)   writeBlock       :: HandleStream bufType -> bufType -> IO (Result ())@@ -155,7 +162,7 @@  instance HStream Lazy.ByteString where     openStream       = \ a b -> openTCPConnection_ a b True-    openSocketStream = \ a b -> socketConnection_ a b True+    openSocketStream = \ a b c -> socketConnection_ a b c True     readBlock c n    = readBlockBS c n     readLine c       = readLineBS c     writeBlock c str = writeBlockBS c str@@ -205,14 +212,16 @@ openTCPConnection uri port = openTCPConnection_ uri port False  openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty)-openTCPConnection_ uri port stashInput = do-    s <- socket AF_INET Stream 6+openTCPConnection_ uri port stashInput = withSocket $ \s -> do     setSocketOption s KeepAlive 1     hostA <- getHostAddr uri     let a = SockAddrInet (toEnum port) hostA-    catchIO (connect s a) (\e -> sClose s >> ioError e)-    socketConnection_ uri s stashInput+    connect s a+    socketConnection_ uri port s stashInput  where+  withSocket action = do+    s <- socket AF_INET Stream 6+    catchIO (action s) (\e -> sClose s >> ioError e)   getHostAddr h = do     catchIO (inet_addr uri)    -- handles ascii IP numbers             (\ _ -> do@@ -228,18 +237,20 @@ -- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. socketConnection :: BufferType ty                  => String+                 -> Int 		 -> Socket 		 -> IO (HandleStream ty)-socketConnection hst sock = socketConnection_ hst sock False+socketConnection hst port sock = socketConnection_ hst port sock False  -- Internal function used to control the on-demand streaming of input -- for /lazy/ streams. socketConnection_ :: BufferType ty                   => String+                  -> Int 		  -> Socket 		  -> Bool 		  -> IO (HandleStream ty)-socketConnection_ hst sock stashInput = do+socketConnection_ hst port sock stashInput = do     h <- socketToHandle sock ReadWriteMode     mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing }     let conn = MkConn @@ -247,7 +258,7 @@ 	 , connHandle   = h 	 , connBuffer   = bufferOps 	 , connInput    = mb-	 , connHost     = hst+	 , connEndPoint = EndPoint hst port 	 , connHooks    = Nothing 	 , connCloseEOF = False 	 }@@ -284,23 +295,23 @@ -- | Checks both that the underlying Socket is connected -- and that the connection peer matches the given -- host name (which is recorded locally).-isConnectedTo :: Connection -> String -> IO Bool-isConnectedTo (Connection conn) name = do+isConnectedTo :: Connection -> EndPoint -> IO Bool+isConnectedTo (Connection conn) endPoint = do    v <- readMVar (getRef conn)    case v of      ConnClosed -> print "aa" >> return False      _ -      | map toLower (connHost v) == map toLower name ->+      | connEndPoint v == endPoint ->           catch (getPeerName (connSock v) >> return True) (const $ return False)       | otherwise -> return False -isTCPConnectedTo :: HandleStream ty -> String -> IO Bool-isTCPConnectedTo conn name = do+isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool+isTCPConnectedTo conn endPoint = do    v <- readMVar (getRef conn)    case v of      ConnClosed -> return False      _ -      | map toLower (connHost v) == map toLower name -> +      | connEndPoint v == endPoint ->           catch (getPeerName (connSock v) >> return True) (const $ return False)       | otherwise -> return False 

@@ -0,0 +1,574 @@+{-# LANGUAGE ViewPatterns #-}+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++import Network.Browser+import Network.HTTP+import Network.HTTP.Auth+import Network.HTTP.Headers+import Network.Stream (Result)+import Network.URI (uriPath, parseURI)++import System.Environment (getArgs)+import System.IO (getChar)++import Test.Framework (defaultMainWithArgs, testGroup)+import Test.Framework.Providers.HUnit+import Test.HUnit+++basicGetRequest :: Assertion+basicGetRequest = do+  response <- simpleHTTP (getRequest (testUrl "/basic/get"))+  code <- getResponseCode response+  assertEqual "HTTP status code" (2, 0, 0) code+  body <- getResponseBody response+  assertEqual "Receiving expected response" "It works." body++basicExample :: Assertion+basicExample = do+  result <-+    -- sample code from Network.HTTP haddock, with URL changed+    simpleHTTP (getRequest (testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody+  assertEqual "Receiving expected response" (take 100 haskellOrgText) result++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++basicPostRequest :: Assertion+basicPostRequest = do+  let sendBody = "body"+  response <- simpleHTTP $ postRequestWithBody (testUrl "/basic/post")+                                               "text/plain"+                                               sendBody+  code <- getResponseCode response+  assertEqual "HTTP status code" (2, 0, 0) code+  body <- getResponseBody response+  assertEqual "Receiving expected response"+              (show (Just "text/plain\r", Just "4\r", sendBody))+              body++basicAuthFailure :: Assertion+basicAuthFailure = do+  response <- simpleHTTP (getRequest (testUrl "/auth/basic"))+  code <- getResponseCode response+  body <- getResponseBody response+  assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body)++credentialsBasic = AuthBasic "Testing realm" "test" "password"+                             (fromJust . parseURI . testUrl $ "/auth/basic")++basicAuthSuccess :: Assertion+basicAuthSuccess = do+  let req = getRequest (testUrl "/auth/basic")+  let authString = withAuthority credentialsBasic req+  let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req }+  response <- simpleHTTP reqWithAuth+  code <- getResponseCode response+  body <- getResponseBody response+  assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)++browserExample :: Assertion+browserExample = do+  result <-+    -- sample code from Network.Browser haddock, with URL changed+    do +      (_, rsp)+         <- Network.Browser.browse $ do+               setAllowRedirects True -- handle HTTP redirects+               request $ getRequest (testUrl "/browser/example")+      return (take 100 (rspBody rsp))+  assertEqual "Receiving expected response" (take 100 haskellOrgText) result++-- A vanilla HTTP request using Browser shouln't send a cookie header+browserNoCookie :: Assertion+browserNoCookie = do+  (_, response) <- browse $ do+    setOutHandler (const $ return ())+    request $ getRequest (testUrl "/browser/no-cookie")+  let code = rspCode response+  assertEqual "HTTP status code" (2, 0, 0) code+++-- Regression test+--  * Browser sends vanilla request to server+--  * Server sets one cookie "hello=world"+--  * Browser sends a second request+--+-- Expected: Server gets single cookie with "hello=world"+-- Actual:   Server gets 3 extra cookies, which are actually cookie attributes:+--           "$Version=0;hello=world;$Domain=localhost:8080\r"+browserOneCookie :: Assertion+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")++    -- This second request should send a single Cookie: hello=world+    request $ getRequest (testUrl "/browser/one-cookie/2")+  let body = rspBody response+  assertEqual "Receiving expected response" "" body+  let code = rspCode response+  assertEqual "HTTP status code" (2, 0, 0) code++browserTwoCookies :: Assertion+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")++    -- This second request should send them back+    request $ getRequest (testUrl "/browser/two-cookies/2")+  let body = rspBody response+  assertEqual "Receiving expected response" "" body+  let code = rspCode response+  assertEqual "HTTP status code" (2, 0, 0) code+++browserFollowsRedirect :: Int -> Assertion+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.")+              (rspCode response, rspBody response)++browserReturnsRedirect :: Int -> Assertion+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), "")+              (rspCode response, rspBody response)++authGenBasic _ "Testing realm" = return $ Just ("test", "password")+authGenBasic _ realm = fail $ "Unexpected realm " ++ realm++browserBasicAuth :: Assertion+browserBasicAuth = do+  (_, response) <- browse $ do+    setOutHandler (const $ return ())+    setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14++    setAuthorityGen authGenBasic++    request $ getRequest (testUrl "/auth/basic")++  assertEqual "Receiving expected response from server"+              ((2, 0, 0), "Here's the secret")+              (rspCode response, rspBody response)++authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword")+authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm++browserDigestAuth :: Assertion+browserDigestAuth = do+  (_, response) <- browse $ do+    setOutHandler (const $ return ())+    setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14++    setAuthorityGen authGenDigest++    request $ getRequest (testUrl "/auth/digest")++  assertEqual "Receiving expected response from server"+              ((2, 0, 0), "Here's the digest secret")+              (rspCode response, rspBody response)++++browserAlt :: Assertion+browserAlt = do+  (response) <- browse $ do++    setOutHandler (const $ return ())++    (_, response1) <- request $ getRequest (altTestUrl "/basic/get")++    return response1++  assertEqual "Receiving expected response from alternate server"+              ((2, 0, 0), "This is the alternate server.")+              (rspCode response, rspBody response)++-- test that requests to multiple servers on the same host+-- don't get confused with each other+browserBoth :: Assertion+browserBoth = do+  (response1, response2) <- browse $ do+    setOutHandler (const $ return ())++    (_, response1) <- request $ getRequest (testUrl "/basic/get")+    (_, response2) <- request $ getRequest (altTestUrl "/basic/get")++    return (response1, response2)++  assertEqual "Receiving expected response from main server"+              ((2, 0, 0), "It works.")+              (rspCode response1, rspBody response1)++  assertEqual "Receiving expected response from alternate server"+              ((2, 0, 0), "This is the alternate server.")+              (rspCode response2, rspBody response2)++-- test that requests to multiple servers on the same host+-- don't get confused with each other+browserBothReversed :: Assertion+browserBothReversed = do+  (response1, response2) <- browse $ do+    setOutHandler (const $ return ())++    (_, response2) <- request $ getRequest (altTestUrl "/basic/get")+    (_, response1) <- request $ getRequest (testUrl "/basic/get")++    return (response1, response2)++  assertEqual "Receiving expected response from main server"+              ((2, 0, 0), "It works.")+              (rspCode response1, rspBody response1)++  assertEqual "Receiving expected response from alternate server"+              ((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+  (response1, response2) <- browse $ do+    setOutHandler (const $ return ())++    (_, response1) <- request $ getRequest (testUrl "/basic/get")+    (_, response2) <- request $ getRequest (testUrl "/basic/get2")++    return (response1, response2)++  assertEqual "Receiving expected response from main server"+              ((2, 0, 0), "It works.")+              (rspCode response1, rspBody response1)++  assertEqual "Receiving expected response from main server"+              ((2, 0, 0), "It works (2).")+              (rspCode response2, rspBody response2)+++browserTwoRequestsAlt :: Assertion+browserTwoRequestsAlt = do+  (response1, response2) <- browse $ do++    setOutHandler (const $ return ())++    (_, response1) <- request $ getRequest (altTestUrl "/basic/get")+    (_, response2) <- request $ getRequest (altTestUrl "/basic/get2")++    return (response1, response2)++  assertEqual "Receiving expected response from alternate server"+              ((2, 0, 0), "This is the alternate server.")+              (rspCode response1, rspBody response1)++  assertEqual "Receiving expected response from alternate server"+              ((2, 0, 0), "This is the alternate server (2).")+              (rspCode response2, rspBody response2)++browserTwoRequestsBoth :: Assertion+browserTwoRequestsBoth = do+  (response1, response2, response3, response4) <- browse $ do+    setOutHandler (const $ return ())++    (_, response1) <- request $ getRequest (testUrl "/basic/get")+    (_, response2) <- request $ getRequest (altTestUrl "/basic/get")+    (_, response3) <- request $ getRequest (testUrl "/basic/get2")+    (_, response4) <- request $ getRequest (altTestUrl "/basic/get2")++    return (response1, response2, response3, response4)++  assertEqual "Receiving expected response from main server"+              ((2, 0, 0), "It works.")+              (rspCode response1, rspBody response1)++  assertEqual "Receiving expected response from alternate server"+              ((2, 0, 0), "This is the alternate server.")+              (rspCode response2, rspBody response2)++  assertEqual "Receiving expected response from main server"+              ((2, 0, 0), "It works (2).")+              (rspCode response3, rspBody response3)++  assertEqual "Receiving expected response from alternate server"+              ((2, 0, 0), "This is the alternate server (2).")+              (rspCode response4, rspBody response4)++hasPrefix :: String -> String -> Maybe String+hasPrefix [] ys = Just ys+hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys+hasPrefix _ _ = Nothing++maybeRead :: Read a => String -> Maybe a+maybeRead s =+   case reads s of+     [(v, "")] -> Just v+     _ -> Nothing++splitFields = map (toPair '=' . trim isSpace) . splitOn ","++toPair c str = case break (==c) str of+                 (left, _:right) -> (left, right)+                 _ -> error $ "No " ++ show c ++ " in " ++ str+trim f = dropWhile f . reverse . dropWhile f . reverse++isSubsetOf xs ys = all (`elem` ys) xs++-- 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<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\" />"++processRequest :: Httpd.Request -> IO Httpd.Response+processRequest req = do+  case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of +    ("GET", "/basic/get") -> return $ Httpd.Response 200 [] "It works."+    ("GET", "/basic/get2") -> return $ Httpd.Response 200 [] "It works (2)."+    ("POST", "/basic/post") ->+        let typ = lookup "Content-Type" (Httpd.reqHeaders req)+            len = lookup "Content-Length" (Httpd.reqHeaders req)+            body = Httpd.reqBody req+        in return $ Httpd.Response 200 [] (show (typ, len, body))++    ("GET", "/basic/example") ->+      return $ Httpd.Response 200 [] haskellOrgText++    ("GET", "/auth/basic") ->+      case lookup "Authorization" (Httpd.reqHeaders req) of+        Just "Basic dGVzdDpwYXNzd29yZA==\r" -> return $ Httpd.Response 200 [] "Here's the secret"+        x -> return $ Httpd.Response 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x)++    ("GET", "/auth/digest") ->+      case lookup "Authorization" (Httpd.reqHeaders req) of+        Just (hasPrefix "Digest " -> Just (splitFields -> items))+          | [("username", show "test"), ("realm", show "Digest testing realm"), ("nonce", show "87e4"),+             ("uri", show (testUrl "/auth/digest")), ("opaque", show "057d"),+             ("response", show "ace810a3cfb830489a3b48e90a02b2ae")] `isSubsetOf` items+          -> return $ Httpd.Response 200 [] "Here's the digest secret"+          | [("username", show "test"), ("realm", show "Digest testing realm"), ("nonce", show "87e4"),+             ("uri", show "/auth/digest"), ("opaque", show "057d"),+             ("response", show "4845c3faf4dcb125b8dcc88b5c20bb89")] `isSubsetOf` items+          -> return $ Httpd.Response 200 [] "Here's the digest secret"+        x -> return $ Httpd.Response+                        401+                        [("WWW-Authenticate",+                          "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")]+                        (show x)++    ("GET", "/browser/example") ->+      return $ Httpd.Response 200 [] haskellOrgText+    ("GET", "/browser/no-cookie") ->+      case lookup "Cookie" (Httpd.reqHeaders req) of+        Nothing -> return $ Httpd.Response 200 [] ""+        Just s  -> return $ Httpd.Response 500 [] s+    ("GET", "/browser/one-cookie/1") ->+      return $ Httpd.Response 200 [("Set-Cookie", "hello=world")] ""+    ("GET", "/browser/one-cookie/2") ->+      case lookup "Cookie" (Httpd.reqHeaders req) of+        -- TODO: is it correct to expect the \r at the end?+        Just "hello=world\r" -> return $ Httpd.Response 200 [] ""+        Just s               -> return $ Httpd.Response 500 [] s+        Nothing              -> return $ Httpd.Response 500 [] (show $ Httpd.reqHeaders req)+    ("GET", "/browser/two-cookies/1") ->+      return $ Httpd.Response 200+                              [("Set-Cookie", "hello=world")+                              ,("Set-Cookie", "goodbye=cruelworld")]+                              ""+    ("GET", "/browser/two-cookies/2") ->+      case lookup "Cookie" (Httpd.reqHeaders req) of+        -- TODO: is it correct to expect the \r at the end?+        -- TODO generalise the cookie parsing to allow for whitespace/ordering variations+        Just "goodbye=cruelworld; hello=world\r" -> return $ Httpd.Response 200 [] ""+        Just s               -> return $ Httpd.Response 500 [] s+        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+altProcessRequest req = do+  case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of +    ("GET", "/basic/get") -> return $ Httpd.Response 200 [] "This is the alternate server."+    ("GET", "/basic/get2") -> return $ Httpd.Response 200 [] "This is the alternate server (2)."+    _                     -> return $ Httpd.Response 500 [] "Unknown request"++getResponseCode :: Result (Response a) -> IO ResponseCode+getResponseCode (Left err) = fail (show err)+getResponseCode (Right r)  = return (rspCode r)++maybeTestGroup True name xs = testGroup name xs+maybeTestGroup False name _ = testGroup name []++tests port80Server =+  [ testGroup "Basic tests"+    [ testCase "Basic GET request" basicGetRequest+    , testCase "Network.HTTP example code" basicExample+    , testCase "Secure GET request" secureGetRequest+    , testCase "Basic POST request" basicPostRequest+    , testCase "Basic Auth failure" basicAuthFailure+    , testCase "Basic Auth success" basicAuthSuccess+    ]+  , testGroup "Browser tests"+    [ testGroup "Basic"+      [+        -- github issue 14+        -- testCase "Two requests" browserTwoRequests+        testCase "Network.Browser example code" browserExample+      ]+    , testGroup "Secure"+      [+        testCase "Secure request" browserSecureRequest+      , testCase "After insecure" browserSecureRequestAfterInsecure+      , testCase "Redirection" browserRedirectToSecure+      ]+    , testGroup "Cookies"+      [ testCase "No cookie header" browserNoCookie+      , testCase "One cookie" browserOneCookie+      , testCase "Two cookies" browserTwoCookies+      ]+    , testGroup "Redirection"+      [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection+        -- 300 Multiple Choices: client has to handle this+        testCase "300" (browserReturnsRedirect 300)+        -- 301 Moved Permanently: should follow+      , testCase "301" (browserFollowsRedirect 301)+        -- 302 Found: should follow+      , testCase "302" (browserFollowsRedirect 302)+        -- 303 See Other: should follow (directly for GETs)+      , testCase "303" (browserFollowsRedirect 303)+        -- 304 Not Modified: maybe Browser could do something intelligent based on+        -- being given locally cached content and sending If-Modified-Since, but it+        -- doesn't at the moment+      , testCase "304" (browserReturnsRedirect 304)+      -- 305 Use Proxy: test harness doesn't have a proxy (yet)+      -- 306 Switch Proxy: obsolete+      -- 307 Temporary Redirect: should follow+      , testCase "307" (browserFollowsRedirect 307)+      -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this+      , testCase "308" (browserReturnsRedirect 308)+      ]+    , testGroup "Authentication"+      [ testCase "Basic" browserBasicAuth+      , testCase "Digest" browserDigestAuth+      ]+    ]+  , maybeTestGroup port80Server "Multiple servers"+    [ 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+    ]+  ]++portNum :: Int+portNum = 5812++altPortNum :: Int+altPortNum = 80++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+  case args of+     ["server"] -> do -- run only the harness servers for diagnostic/debug purposes+                      -- halt on any keypress+        _ <- forkIO (() <$ Httpd.initServer portNum processRequest)+        _ <- forkIO (() <$ Httpd.initServer altPortNum altProcessRequest)+        _ <- getChar+        return ()+     ("--withport80":args) -> do+        _ <- forkIO (() <$ Httpd.initServer portNum processRequest)+        _ <- forkIO (() <$ Httpd.initServer altPortNum altProcessRequest)+        _ <- threadDelay 1000000 -- Give the server time to start :-(+        defaultMainWithArgs (tests True) args+     args -> do -- run the test harness as normal+        _ <- forkIO (() <$ Httpd.initServer portNum processRequest)+        _ <- threadDelay 1000000 -- Give the server time to start :-(+        defaultMainWithArgs (tests False) args+