patches from Duncan

HTTP.cabal

@@ -76,7 +76,6 @@ Library
                  Network.Browser
   Other-modules:
                  Network.HTTP.Base64,
-                 Network.HTTP.MD5,
                  Network.HTTP.MD5Aux,
                  Network.HTTP.Utils
   GHC-options: -fwarn-missing-signatures -Wall

Network/Browser.hs

@@ -385,7 +385,7 @@ data BrowserState connection
       , bsMaxRedirects    :: Maybe Int
       , bsMaxErrorRetries :: Maybe Int
       , bsMaxAuthAttempts :: Maybe Int
-      , bsConnectionPool  :: [connection]
+      , bsConnectionPool  :: [(String,Int,connection)] -- (host,port,conn)
       , bsCheckProxy      :: Bool
       , bsProxy           :: Proxy
       , bsDebug           :: Maybe String
@@ -846,7 +846,7 @@ request' nullVal rqState rq = do
 				     }
 			      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 +903,8 @@ request' nullVal rqState rq = do
 				     , 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
@@ -940,15 +913,18 @@ dorequest :: (HStream ty)
 	                   (Result (Response ty))
 dorequest hst rqst = do
   pool <- getBS bsConnectionPool
-  conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool
+  conn <- ioAction $ filterM isTCPConnected
+                             [ c | (hostname,portnum, c) <- pool
+                                 , hostname == uriRegName hst
+                                 , portnum  == uriAuthPort Nothing hst ]
   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
-	updateConnectionPool c
+	updateConnectionPool (uriRegName hst, uPort, c)
 	dorequest2 c rqst
       (c:_) -> do
         out ("Recovering connection to " ++ uriAuthToString hst)
@@ -978,13 +954,14 @@ dorequest hst rqst = do
 	    dbg
 
 updateConnectionPool :: HStream hTy
-                     => HandleStream hTy
+                     => (String, Int, HandleStream hTy)
 		     -> BrowserAction (HandleStream hTy) ()
 updateConnectionPool c = do
    pool <- getBS bsConnectionPool
    let len_pool = length pool
+       (_,_,last_conn) = last pool
    when (len_pool > maxPoolSize)
-        (ioAction $ close (last pool))
+        (ioAction $ close last_conn)
    let pool' 
 	| len_pool > maxPoolSize = init pool
 	| otherwise              = pool

Network/HTTP/Auth.hs

@@ -26,7 +26,7 @@ import Network.URI
 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 @@ type Octet = Word8
 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)

Network/TCP.hs

@@ -16,10 +16,12 @@
 module Network.TCP
    ( Connection
    , openTCPPort
+   , isConnected
    , isConnectedTo
 
    , openTCPConnection
    , socketConnection
+   , isTCPConnected
    , isTCPConnectedTo
 
    , HandleStream
@@ -83,6 +85,8 @@ data Conn a
           , connBuffer    :: BufferOp a
 	  , connInput     :: Maybe a
           , connHost      :: String
+            --Note: connHost only used for deprecated isConnectedTo
+            --      so can remove when isConnectedTo is removed.
 	  , connHooks     :: Maybe (StreamHooks a)
 	  , connCloseEOF  :: Bool -- True => close socket upon reaching end-of-stream.
           }
@@ -281,6 +285,26 @@ closeConnection ref readL = do
     f <- rd
     if f then return () else suck rd
 
+-- | Checks that the underlying Socket is connected
+isConnected :: Connection -> IO Bool
+isConnected (Connection conn) = do
+   v <- readMVar (getRef conn)
+   case v of
+     ConnClosed -> return False
+     _          -> catch (getPeerName (connSock v) >> return True)
+                         (const $ return False)
+
+isTCPConnected :: HandleStream ty -> IO Bool
+isTCPConnected conn = do
+   v <- readMVar (getRef conn)
+   case v of
+     ConnClosed -> return False
+     _          -> catch (getPeerName (connSock v) >> return True)
+                         (const $ return False)
+
+{-# DEPRECATED isConnectedTo, isTCPConnectedTo
+    "This function is silly, use isConnected or isTCPConnected" #-}
+
 -- | Checks both that the underlying Socket is connected
 -- and that the connection peer matches the given
 -- host name (which is recorded locally).