HTTP 4000.2.3 → 4000.2.4
raw patch · 9 files changed
+116/−47 lines, 9 filesdep +case-insensitivedep +conduitdep +deepseqdep ~basedep ~bytestringdep ~mtlPVP ok
version bump matches the API change (PVP)
Dependencies added: case-insensitive, conduit, deepseq, http-types, pureMD5, wai, warp
Dependency ranges changed: base, bytestring, mtl
API changes (from Hackage documentation)
+ Network.HTTP: getResponseCode :: Result (Response ty) -> IO ResponseCode
+ Network.HTTP: headRequest :: String -> Request_String
Files
- HTTP.cabal +19/−2
- Network/Browser.hs +4/−2
- Network/HTTP.hs +45/−12
- Network/HTTP/Base.hs +4/−3
- Network/HTTP/HandleStream.hs +13/−7
- Network/HTTP/Proxy.hs +5/−2
- Network/HTTP/Stream.hs +13/−7
- Network/StreamSocket.hs +2/−2
- Network/TCP.hs +11/−10
HTTP.cabal view
@@ -1,5 +1,5 @@ Name: HTTP-Version: 4000.2.3+Version: 4000.2.4 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3@@ -55,6 +55,10 @@ description: Use the old mtl version 1. default: False +Flag warn-as-error+ default: False+ description: Build with warnings-as-errors+ Library Exposed-modules: Network.BufferType,@@ -77,7 +81,7 @@ Network.HTTP.Utils Paths_HTTP GHC-options: -fwarn-missing-signatures -Wall- Build-depends: base >= 2 && < 4.6, network, parsec+ Build-depends: base >= 2 && < 4.7, network, parsec Extensions: FlexibleInstances if flag(old-base) Build-depends: base < 3@@ -89,6 +93,9 @@ else Build-depends: mtl >= 2.0 && < 2.2 + if flag(warn-as-error)+ ghc-options: -Werror+ if os(windows) Build-depends: Win32 @@ -103,8 +110,18 @@ build-depends: HTTP, HUnit, httpd-shed,+ mtl >= 2.0 && < 2.2,+ bytestring >= 0.9 && < 0.10,+ case-insensitive >= 0.4 && < 0.5,+ deepseq >= 1.3 && < 1.4,+ http-types >= 0.6 && < 0.7,+ conduit >= 0.4 && < 0.5,+ wai >= 1.2 && < 1.3,+ warp >= 1.2 && < 1.3,+ pureMD5 >= 2.1 && < 2.2, base >= 2 && < 4.6, network, split >= 0.1 && < 0.2, test-framework, test-framework-hunit+
Network/Browser.hs view
@@ -495,7 +495,7 @@ setErrHandler :: (String -> IO ()) -> BrowserAction t () setErrHandler h = modify (\b -> b { bsErr=h }) --- | @setErrHandler@ sets the IO action to call when+-- | @setOutHandler@ 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 ()@@ -809,7 +809,9 @@ case e_rsp of Left v | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && - (v == ErrorReset || v == ErrorClosed) ->+ (v == ErrorReset || v == ErrorClosed) -> do+ --empty connnection pool in case connection has become invalid+ modify (\b -> b { bsConnectionPool=[] }) request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq | otherwise -> return (Left v)
Network/HTTP.hs view
@@ -59,10 +59,12 @@ , module Network.TCP , getRequest -- :: String -> Request_String+ , headRequest -- :: String -> Request_String , postRequest -- :: String -> Request_String , postRequestWithBody -- :: String -> String -> String -> Request_String - , getResponseBody -- :: Requesty ty -> ty+ , getResponseBody -- :: Result (Request ty) -> IO ty+ , getResponseCode -- :: Result (Request ty) -> IO ResponseCode ) where -----------------------------------------------------------------@@ -142,29 +144,52 @@ respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () respondHTTP conn rsp = S.respondHTTP conn rsp --- | @getRequest urlString@ is convenience constructor for basic GET 'Request's. If--- @urlString@ isn't a syntactically valid URL, the function raises an error.-getRequest :: String -> Request_String++-- | A convenience constructor for a GET 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+getRequest+ :: String -- ^URL to fetch+ -> Request_String -- ^The constructed request getRequest urlString = case parseURI urlString of Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest GET u --- | @postRequest urlString@ is convenience constructor for POST 'Request's. If--- @urlString@ isn\'t a syntactically valid URL, the function raises an error.-postRequest :: String -> Request_String+-- | A convenience constructor for a HEAD 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+headRequest+ :: String -- ^URL to fetch+ -> Request_String -- ^The constructed request+headRequest urlString = + case parseURI urlString of+ Nothing -> error ("headRequest: Not a valid URL - " ++ urlString)+ Just u -> mkRequest HEAD u++-- | A convenience constructor for a POST 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+postRequest+ :: String -- ^URL to POST to+ -> Request_String -- ^The constructed request postRequest urlString = 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+-- | A convenience constructor for a POST 'Request'.+--+-- 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+--+-- If the URL isn\'t syntactically valid, the function raises an error.+postRequestWithBody+ :: String -- ^URL to POST to+ -> String -- ^Content-Type of body+ -> String -- ^The body of the request+ -> Request_String -- ^The constructed request postRequestWithBody urlString typ body = case parseURI urlString of Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString)@@ -176,6 +201,14 @@ getResponseBody :: Result (Response ty) -> IO ty getResponseBody (Left err) = fail (show err) getResponseBody (Right r) = return (rspBody r)++-- | @getResponseBody response@ takes the response of a HTTP requesting action and+-- tries to extricate the status code of the 'Response' @response@. If the request action+-- returned an error, an IO exception is raised.+getResponseCode :: Result (Response ty) -> IO ResponseCode+getResponseCode (Left err) = fail (show err)+getResponseCode (Right r) = return (rspCode r)+ -- -- * TODO
Network/HTTP/Base.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Base@@ -122,7 +123,7 @@ import Text.ParserCombinators.ReadP ( ReadP, readP_to_S, char, (<++), look, munch ) -import Control.Exception as Exception (IOException)+import Control.Exception as Exception (catch, IOException) import qualified Paths_HTTP as Self (version) import Data.Version (showVersion)@@ -886,10 +887,10 @@ -- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific -- tweaks better go here. catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO a h = Prelude.catch a h+catchIO a h = Exception.catch a h catchIO_ :: IO a -> IO a -> IO a-catchIO_ a h = Prelude.catch a (const h)+catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) responseParseError :: String -> String -> Result a responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v))
Network/HTTP/HandleStream.hs view
@@ -43,6 +43,7 @@ import Data.Char (toLower) import Data.Maybe (fromMaybe)+import Control.Exception (onException) import Control.Monad (when) -----------------------------------------------------------------@@ -88,8 +89,8 @@ -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True)- catchIO (sendMain conn rq onSendComplete)- (\e -> do { close conn; ioError e })+ onException (sendMain conn rq onSendComplete)+ (close conn) where providedClose = findConnClose (rqHeaders rq) @@ -112,9 +113,11 @@ --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst)- writeBlock conn (buf_fromStr bufferOps $ show rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (buf_fromStr bufferOps $ show rqst) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rqBody rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst@@ -150,7 +153,8 @@ Retry -> do {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -}- writeBlock conn ((buf_append bufferOps)+ -- TODO review throwing away of result+ _ <- writeBlock conn ((buf_append bufferOps) (buf_fromStr bufferOps (show rqst)) (rqBody rqst)) rsp <- getResponseHead conn@@ -228,9 +232,11 @@ -- server interactions, performing the dual role to 'sendHTTP'. respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () respondHTTP conn rsp = do - writeBlock conn (buf_fromStr bufferOps $ show rsp)+ -- TODO: review throwing away of result+ _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rspBody rsp)+ -- TODO: review throwing away of result+ _ <- writeBlock conn (rspBody rsp) return () ------------------------------------------------------------------------------
Network/HTTP/Proxy.hs view
@@ -21,6 +21,7 @@ import Control.Monad ( when, mplus, join, liftM2) +import Network.HTTP.Base ( catchIO ) import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) import Network.HTTP.Auth import Network.URI@@ -85,7 +86,7 @@ -- read proxy settings from the windows registry; this is just a best -- effort and may not work on all setups. -registryProxyString = Prelude.catch+registryProxyString = catchIO (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" if enable@@ -163,7 +164,9 @@ #if defined(WIN32) regQueryValueDWORD :: HKEY -> String -> IO DWORD regQueryValueDWORD hkey name = alloca $ \ptr -> do- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+ -- TODO: this throws away the key type returned by regQueryValueEx+ -- we should check it's what we expect instead+ _ <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) peek ptr #endif
Network/HTTP/Stream.hs view
@@ -49,6 +49,7 @@ import Data.Char (toLower) import Data.Maybe (fromMaybe)+import Control.Exception (onException) import Control.Monad (when) @@ -86,8 +87,8 @@ sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True)- catchIO (sendMain conn rq onSendComplete)- (\e -> do { close conn; ioError e })+ onException (sendMain conn rq onSendComplete)+ (close conn) where providedClose = findConnClose (rqHeaders rq) @@ -106,9 +107,11 @@ --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst)- writeBlock conn (show rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (show rqst) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rqBody rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst@@ -153,7 +156,8 @@ Retry -> {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -}- do { writeBlock conn (show rqst ++ rqBody rqst)+ do { -- TODO review throwing away of result+ _ <- writeBlock conn (show rqst ++ rqBody rqst) ; rsp <- getResponseHead conn ; switchResponse conn False bdy_sent rsp rqst } @@ -224,7 +228,9 @@ -- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. respondHTTP :: Stream s => s -> Response_String -> IO ()-respondHTTP conn rsp = do writeBlock conn (show rsp)+respondHTTP conn rsp = do -- TODO review throwing away of result+ _ <- writeBlock conn (show rsp) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rspBody rsp)+ -- TODO review throwing away of result+ _ <- writeBlock conn (rspBody rsp) return ()
Network/StreamSocket.hs view
@@ -36,7 +36,7 @@ import Network.HTTP.Base ( catchIO ) import Control.Monad (liftM) import Control.Exception as Exception (IOException)-import System.IO.Error (catch, isEOFError)+import System.IO.Error (isEOFError) -- | Exception handler for socket operations. handleSocketError :: Socket -> IOException -> IO (Result a)@@ -50,7 +50,7 @@ myrecv :: Socket -> Int -> IO String myrecv sock len = let handler e = if isEOFError e then return [] else ioError e- in System.IO.Error.catch (recv sock len) handler+ in catchIO (recv sock len) handler instance Stream Socket where readBlock sk n = readBlockSocket sk n
Network/TCP.hs view
@@ -58,6 +58,7 @@ import Data.Char ( toLower ) import Data.Word ( Word8 ) import Control.Concurrent+import Control.Exception ( onException ) import Control.Monad ( liftM, when ) import System.IO ( Handle, hFlush, IOMode(..), hClose ) import System.IO.Error ( isEOFError )@@ -221,7 +222,7 @@ where withSocket action = do s <- socket AF_INET Stream 6- catchIO (action s) (\e -> sClose s >> ioError e)+ onException (action s) (sClose s) getHostAddr h = do catchIO (inet_addr uri) -- handles ascii IP numbers (\ _ -> do@@ -302,7 +303,7 @@ ConnClosed -> print "aa" >> return False _ | connEndPoint v == endPoint ->- catch (getPeerName (connSock v) >> return True) (const $ return False)+ catchIO (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool@@ -312,7 +313,7 @@ ConnClosed -> return False _ | connEndPoint v == endPoint ->- catch (getPeerName (connSock v) >> return True) (const $ return False)+ catchIO (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a)@@ -364,18 +365,18 @@ modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b}) return (return a) _ -> do- Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)- (\ e -> + catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)+ (\ e -> if isEOFError e then do- when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ())+ when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) return (return (buf_empty (connBuffer conn))) else return (failMisc (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 (failMisc (show e)))+ catchIO (buf_hPut ops h b >> hFlush h >> return (return ()))+ (\ e -> return (failMisc (show e))) bufferReadLine :: HStream a => HandleStream a -> IO (Result a) bufferReadLine ref = onNonClosedDo ref $ \ conn -> do@@ -385,13 +386,13 @@ let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0 modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) return (return (buf_append (connBuffer conn) a newl))- _ -> Prelude.catch + _ -> catchIO (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e then do- when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ())+ when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) return (return (buf_empty (connBuffer conn))) else return (failMisc (show e))) where