diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,17 @@ +Version 4004.0.9: release 2009-12-20 + + * Export headerMap from Network.HTTP.Headers + (suggested by David Leuschner.) + * Fix Network.TCP.{isTCPConnectedTo,isConnectedTo} to be useful. + * Always delay closing non-persistent connections until we reach EOF. + Delaying it until then is vital when reading the response out as a + lazy ByteString; all of the I/O may not have happened by the time we + were returning the HTTP response. Bug manifested itself occasionally + with larger responses. Courtesy of Valery Vorotyntsev; both untiring bug + hunt and fix. + * drop unused type argument from Network.Browser.BrowserEvent; needlessly general. + (patch provided by Daniel Wagner.) + Version 4004.0.8: release 2009-08-05 * Incorporated proxy setting lookup and parsing contribution diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.0.8 +Version: 4000.0.9 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3 @@ -20,12 +20,23 @@ Synopsis: A library for client-side HTTP Description: - A package for sending and receiving HTTP requests and responses, all implemented - in Haskell (assuming you've already got a network stack to spare, via the 'network' - package!) The representation of content of in requests and responses is user-controllable, - letting you pick a representation that fits your code better (e.g., use @ByteString@s rather - than the default Haskell @String@s.) Example uses: + 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/") @@ -69,7 +80,7 @@ Network.HTTP.MD5Aux, Network.HTTP.Utils GHC-options: -fwarn-missing-signatures -Wall - Build-depends: base >= 2 && < 4 , network, parsec, mtl + Build-depends: base >= 2 && < 4, network, parsec, mtl if flag(old-base) Build-depends: base < 3 else diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -82,7 +82,7 @@ , setErrHandler -- :: (String -> IO ()) -> BrowserAction t () , setOutHandler -- :: (String -> IO ()) -> BrowserAction t () - , setEventHandler -- :: (BrowserEvent t -> BrowserAction t ()) -> BrowserAction t () + , setEventHandler -- :: (BrowserEvent -> BrowserAction t ()) -> BrowserAction t () , BrowserEvent(..) , BrowserEventType(..) @@ -96,6 +96,9 @@ , setDebugLog -- :: Maybe String -> BrowserAction t () + , getUserAgent -- :: BrowserAction t String + , setUserAgent -- :: String -> BrowserAction t () + , out -- :: String -> BrowserAction t () , err -- :: String -> BrowserAction t () , ioAction -- :: IO a -> BrowserAction a @@ -112,7 +115,7 @@ ) where import Network.URI - ( URI(uriAuthority, uriPath, uriQuery) + ( URI(..) , URIAuth(..) , parseURI, parseURIReference, relativeTo ) @@ -386,8 +389,9 @@ , bsCheckProxy :: Bool , bsProxy :: Proxy , bsDebug :: Maybe String - , bsEvent :: Maybe (BrowserEvent connection -> BrowserAction connection ()) + , bsEvent :: Maybe (BrowserEvent -> BrowserAction connection ()) , bsRequestID :: RequestID + , bsUserAgent :: Maybe String } instance Show (BrowserState t) where @@ -414,7 +418,7 @@ browse act = do x <- lift act defaultBrowserState return (snd x) --- | Default browser state.. +-- | The default browser state has the settings defaultBrowserState :: BrowserState t defaultBrowserState = res where @@ -439,6 +443,7 @@ , bsDebug = Nothing , bsEvent = Nothing , bsRequestID = 0 + , bsUserAgent = Nothing } -- | Alter browser state @@ -567,6 +572,17 @@ setDebugLog :: Maybe String -> BrowserAction t () setDebugLog v = alterBS (\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. +setUserAgent :: String -> BrowserAction t () +setUserAgent ua = alterBS (\b -> b{bsUserAgent=Just ua}) + +-- | @getUserAgent@ returns the current @User-Agent:@ default string. +getUserAgent :: BrowserAction t String +getUserAgent = do + n <- getBS bsUserAgent + return (maybe defaultUserAgent id n) + -- | @RequestState@ is an internal tallying type keeping track of various -- per-connection counters, like the number of authorization attempts and -- forwards we've gone through. @@ -592,47 +608,47 @@ -- via 'setEventHandler', will be passed. It indicates various state changes -- encountered in the processing of a given 'RequestID', along with timestamps -- at which they occurred. -data BrowserEvent ty +data BrowserEvent = BrowserEvent { browserTimestamp :: ClockTime , browserRequestID :: RequestID , browserRequestURI :: {-URI-}String - , browserEventType :: BrowserEventType ty + , browserEventType :: BrowserEventType } -- | 'BrowserEventType' is the enumerated list of events that the browser -- internals will report to a user-defined event handler. -data BrowserEventType ty +data BrowserEventType = OpenConnection | ReuseConnection | RequestSent + | ResponseEnd ResponseData + | ResponseFinish {- not yet, you will have to determine these via the ResponseEnd event. | Redirect | AuthChallenge | AuthResponse -} - | ResponseEnd ResponseData - | ResponseFinish -- | @setEventHandler onBrowserEvent@ configures event handling. -- If @onBrowserEvent@ is @Nothing@, event handling is turned off; -- setting it to @Just onEv@ causes the @onEv@ IO action to be -- notified of browser events during the processing of a request -- by the Browser pipeline. -setEventHandler :: Maybe (BrowserEvent ty -> BrowserAction ty ()) -> BrowserAction ty () +setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty () setEventHandler mbH = alterBS (\b -> b { bsEvent=mbH}) -buildBrowserEvent :: BrowserEventType t -> {-URI-}String -> RequestID -> IO (BrowserEvent t) +buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent buildBrowserEvent bt uri reqID = do ct <- getClockTime return BrowserEvent - { browserTimestamp = ct - , browserRequestID = reqID - , browserRequestURI = uri - , browserEventType = bt - } + { browserTimestamp = ct + , browserRequestID = reqID + , browserRequestURI = uri + , browserEventType = bt + } -reportEvent :: BrowserEventType t -> {-URI-}String -> BrowserAction t () +reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () reportEvent bt uri = do st <- getBrowserState case bsEvent st of @@ -719,13 +735,15 @@ Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) let rq'' = insertHeaders (map cookieToHeader cookies) rq' p <- getProxy + def_ua <- getBS bsUserAgent let defaultOpts = case p of - NoProxy -> defaultNormalizeRequestOptions + NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} Proxy _ ath -> defaultNormalizeRequestOptions - { normForProxy=True - , normCustoms = + { normForProxy = True + , normUserAgent = def_ua + , normCustoms = maybe [] (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) ath @@ -828,13 +846,12 @@ } rq - (3,0,x) | x == 3 || x == 2 -> do -- Redirect using GET request method. + (3,0,x) | x `elem` [2,3,1,7] -> do -- Redirect using GET request method. out ("30" ++ show x ++ " - redirect using GET") - rd <- getAllowRedirects - mbMxRetries <- getMaxRedirects - if not rd || reqRedirects rqState > fromMaybe defaultMaxRetries mbMxRetries - then return (Right (uri,rsp)) - else + allow_redirs <- allowRedirect rqState + case allow_redirs of + False -> return (Right (uri,rsp)) + _ -> do case retrieveHeaders HdrLocation rsp of [] -> do err "No Location: header in redirect response" @@ -844,17 +861,21 @@ Nothing -> do err ("Parse of Location: header in a redirect response failed: " ++ u) return (Right (uri,rsp)) - Just newuri -> do - out ("Redirecting to " ++ show newuri' ++ " ...") - let rq1 = rq { rqMethod=GET, rqURI=newuri', rqBody=nullVal } - request' nullVal - rqState{ reqDenies = 0 - , reqRedirects = succ(reqRedirects rqState) - , reqStopOnDeny = True - } - (replaceHeader HdrContentLength "0" rq1) + Just newURI + | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do + err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs) + return (Right (uri, rsp)) + | otherwise -> do + out ("Redirecting to " ++ show newURI_abs ++ " ...") + let rq1 = rq { rqMethod=GET, rqURI=newURI_abs, rqBody=nullVal } + request' nullVal + rqState{ reqDenies = 0 + , reqRedirects = succ(reqRedirects rqState) + , reqStopOnDeny = True + } + (replaceHeader HdrContentLength "0" rq1) where - newuri' = maybe newuri id (newuri `relativeTo` uri) + newURI_abs = maybe newURI id (newURI `relativeTo` uri) (3,0,5) -> case retrieveHeaders HdrLocation rsp of @@ -891,15 +912,15 @@ return (Right (uri,rsp)) (Header _ u:_) -> case parseURIReference u of - Just newuri -> do - let newuri' = maybe newuri id (newuri `relativeTo` uri) - out ("Redirecting to " ++ show newuri' ++ " ...") + 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'} + rq{rqURI=newURI_abs} Nothing -> do err ("Parse of Location header in a redirect response failed: " ++ u) return (Right (uri,rsp)) @@ -985,6 +1006,17 @@ ------------------------------------------------------------------ ----------------------- Miscellaneous ---------------------------- ------------------------------------------------------------------ + +allowRedirect :: RequestState -> BrowserAction t Bool +allowRedirect rqState = do + rd <- getAllowRedirects + mbMxRetries <- getMaxRedirects + return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries)) + +-- | Return @True@ iff the package is able to handle requests and responses +-- over it. +supportedScheme :: URI -> Bool +supportedScheme u = uriScheme u == "http:" -- | @uriDefaultTo a b@ returns a URI that is consistent with the first -- argument URI @a@ when read in the context of the second URI @b@. diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -337,7 +337,7 @@ ------------------ Request Building ------------------------------ ------------------------------------------------------------------ libUA :: String -libUA = "hs-HTTP-4000.0.5" +libUA = "hs-HTTP-4000.0.9" defaultUserAgent :: String defaultUserAgent = libUA @@ -664,8 +664,8 @@ Nothing -> req Just ua -> case findHeader HdrUserAgent req of - Nothing -> setHeaders req (mkHeader HdrUserAgent ua : getHeaders req) - Just{} -> req + Just u | u /= defaultUserAgent -> req + _ -> replaceHeader HdrUserAgent ua req -- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ -- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -85,14 +85,11 @@ -> IO () -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do - rsp <- catchIO (sendMain conn rq onSendComplete) - (\e -> do { close conn; ioError e }) - let fn list = when (or $ map findConnClose list) - (close conn) - either (\_ -> fn [rqHeaders rq]) - (\r -> fn [rqHeaders rq,rspHeaders r]) - rsp - return rsp + when providedClose $ (closeOnEnd conn True) + catchIO (sendMain conn rq onSendComplete) + (\e -> do { close conn; ioError e }) + where + providedClose = findConnClose (rqHeaders rq) -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows @@ -157,20 +154,34 @@ rsp <- getResponseHead conn switchResponse conn False bdy_sent rsp rqst - Done -> return (Right $ Response cd rn hdrs (buf_empty bufferOps)) + Done -> do + when (findConnClose hdrs) + (closeOnEnd conn True) + return (Right $ Response cd rn hdrs (buf_empty bufferOps)) - DieHorribly str -> return (responseParseError "Invalid response:" str) - ExpectEntity -> - fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ - maybe (maybe (hopefulTransfer bo (readLine conn) []) - (\ x -> - readsOne (linearTransfer (readBlock conn)) - (return$responseParseError "unrecognized content-length value" x) - x) - cl) - (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) - (uglyDeathTransfer "sendHTTP")) - tc + DieHorribly str -> do + close conn + return (responseParseError "Invalid response:" str) + ExpectEntity -> do + r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ + maybe (maybe (hopefulTransfer bo (readLine conn) []) + (\ x -> + readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized content-length value" x) + x) + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "sendHTTP")) + tc + case r of + Left{} -> do + close conn + return r + Right (Response _ _ hs _) -> do + when (findConnClose hs) + (closeOnEnd conn True) + return r + where tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs --- a/Network/HTTP/Headers.hs +++ b/Network/HTTP/Headers.hs @@ -36,6 +36,8 @@ , parseHeader -- :: parseHeader :: String -> Result Header , parseHeaders -- :: [String] -> Result [Header] + , headerMap -- :: [(String, HeaderName)] + , HeaderSetter ) where diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs --- a/Network/HTTP/Stream.hs +++ b/Network/HTTP/Stream.hs @@ -79,22 +79,17 @@ | otherwise = do s' <- debugStream httpLogFile s sendHTTP s' r - -- already done by sendHTTP because of "Connection: close" header - --; close s sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) sendHTTP conn rq = sendHTTP_notify conn rq (return ()) sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) -sendHTTP_notify conn rq onSendComplete = do - rsp <- catchIO (sendMain conn rq onSendComplete) - (\e -> do { close conn; ioError e }) - let fn list = when (or $ map findConnClose list) - (close conn) - either (\_ -> fn [rqHeaders rq]) - (\r -> fn [rqHeaders rq,rspHeaders r]) - rsp - return rsp +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + catchIO (sendMain conn rq onSendComplete) + (\e -> do { close conn; ioError e }) + where + providedClose = findConnClose (rqHeaders rq) -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows @@ -163,10 +158,13 @@ ; switchResponse conn False bdy_sent rsp rqst } - Done -> + Done -> do + when (findConnClose hdrs) + (closeOnEnd conn True) return (Right $ Response cd rn hdrs "") - DieHorribly str -> + DieHorribly str -> do + close conn return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) ExpectEntity -> @@ -183,9 +181,12 @@ "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "sendHTTP" - ; return $ do - (ftrs,bdy) <- rslt - return (Response cd rn (hdrs++ftrs) bdy) + ; case rslt of + Left e -> close conn >> return (Left e) + Right (ftrs,bdy) -> do + when (findConnClose (hdrs++ftrs)) + (closeOnEnd conn True) + return (Right (Response cd rn (hdrs++ftrs) bdy)) } -- | Receive and parse a HTTP request from the given Stream. Should be used diff --git a/Network/Stream.hs b/Network/Stream.hs --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -79,3 +79,6 @@ readBlock :: x -> Int -> IO (Result String) writeBlock :: x -> String -> IO (Result ()) close :: x -> IO () + closeOnEnd :: x -> Bool -> IO () + -- ^ True => shutdown the connection when response has been read / end-of-stream + -- has been reached. diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs --- a/Network/StreamDebugger.hs +++ b/Network/StreamDebugger.hs @@ -25,7 +25,8 @@ import System.IO ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile ) -import Network.TCP ( HandleStream, StreamHooks(..), HStream, setStreamHooks ) +import Network.TCP ( HandleStream, HStream, + StreamHooks(..), setStreamHooks, getStreamHooks ) -- | Allows stream logging. Refer to 'debugStream' below. data StreamDebugger x @@ -34,22 +35,29 @@ instance (Stream x) => Stream (StreamDebugger x) where readBlock (Dbg h x) n = do val <- readBlock x n - hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val) + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (show val) return val readLine (Dbg h x) = do val <- readLine x - hPutStrLn h ("readLine " ++ show val) + hPutStrLn h ("--readLine") + hPutStrLn h (show val) return val writeBlock (Dbg h x) str = do val <- writeBlock x str - hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str) + hPutStrLn h ("--writeBlock" ++ show str) + hPutStrLn h (show val) return val close (Dbg h x) = - do hPutStrLn h "closing..." + do hPutStrLn h "--closing..." hFlush h close x - hPutStrLn h "...closed" + hPutStrLn h "--closed." hClose h + closeOnEnd (Dbg h x) f = + do hPutStrLn h ("--close-on-end.." ++ show f) + hFlush h + closeOnEnd x f -- | Wraps a stream with logging I\/O. -- The first argument is a filename which is opened in @AppendMode@. @@ -60,25 +68,34 @@ return (Dbg h stream) debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty) -debugByteStream file stream = - do h <- openFile file AppendMode +debugByteStream file stream = do + sh <- getStreamHooks stream + case sh of + Just h + | hook_name h == file -> return stream -- reuse the stream hooks. + _ -> do + h <- openFile file AppendMode hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") - setStreamHooks stream (debugStreamHooks h) + setStreamHooks stream (debugStreamHooks h file) return stream -debugStreamHooks :: HStream ty => Handle -> StreamHooks ty -debugStreamHooks h = +debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty +debugStreamHooks h nm = StreamHooks { hook_readBlock = \ toStr n val -> do let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} - hPutStrLn h ("readBlock " ++ show n ++ ' ' : show eval) + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (either show show eval) , hook_readLine = \ toStr val -> do let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} - hPutStrLn h ("readLine " ++ show eval) + hPutStrLn h ("--readLine") + hPutStrLn h (either show show eval) , hook_writeBlock = \ toStr str val -> do - hPutStrLn h ("writeBlock " ++ show val ++ ' ' : toStr str) + hPutStrLn h ("--writeBlock " ++ show val) + hPutStrLn h (toStr str) , hook_close = do - hPutStrLn h "closing..." + hPutStrLn h "--closing..." hFlush h hClose h + , hook_name = nm } diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -55,8 +55,11 @@ readBlock sk n = readBlockSocket sk n readLine sk = readLineSocket sk writeBlock sk str = writeBlockSocket sk str - close sk = shutdown sk ShutdownBoth >> sClose sk - -- This slams closed the connection (which is considered rude for TCP\/IP) + close sk = do + -- This slams closed the connection (which is considered rude for TCP\/IP) + shutdown sk ShutdownBoth + sClose sk + closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here. readBlockSocket :: Socket -> Int -> IO (Result String) readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk) diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -28,6 +28,7 @@ , StreamHooks(..) , nullHooks , setStreamHooks + , getStreamHooks , hstreamToConnection ) where @@ -36,12 +37,12 @@ import Network.Socket ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive) , SocketType(Stream), inet_addr, connect - , shutdown, ShutdownCmd(ShutdownSend, ShutdownReceive) - , sClose, sIsConnected, setSocketOption + , shutdown, ShutdownCmd(..) + , sClose, setSocketOption, getPeerName , socket, Family(AF_INET) ) import qualified Network.Stream as Stream - ( Stream(readBlock, readLine, writeBlock, close) ) + ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) import Network.Stream ( ConnError(..) , Result @@ -55,7 +56,7 @@ import Data.Char ( toLower ) import Data.Word ( Word8 ) import Control.Concurrent -import Control.Monad ( liftM ) +import Control.Monad ( liftM, when ) import System.IO ( Handle, hFlush, IOMode(..), hClose ) import System.IO.Error ( isEOFError ) @@ -76,12 +77,13 @@ newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} data Conn a - = MkConn { connSock :: ! Socket - , connHandle :: Handle - , connBuffer :: BufferOp a - , connInput :: Maybe a - , connHost :: String - , connHooks :: Maybe (StreamHooks a) + = MkConn { connSock :: ! Socket + , connHandle :: Handle + , connBuffer :: BufferOp a + , connInput :: Maybe a + , connHost :: String + , connHooks :: Maybe (StreamHooks a) + , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. } | ConnClosed deriving(Eq) @@ -100,6 +102,7 @@ , hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO () , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO () , hook_close :: IO () + , hook_name :: String -- hack alert: name of the hook itself. } instance Eq ty => Eq (StreamHooks ty) where @@ -111,28 +114,32 @@ , hook_readBlock = \ _ _ _ -> return () , hook_writeBlock = \ _ _ _ -> return () , hook_close = return () + , hook_name = "" } setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) +getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty)) +getStreamHooks h = readMVar (getRef h) >>= return.connHooks + -- | @HStream@ overloads the use of 'HandleStream's, letting you -- overload the handle operations over the type that is communicated --- across the handle. It is used in the context of @Network.HTTP@ to --- buy us freedom in how HTTP 'Request' and 'Response' payloads are --- represented. +-- across the handle. It comes in handy for @Network.HTTP@ 'Request' +-- and 'Response's as the payload representation isn't fixed, but overloaded. -- --- The package provides instances for @ByteString@s and @String@, but +-- The library comes with instances for @ByteString@s and @String@, but -- should you want to plug in your own payload representation, defining --- your own @HStream@ instance is all it takes. +-- your own @HStream@ instance _should_ be all that it takes. -- class BufferType bufType => HStream bufType where openStream :: String -> Int -> IO (HandleStream bufType) openSocketStream :: String -> Socket -> IO (HandleStream bufType) - readLine :: HandleStream bufType -> IO (Result bufType) - readBlock :: HandleStream bufType -> Int -> IO (Result bufType) - writeBlock :: HandleStream bufType -> bufType -> IO (Result ()) - close :: HandleStream bufType -> IO () + readLine :: HandleStream bufType -> IO (Result bufType) + readBlock :: HandleStream bufType -> Int -> IO (Result bufType) + writeBlock :: HandleStream bufType -> bufType -> IO (Result ()) + close :: HandleStream bufType -> IO () + closeOnEnd :: HandleStream bufType -> Bool -> IO () instance HStream Strict.ByteString where openStream = openTCPConnection @@ -141,6 +148,7 @@ readLine c = readLineBS c writeBlock c str = writeBlockBS c str close c = closeIt c Strict.null + closeOnEnd c f = closeEOF c f instance HStream Lazy.ByteString where openStream = \ a b -> openTCPConnection_ a b True @@ -149,12 +157,14 @@ readLine c = readLineBS c writeBlock c str = writeBlockBS c str close c = closeIt c Lazy.null + closeOnEnd c f = closeEOF c f instance Stream.Stream Connection where - readBlock (Connection c) = Network.TCP.readBlock c - readLine (Connection c) = Network.TCP.readLine c - writeBlock (Connection c) = Network.TCP.writeBlock c - close (Connection c) = Network.TCP.close c + readBlock (Connection c) = Network.TCP.readBlock c + readLine (Connection c) = Network.TCP.readLine c + writeBlock (Connection c) = Network.TCP.writeBlock c + close (Connection c) = Network.TCP.close c + closeOnEnd (Connection c) f = Network.TCP.closeEOF c f instance HStream String where openStream = openTCPConnection @@ -174,6 +184,8 @@ -- (I think the behaviour here is TCP specific) close c = closeIt c null + closeOnEnd c f = closeEOF c f + -- | @openTCPPort uri port@ establishes a connection to a remote -- host, using 'getHostByName' which possibly queries the DNS system, hence -- may trigger a network connection. @@ -224,17 +236,18 @@ h <- socketToHandle sock ReadWriteMode mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing } let conn = MkConn - { connSock = sock - , connHandle = h - , connBuffer = bufferOps - , connInput = mb - , connHost = hst - , connHooks = Nothing + { connSock = sock + , connHandle = h + , connBuffer = bufferOps + , connInput = mb + , connHost = hst + , connHooks = Nothing + , connCloseEOF = False } v <- newMVar conn return (HandleStream v) -closeConnection :: HandleStream a -> IO Bool -> IO () +closeConnection :: HStream a => HandleStream a -> IO Bool -> IO () closeConnection ref readL = do -- won't hold onto the lock for the duration -- we are draining it...ToDo: have Connection @@ -249,6 +262,7 @@ closeConn ConnClosed = return () closeConn conn = do let sk = connSock conn + hFlush (connHandle conn) shutdown sk ShutdownSend suck readL hClose (connHandle conn) @@ -267,9 +281,10 @@ isConnectedTo (Connection conn) name = do v <- readMVar (getRef conn) case v of - ConnClosed -> return False + ConnClosed -> print "aa" >> return False _ - | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v) + | map toLower (connHost v) == map toLower name -> + catch (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False isTCPConnectedTo :: HandleStream ty -> String -> IO Bool @@ -278,10 +293,11 @@ case v of ConnClosed -> return False _ - | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v) + | map toLower (connHost v) == map toLower name -> + catch (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False -readBlockBS :: HandleStream a -> Int -> IO (Result a) +readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a) readBlockBS ref n = onNonClosedDo ref $ \ conn -> do x <- bufferGetBlock ref n maybe (return ()) @@ -291,7 +307,7 @@ -- This function uses a buffer, at this time the buffer is just 1000 characters. -- (however many bytes this is is left for the user to decipher) -readLineBS :: HandleStream a -> IO (Result a) +readLineBS :: HStream a => HandleStream a -> IO (Result a) readLineBS ref = onNonClosedDo ref $ \ conn -> do x <- bufferReadLine ref maybe (return ()) @@ -309,15 +325,18 @@ (connHooks' conn) return x -closeIt :: HandleStream ty -> (ty -> Bool) -> IO () +closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> IO () closeIt c p = do - closeConnection c (readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True}) - conn <- readMVar (getRef c) - maybe (return ()) - (hook_close) - (connHooks' conn) + closeConnection c (readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True}) + conn <- readMVar (getRef c) + maybe (return ()) + (hook_close) + (connHooks' conn) -bufferGetBlock :: HandleStream a -> Int -> IO (Result a) +closeEOF :: HandleStream ty -> Bool -> IO () +closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg}) + +bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a) bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do case connInput conn of Just c -> do @@ -326,16 +345,19 @@ return (return a) _ -> do Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return) - (\ e -> if isEOFError e - then return (return (buf_empty (connBuffer conn))) - else return (fail (show e))) + (\ e -> + if isEOFError e + then do + when (connCloseEOF conn) $ catch (close ref) (\ _ -> return ()) + return (return (buf_empty (connBuffer conn))) + else return (fail (show e))) bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) bufferPutBlock ops h b = Prelude.catch (buf_hPut ops h b >> hFlush h >> return (return ())) (\ e -> return (fail (show e))) -bufferReadLine :: HandleStream a -> IO (Result a) -- BufferOp a -> Handle -> IO (Result a) +bufferReadLine :: HStream a => HandleStream a -> IO (Result a) bufferReadLine ref = onNonClosedDo ref $ \ conn -> do case connInput conn of Just c -> do @@ -346,9 +368,11 @@ _ -> Prelude.catch (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . return . appendNL (connBuffer conn)) - (\ e -> + (\ e -> if isEOFError e - then return (return (buf_empty (connBuffer conn))) + then do + when (connCloseEOF conn) $ catch (close ref) (\ _ -> return ()) + return (return (buf_empty (connBuffer conn))) else return (fail (show e))) where -- yes, this s**ks.. _may_ have to be addressed if perf