diff --git a/HTTP.cabal b/HTTP.cabal
index d351203..f5f46d5 100644
--- a/HTTP.cabal
+++ b/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
diff --git a/Network/Browser.hs b/Network/Browser.hs
index 0f43ae1..14686e6 100644
--- a/Network/Browser.hs
+++ b/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,7 +913,10 @@ 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
@@ -948,7 +924,7 @@ dorequest hst rqst = do
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
diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs
index 8f3ef14..681b348 100644
--- a/Network/HTTP/Auth.hs
+++ b/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)
diff --git a/Network/HTTP/MD5.hs b/Network/HTTP/MD5.hs
deleted file mode 100644
index ca157de..0000000
--- a/Network/HTTP/MD5.hs
+++ /dev/null
@@ -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
--- and .
---
------------------------------------------------------------------------------
-
-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:[])
diff --git a/Network/TCP.hs b/Network/TCP.hs
index 225ea15..975941d 100644
--- a/Network/TCP.hs
+++ 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).