HTTP 4000.0.1 → 4000.0.2
raw patch · 9 files changed
+370/−314 lines, 9 filesdep +mtlPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: mtl
API changes (from Hackage documentation)
- Network.HTTP.Base: data HTTPRequest a
- Network.HTTP.Base: data HTTPResponse a
- Network.HTTP.Base: instance HasHeaders (HTTPRequest a)
- Network.HTTP.Base: instance HasHeaders (HTTPResponse a)
- Network.HTTP.Base: instance Show (HTTPRequest a)
- Network.HTTP.Base: instance Show (HTTPResponse a)
- Network.HTTP.Base: type Request = HTTPRequest String
- Network.HTTP.Base: type Response = HTTPResponse String
+ Network.Browser: defaultGETRequest_ :: (BufferType a) => URI -> Request a
+ Network.Browser: getBrowserState :: BrowserAction t (BrowserState t)
+ Network.Browser: withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a
+ Network.HTTP.Base: data Request a
+ Network.HTTP.Base: data Response a
+ Network.HTTP.Base: instance HasHeaders (Request a)
+ Network.HTTP.Base: instance HasHeaders (Response a)
+ Network.HTTP.Base: instance Show (Request a)
+ Network.HTTP.Base: instance Show (Response a)
+ Network.HTTP.Base: responseParseError :: String -> String -> Result a
+ Network.HTTP.Base: type HTTPRequest a = Request a
+ Network.HTTP.Base: type HTTPResponse a = Response a
+ Network.HTTP.Base: type Request_String = Request String
+ Network.HTTP.Base: type Response_String = Response String
+ Network.Stream: failParse :: String -> Result a
+ Network.Stream: failWith :: ConnError -> Result a
+ Network.Stream: fmapE :: (a -> Result b) -> IO (Result a) -> IO (Result b)
+ Network.Stream: instance Error ConnError
- Network.Browser: defaultGETRequest :: URI -> Request
+ Network.Browser: defaultGETRequest :: URI -> Request_String
- Network.Browser: formToRequest :: Form -> Request
+ Network.Browser: formToRequest :: Form -> Request_String
- Network.Browser: request :: (HStream ty) => HTTPRequest ty -> BrowserAction (HandleStream ty) (URI, HTTPResponse ty)
+ Network.Browser: request :: (HStream ty) => Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
- Network.HTTP.Base: Request :: URI -> RequestMethod -> [Header] -> a -> HTTPRequest a
+ Network.HTTP.Base: Request :: URI -> RequestMethod -> [Header] -> a -> Request a
- Network.HTTP.Base: Response :: ResponseCode -> String -> [Header] -> a -> HTTPResponse a
+ Network.HTTP.Base: Response :: ResponseCode -> String -> [Header] -> a -> Response a
- Network.HTTP.Base: getAuth :: (Monad m) => HTTPRequest ty -> m URIAuthority
+ Network.HTTP.Base: getAuth :: (Monad m) => Request ty -> m URIAuthority
- Network.HTTP.Base: normalizeHostHeader :: HTTPRequest ty -> HTTPRequest ty
+ Network.HTTP.Base: normalizeHostHeader :: Request ty -> Request ty
- Network.HTTP.Base: normalizeRequestURI :: URIAuthority -> HTTPRequest ty -> HTTPRequest ty
+ Network.HTTP.Base: normalizeRequestURI :: String -> Request ty -> Request ty
- Network.HTTP.Base: rqBody :: HTTPRequest a -> a
+ Network.HTTP.Base: rqBody :: Request a -> a
- Network.HTTP.Base: rqHeaders :: HTTPRequest a -> [Header]
+ Network.HTTP.Base: rqHeaders :: Request a -> [Header]
- Network.HTTP.Base: rqMethod :: HTTPRequest a -> RequestMethod
+ Network.HTTP.Base: rqMethod :: Request a -> RequestMethod
- Network.HTTP.Base: rqURI :: HTTPRequest a -> URI
+ Network.HTTP.Base: rqURI :: Request a -> URI
- Network.HTTP.Base: rspBody :: HTTPResponse a -> a
+ Network.HTTP.Base: rspBody :: Response a -> a
- Network.HTTP.Base: rspCode :: HTTPResponse a -> ResponseCode
+ Network.HTTP.Base: rspCode :: Response a -> ResponseCode
- Network.HTTP.Base: rspHeaders :: HTTPResponse a -> [Header]
+ Network.HTTP.Base: rspHeaders :: Response a -> [Header]
- Network.HTTP.Base: rspReason :: HTTPResponse a -> String
+ Network.HTTP.Base: rspReason :: Response a -> String
- Network.HTTP.Base: uglyDeathTransfer :: IO (Result ([Header], a))
+ Network.HTTP.Base: uglyDeathTransfer :: String -> IO (Result ([Header], a))
- Network.HTTP.HandleStream: receiveHTTP :: (HStream bufTy) => HandleStream bufTy -> IO (Result (HTTPRequest bufTy))
+ Network.HTTP.HandleStream: receiveHTTP :: (HStream bufTy) => HandleStream bufTy -> IO (Result (Request bufTy))
- Network.HTTP.HandleStream: respondHTTP :: (HStream ty) => HandleStream ty -> HTTPResponse ty -> IO ()
+ Network.HTTP.HandleStream: respondHTTP :: (HStream ty) => HandleStream ty -> Response ty -> IO ()
- Network.HTTP.HandleStream: sendHTTP :: (HStream ty) => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))
+ Network.HTTP.HandleStream: sendHTTP :: (HStream ty) => HandleStream ty -> Request ty -> IO (Result (Response ty))
- Network.HTTP.HandleStream: simpleHTTP :: (HStream ty) => HTTPRequest ty -> IO (Result (HTTPResponse ty))
+ Network.HTTP.HandleStream: simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty))
- Network.HTTP.HandleStream: simpleHTTP_ :: (HStream ty) => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))
+ Network.HTTP.HandleStream: simpleHTTP_ :: (HStream ty) => HandleStream ty -> Request ty -> IO (Result (Response ty))
- Network.HTTP.HandleStream: simpleHTTP_debug :: (HStream ty) => FilePath -> HTTPRequest ty -> IO (Result (HTTPResponse ty))
+ Network.HTTP.HandleStream: simpleHTTP_debug :: (HStream ty) => FilePath -> Request ty -> IO (Result (Response ty))
- Network.HTTP.Stream: receiveHTTP :: (Stream s) => s -> IO (Result Request)
+ Network.HTTP.Stream: receiveHTTP :: (Stream s) => s -> IO (Result Request_String)
- Network.HTTP.Stream: respondHTTP :: (Stream s) => s -> Response -> IO ()
+ Network.HTTP.Stream: respondHTTP :: (Stream s) => s -> Response_String -> IO ()
- Network.HTTP.Stream: sendHTTP :: (Stream s) => s -> Request -> IO (Result Response)
+ Network.HTTP.Stream: sendHTTP :: (Stream s) => s -> Request_String -> IO (Result Response_String)
- Network.HTTP.Stream: simpleHTTP :: Request -> IO (Result Response)
+ Network.HTTP.Stream: simpleHTTP :: Request_String -> IO (Result Response_String)
- Network.HTTP.Stream: simpleHTTP_ :: (Stream s) => s -> Request -> IO (Result Response)
+ Network.HTTP.Stream: simpleHTTP_ :: (Stream s) => s -> Request_String -> IO (Result Response_String)
Files
- HTTP.cabal +9/−4
- Network/Browser.hs +75/−50
- Network/HTTP.hs +12/−33
- Network/HTTP/Base.hs +87/−74
- Network/HTTP/HandleStream.hs +76/−66
- Network/HTTP/Headers.hs +11/−9
- Network/HTTP/Stream.hs +25/−22
- Network/Stream.hs +23/−0
- Network/TCP.hs +52/−56
HTTP.cabal view
@@ -1,5 +1,5 @@ Name: HTTP-Version: 4000.0.1+Version: 4000.0.2 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3@@ -12,12 +12,15 @@ Copyright (c) 2004, Ganesh Sittampalam Copyright (c) 2004-2005, Dominic Steinitz Copyright 2007 Robin Bate Boerop+ Copyright 2008-2009 Sigbjorn Finne Author: Warrick Gray <warrick.gray@hotmail.com> Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> Homepage: http://www.haskell.org/http/+Category: Network+Synopsis: A library for client-side HTTP Description: - A library for client-side HTTP, version 2. Rewrite of existing HTTP+ A library for client-side HTTP, version 4. Rewrite of existing HTTP package to allow overloaded representation of HTTP request bodies and responses. Provides three such instances: lazy and strict 'ByteString', along with the good old @String@.@@ -50,9 +53,11 @@ Network.HTTP.MD5Aux, Network.HTTP.Utils GHC-options: -fwarn-missing-signatures -Wall- Build-depends: network, parsec, bytestring+ Build-depends: network, parsec, bytestring, mtl if flag(old-base) Build-depends: base < 3 else- Build-depends: base >= 3, array+ Build-depends: base >= 3+ + Build-depends: array
Network/Browser.hs view
@@ -38,6 +38,9 @@ browse, -- BrowserAction a -> IO a request, -- Request -> BrowserAction Response + getBrowserState,+ withBrowserState,+ setAllowRedirects, getAllowRedirects, @@ -69,6 +72,7 @@ ioAction, -- :: IO a -> BrowserAction a defaultGETRequest,+ defaultGETRequest_, formToRequest, uriDefaultTo, uriTrimHost@@ -83,7 +87,7 @@ import Network.HTTP import qualified Network.HTTP.MD5 as MD5 (hash) import qualified Network.HTTP.Base64 as Base64 (encode)-import Network.Stream ( ConnError(..) )+import Network.Stream ( ConnError(..), Result ) import Network.BufferType import Network.HTTP.Utils ( trim, splitBy )@@ -101,7 +105,6 @@ , BufferMode(NoBuffering, LineBuffering) ) import Data.Word (Word8)-import Debug.Trace type Octet = Word8 @@ -111,7 +114,7 @@ word, quotedstring :: Parser String quotedstring =- do { char '"' -- "+ do { char '"' ; str <- many (satisfy $ not . (=='"')) ; char '"' ; return str@@ -125,16 +128,11 @@ -- If second argument is not sufficient context for -- determining a full URI then anarchy reins. uriDefaultTo :: URI -> URI -> URI-uriDefaultTo a b =- case a `relativeTo` b of- Nothing -> a- Just x -> x-+uriDefaultTo a b = maybe a id (a `relativeTo` b) uriTrimHost :: URI -> URI uriTrimHost uri = uri { uriScheme="", uriAuthority=Nothing } - ------------------------------------------------------------------ ----------------------- Cookie Stuff ----------------------------- ------------------------------------------------------------------@@ -142,13 +140,15 @@ -- Some conventions: -- assume ckDomain is lowercase ---data Cookie = MkCookie { ckDomain- , ckName- , ckValue :: String- , ckPath- , ckComment- , ckVersion :: Maybe String- }+data Cookie + = MkCookie + { ckDomain :: String+ , ckName :: String+ , ckValue :: String+ , ckPath :: Maybe String+ , ckComment :: Maybe String+ , ckVersion :: Maybe String+ } deriving(Show,Read) @@ -168,10 +168,8 @@ case ckComment cky of Nothing -> return () Just x -> putStrLn ("Cookie Comment:\n" ++ x)- putStrLn ("Domain/Path: " ++ ckDomain cky ++ - case ckPath cky of- Nothing -> ""- Just x -> "/" ++ x)+ let pth = maybe "" ('/':) (ckPath cky)+ putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth) putStrLn (ckName cky ++ '=' : ckValue cky) System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering@@ -187,21 +185,21 @@ cookieToHeader :: Cookie -> Header cookieToHeader ck = Header HdrCookie text where+ path = maybe "" (";$Path="++) (ckPath ck) text = "$Version=" ++ fromMaybe "0" (ckVersion ck)- ++ ';' : ckName ck ++ "=" ++ ckValue ck+ ++ ';' : ckName ck ++ "=" ++ ckValue ck ++ path ++ (case ckPath ck of Nothing -> "" Just x -> ";$Path=" ++ x) ++ ";$Domain=" ++ ckDomain ck - {- replace "error" call with [] in final version? -} headerToCookies :: String -> Header -> [Cookie] headerToCookies dom (Header HdrSetCookie val) = case parse cookies "" val of Left e -> error ("Cookie parse failure on: " ++ val ++ " " ++ show e) - Right x -> x+ Right x -> x where cookies :: Parser [Cookie] cookies = sepBy1 cookie (char ',')@@ -480,7 +478,7 @@ -- | Retrieve a likely looking authority for a Request.-anticipateChallenge :: HTTPRequest ty -> BrowserAction t (Maybe Authority)+anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority) anticipateChallenge rq = let uri = rqURI rq in do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri)@@ -532,7 +530,7 @@ -- the context of a specific request. If a client nonce -- was to be used then this function might need to -- be of type ... -> BrowserAction String-withAuthority :: Authority -> HTTPRequest ty -> String+withAuthority :: Authority -> Request ty -> String withAuthority a rq = case a of AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) AuthDigest{} ->@@ -634,12 +632,15 @@ return (snd x) defaultBrowserState :: BrowserState t-defaultBrowserState = - BS { bsErr = putStrLn+defaultBrowserState = res+ where+ res = BS+ { bsErr = putStrLn , bsOut = putStrLn , bsCookies = [] , bsCookieFilter = defaultCookieFilter- , bsAuthorityGen = (error "bsAuthGen wanted")+ , bsAuthorityGen = \ _uri _realm -> + (bsErr res) ("No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing") >> return Nothing , bsAuthorities = [] , bsAllowRedirects = True , bsAllowBasicAuth = False@@ -655,6 +656,12 @@ getBS :: (BrowserState t -> a) -> BrowserAction t a getBS f = BA (\b -> return (b,f b)) +getBrowserState :: BrowserAction t (BrowserState t)+getBrowserState = getBS id++withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a+withBrowserState bs act = BA $ \ _ -> lift act bs+ -- | Do an io action ioAction :: IO a -> BrowserAction t a ioAction a = BA (\b -> a >>= \v -> return (b,v))@@ -715,8 +722,8 @@ -- Surely the most important bit: request :: HStream ty- => HTTPRequest ty- -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty)+ => Request ty+ -> BrowserAction (HandleStream ty) (URI,Response ty) request req = request' nullVal initialState req where initialState = nullRequestState@@ -725,8 +732,8 @@ request' :: HStream ty => ty -> RequestState- -> HTTPRequest ty- -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty)+ -> Request ty+ -> BrowserAction (HandleStream ty) (URI,Response ty) request' nullVal rqState rq = do -- add cookies to request let uri = rqURI rq@@ -745,14 +752,16 @@ Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) let rq'' = insertHeaders (map cookieToHeader cookies) rq' p <- getProxy-- out ("Sending:\n" ++ show rq'') + let rq_to_go = normalizeRequestURI (uriToAuthorityString $ rqURI rq'') rq''+ out ("Sending:\n" ++ show rq_to_go) e_rsp <- case p of- NoProxy -> dorequest (reqURIAuth rq'') rq''+ NoProxy -> dorequest (reqURIAuth rq'') rq_to_go Proxy str ath -> do- let rq''' = maybe rq'' - (\x -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq'')+ -- note: don't split off the authority for proxies..+ let rq_to_go' = maybe rq''+ (\x -> insertHeader HdrProxyAuthorization+ (withAuthority x rq'') rq'') ath let notURI | null pt || null hst = @@ -775,7 +784,7 @@ (parseURI str) out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth- dorequest proxyURIAuth rq'''+ dorequest proxyURIAuth rq_to_go' case e_rsp of Left v | (reqRetries rqState < maxRetries) && (v == ErrorReset || v == ErrorClosed) ->@@ -916,21 +925,26 @@ dorequest :: (HStream ty)- => URIAuth -> HTTPRequest ty -> BrowserAction (HandleStream ty) (Either ConnError (HTTPResponse ty))+ => URIAuth+ -> Request ty+ -> BrowserAction (HandleStream ty)+ (Result (Response ty)) dorequest hst rqst = do { pool <- getBS bsConnectionPool ; conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool ; rsp <- case conn of [] -> do { out ("Creating new connection to " ++ uriAuthToString hst) ; let aport = case uriPort hst of- (':':s) -> read s+ (':':s) -> + case reads s of { ((v,_):_) -> v ; _ -> 80} _ -> 80 ; c <- ioAction $ openStream (uriRegName hst) aport- ; let pool' = if length pool > 5- then init pool- else pool- ; when (length pool > 5)+ ; let len_pool = length pool+ ; when (len_pool > 5) (ioAction $ close (last pool))+ ; let pool' + | len_pool > 5 = init pool+ | otherwise = pool ; alterBS (\b -> b { bsConnectionPool=c:pool' }) ; dorequest2 c rqst }@@ -951,7 +965,7 @@ c' <- debugByteStream (f++'-': uriAuthToString hst) c sendHTTP c' r -reqURIAuth :: HTTPRequest ty -> URIAuth+reqURIAuth :: Request ty -> URIAuth reqURIAuth req = case uriAuthority (rqURI req) of Just ua -> ua@@ -967,18 +981,29 @@ ------------------------------------------------------------------ libUA :: String-libUA = "haskell-libwww/0.1"+libUA = "hs-HTTP/4.0.3" -defaultGETRequest :: URI -> Request-defaultGETRequest uri = +defaultGETRequest :: URI -> Request_String+defaultGETRequest uri = defaultGETRequest_ uri+++defaultGETRequest_ :: BufferType a => URI -> Request a+defaultGETRequest_ uri = req+ where+ empty = buf_empty (toBufOps req)+ + req = Request { rqURI=uri- , rqBody=""+ , rqBody=empty , rqHeaders=[ Header HdrContentLength "0" , Header HdrUserAgent libUA ] , rqMethod=GET } + toBufOps :: BufferType a => Request a -> BufferOp a+ toBufOps _ = bufferOps+ -- This form junk is completely untested... type FormVar = (String,String)@@ -986,7 +1011,7 @@ data Form = Form RequestMethod URI [FormVar] -formToRequest :: Form -> Request+formToRequest :: Form -> Request_String formToRequest (Form m u vs) = let enc = urlEncodeVars vs in case m of
Network/HTTP.hs view
@@ -8,39 +8,18 @@ -- Stability : experimental -- Portability : non-portable (not tested) ----- An easy HTTP interface enjoy.------ * Changes by Robin Bate Boerop <robin@bateboerop.name>:--- - Made dependencies explicit in import statements.--- - Removed false dependencies in import statements.--- - Added missing type signatures.--- - Moved Header-related code to Network.HTTP.Headers module.------ * Changes by Simon Foster:--- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules--- - Created functions receiveHTTP and responseHTTP to allow server side interactions--- (although 100-continue is unsupported and I haven't checked for standard compliancy).--- - Pulled the transfer functions from sendHTTP to global scope to allow access by--- above functions.------ * Changes by Graham Klyne:--- - export httpVersion--- - use new URI module (similar to old, but uses revised URI datatype)------ * Changes by Bjorn Bringert:+-- An easy HTTP interface, toplevel module. ----- - handle URIs with a port number--- - added debugging toggle--- - disabled 100-continue transfers to get HTTP\/1.0 compatibility--- - change 'ioError' to 'throw'--- - Added simpleHTTP_, which takes a stream argument.+-- The 'Network.HTTP' module provides functionality for sending+-- HTTP requests and processing their responses, along with a supporting+-- cast of types and utility functions. ----- * Changes from 0.1--- - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class.--- - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses.--- - reworking of the use of Stream, including alterations to make 'sendHTTP' generic--- and the addition of a debugging stream.--- - simplified error handling.+-- The actual functionality is implemented by modules in the @Network.HTTP.*@+-- namespace, allowing the user to either use the default implementation +-- by importing @Network.HTTP@ or, for more fine-grained control, selectively+-- import the modules in @Network.HTTP.*@. To wit, more than one kind of+-- representation of the bulk data that flows across a HTTP connection is +-- supported. Now selectable by importing @Network.HTTP.HandleStream@ (say.) -- -- * TODO -- - request pipelining@@ -98,7 +77,8 @@ , module Network.HTTP.Base , module Network.HTTP.Headers -{-+{- the functionality that Network.HTTP.HandleStream and Network.HTTP.Stream+ exposes: , simpleHTTP -- :: Request -> IO (Result Response) , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response)@@ -106,7 +86,6 @@ , respondHTTP -- :: Stream s => s -> Response -> IO () -} , module Network.TCP- ) where -----------------------------------------------------------------
Network/HTTP/Base.hs view
@@ -17,12 +17,14 @@ httpVersion -- ** HTTP - , Request - , Response + , Request(..) + , Response(..) , RequestMethod(..) - , HTTPRequest(..) - , HTTPResponse(..) + , Request_String + , Response_String + , HTTPRequest + , HTTPResponse -- ** URL Encoding , urlEncode @@ -61,6 +63,7 @@ , catchIO , catchIO_ + , responseParseError ) where import Network.URI @@ -70,6 +73,7 @@ ) import Control.Monad ( guard ) +import Control.Monad.Error import Data.Char ( ord, digitToInt, intToDigit, toLower ) import Data.List ( partition ) import Data.Maybe ( listToMaybe ) @@ -164,13 +168,23 @@ ("OPTIONS", OPTIONS), ("TRACE", TRACE)] -type Request = HTTPRequest String -type Response = HTTPResponse String +-- +-- for backwards-ish compatibility; suggest +-- migrating to new Req/Resp by adding type param. +-- +type Request_String = Request String +type Response_String = Response String +-- Hmm..I really want to use these for the record +-- type, but it will upset codebases wanting to +-- migrate (and live with using pre-HTTPbis versions.) +type HTTPRequest a = Request a +type HTTPResponse a = Response a + -- | An HTTP Request. -- The 'Show' instance of this type is used for message serialisation, -- which means no body data is output. -data HTTPRequest a = +data Request a = Request { rqURI :: URI -- ^ might need changing in future -- 1) to support '*' uri in OPTIONS request -- 2) transparent support for both relative @@ -191,7 +205,7 @@ -- this show function is used to serialise -- a request for the transport link, we send -- the body separately where possible. -instance Show (HTTPRequest a) where +instance Show (Request a) where show (Request u m h _) = show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf ++ foldr (++) [] (map show h) ++ crlf @@ -200,7 +214,7 @@ then u { uriPath = '/' : uriPath u } else u -instance HasHeaders (HTTPRequest a) where +instance HasHeaders (Request a) where getHeaders = rqHeaders setHeaders rq hdrs = rq { rqHeaders=hdrs } @@ -222,7 +236,7 @@ -- which means no body data is output, additionally the output will -- show an HTTP version of 1.1 instead of the actual version returned -- by a server. -data HTTPResponse a = +data Response a = Response { rspCode :: ResponseCode , rspReason :: String , rspHeaders :: [Header] @@ -231,12 +245,12 @@ -- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1 -instance Show (HTTPResponse a) where +instance Show (Response a) where show (Response (a,b,c) reason headers _) = httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf ++ foldr (++) [] (map show headers) ++ crlf -instance HasHeaders (HTTPResponse a) where +instance HasHeaders (Response a) where getHeaders = rspHeaders setHeaders rsp hdrs = rsp { rspHeaders=hdrs } @@ -246,48 +260,48 @@ -- Parsing a request parseRequestHead :: [String] -> Result RequestData -parseRequestHead [] = Left ErrorClosed -parseRequestHead (com:hdrs) = - requestCommand com `bindE` \(_version,rqm,uri) -> - parseHeaders hdrs `bindE` \hdrs' -> - Right (rqm,uri,hdrs') - where - requestCommand line = - case words line of - _yes@(rqm:uri:version) -> - case (parseURIReference uri, lookup rqm rqMethodMap) of - (Just u, Just r) -> Right (version,r,u) - _ -> Left parse_err - _no - | null line -> Left ErrorClosed - | otherwise -> Left parse_err - where - parse_err = ErrorParse ("Request command line parse failure: " ++ line) +parseRequestHead [] = Left ErrorClosed +parseRequestHead (com:hdrs) = do + (_version,rqm,uri) <- requestCommand com (words com) + hdrs' <- parseHeaders hdrs + return (rqm,uri,hdrs') + where + requestCommand l _yes@(rqm:uri:version) = + case (parseURIReference uri, lookup rqm rqMethodMap) of + (Just u, Just r) -> return (version,r,u) + _ -> parse_err l + requestCommand l _ + | null l = failWith ErrorClosed + | otherwise = parse_err l + parse_err l = responseParseError "parseRequestHead" + ("Request command line parse failure: " ++ l) + -- Parsing a response parseResponseHead :: [String] -> Result ResponseData -parseResponseHead [] = Left ErrorClosed -parseResponseHead (sts:hdrs) = - responseStatus sts `bindE` \(_version,code,reason) -> - parseHeaders hdrs `bindE` \hdrs' -> - Right (code,reason,hdrs') - where - responseStatus line = - case words line of - _yes@(version:code:reason) -> - Right (version,match code,concatMap (++" ") reason) - _no - | null line -> Left ErrorClosed -- an assumption - | otherwise -> Left parse_err - where - parse_err = (ErrorParse $ "Response status line parse failure: " ++ line) +parseResponseHead [] = failWith ErrorClosed +parseResponseHead (sts:hdrs) = do + (_version,code,reason) <- responseStatus sts (words sts) + hdrs' <- parseHeaders hdrs + return (code,reason,hdrs') + where + responseStatus _l _yes@(version:code:reason) = + return (version,match code,concatMap (++" ") reason) + responseStatus l _no + | null l = failWith ErrorClosed -- an assumption + | otherwise = parse_err l - match [a,b,c] = (digitToInt a, - digitToInt b, - digitToInt c) - match _ = (-1,-1,-1) -- will create appropriate behaviour + parse_err l = + responseParseError + "parseResponseHead" + ("Response status line parse failure: " ++ l) + match [a,b,c] = (digitToInt a, + digitToInt b, + digitToInt c) + match _ = (-1,-1,-1) -- will create appropriate behaviour + ----------------------------------------------------------------- @@ -390,7 +404,7 @@ -- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ -- header. -getAuth :: Monad m => HTTPRequest ty -> m URIAuthority +getAuth :: Monad m => Request ty -> m URIAuthority getAuth r = -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) case parseURIAuthority auth of @@ -412,8 +426,8 @@ -- the Host header if there is one, otherwise from the request-URI. -- Then we make the request-URI an abs_path and make sure that there -- is a Host header. -normalizeRequestURI :: URIAuthority -> HTTPRequest ty -> HTTPRequest ty -normalizeRequestURI URIAuthority{host=h} r = +normalizeRequestURI :: {-URI-}String -> Request ty -> Request ty +normalizeRequestURI h r = replaceHeader HdrConnection "close" $ insertHeaderIfMissing HdrHost h $ r { rqURI = (rqURI r){ uriScheme = "" @@ -421,7 +435,7 @@ }} -- Adds a Host header if one is NOT ALREADY PRESENT -normalizeHostHeader :: HTTPRequest ty -> HTTPRequest ty +normalizeHostHeader :: Request ty -> Request ty normalizeHostHeader rq = insertHeaderIfMissing HdrHost (uriToAuthorityString $ rqURI rq) @@ -438,9 +452,7 @@ -- | Used when we know exactly how many bytes to expect. linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) -linearTransfer readBlk n - = do info <- readBlk n - return $ info `bindE` \str -> Right ([],str) +linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) -- | Used when nothing about data is known, -- Unfortunately waiting for a socket closure @@ -464,11 +476,11 @@ -> IO (Result a) -> (Int -> IO (Result a)) -> IO (Result ([Header], a)) -chunkedTransfer bufOps readL readBlk = do - v <- chunkedTransferC bufOps readL readBlk 0 - return $ v `bindE` \(ftrs,count,info) -> - let myftrs = Header HdrContentLength (show count) : ftrs - in Right (myftrs,info) +chunkedTransfer bufOps readL readBlk = + fmapE (\ (ftrs,count,info) -> + let myftrs = Header HdrContentLength (show count) : ftrs + in Right (myftrs,info)) + (chunkedTransferC bufOps readL readBlk 0) chunkedTransferC :: BufferOp a -> IO (Result a) @@ -480,20 +492,20 @@ case v of Left e -> return (Left e) Right line - | size == 0 -> do - rs <- readTillEmpty2 bufOps readL [] - return $ - rs `bindE` \strs -> - parseHeaders (map (buf_toStr bufOps) strs) `bindE` \ftrs -> - Right (ftrs,n,buf_empty bufOps) + | size == 0 -> + fmapE (\ strs -> do + ftrs <- parseHeaders (map (buf_toStr bufOps) strs) + return (ftrs,n,buf_empty bufOps)) + (readTillEmpty2 bufOps readL []) + | otherwise -> do some <- readBlk size readL - more <- chunkedTransferC bufOps {-nullVal isNull isLineEnd toStr append -} readL readBlk (n+size) - return $ - some `bindE` \cdata -> - more `bindE` \(ftrs,m,mdata) -> - Right (ftrs,m,buf_append bufOps cdata mdata) + more <- chunkedTransferC bufOps readL readBlk (n+size) + return $ do + cdata <- some + (ftrs,m,mdata) <- more + return (ftrs,m,buf_append bufOps cdata mdata) where size | buf_isEmpty bufOps line = 0 @@ -505,9 +517,8 @@ -- | Maybe in the future we will have a sensible thing -- to do here, at that time we might want to change -- the name. -uglyDeathTransfer :: IO (Result ([Header],a)) -uglyDeathTransfer - = return $ Left $ ErrorParse "Unknown Transfer-Encoding" +uglyDeathTransfer :: String -> IO (Result ([Header],a)) +uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding") -- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) readTillEmpty1 :: BufferOp a @@ -550,3 +561,5 @@ catchIO_ :: IO a -> IO a -> IO a catchIO_ a h = Prelude.catch a (const h) +responseParseError :: String -> String -> Result a +responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v))
Network/HTTP/HandleStream.hs view
@@ -12,13 +12,13 @@ -- ----------------------------------------------------------------------------- module Network.HTTP.HandleStream - ( simpleHTTP -- :: HTTPRequest ty -> IO (Result (HTTPResponse ty))- , simpleHTTP_ -- :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))- , sendHTTP -- :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTResponse ty))- , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (HTTPRequest ty))- , respondHTTP -- :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO ()+ ( simpleHTTP -- :: Request ty -> IO (Result (Response ty))+ , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))+ , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))+ , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty))+ , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO () - , simpleHTTP_debug -- :: FilePath -> HTTPRequest DebugString -> IO (HTTPResponse DebugString)+ , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString) ) where -----------------------------------------------------------------@@ -26,7 +26,7 @@ ----------------------------------------------------------------- import Network.BufferType-import Network.Stream ( ConnError(..), bindE, Result )+import Network.Stream ( ConnError(..), fmapE, Result ) import Network.StreamDebugger ( debugByteStream ) import Network.TCP (HStream(..), HandleStream ) @@ -48,13 +48,13 @@ -- requires a Host header. -- Connection Where no allowance is made for persistant connections -- the Connection header will be set to "close"-simpleHTTP :: HStream ty => HTTPRequest ty -> IO (Result (HTTPResponse ty))+simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty)) simpleHTTP r = do auth <- getAuth r c <- openStream (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r -simpleHTTP_debug :: HStream ty => FilePath -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty)) simpleHTTP_debug httpLogFile r = do auth <- getAuth r c0 <- openStream (host auth) (fromMaybe 80 (port auth))@@ -62,14 +62,14 @@ simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream.-simpleHTTP_ :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) simpleHTTP_ s r = do auth <- getAuth r- let r' = normalizeRequestURI auth r + let r' = normalizeRequestURI (host auth) r rsp <- sendHTTP s r' return rsp -sendHTTP :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) sendHTTP conn rq = do let a_rq = normalizeHostHeader rq rsp <- catchIO (sendMain conn a_rq)@@ -91,7 +91,10 @@ -- for an indefinite period before sending the request body.' -- -- Since we would wait forever, I have disabled use of 100-continue for now.-sendMain :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+sendMain :: HStream ty+ => HandleStream ty+ -> Request ty+ -> IO (Result (Response ty)) sendMain conn rqst = do --let str = if null (rqBody rqst) -- then show rqst@@ -111,8 +114,8 @@ -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData- -> HTTPRequest ty- -> IO (Result (HTTPResponse ty))+ -> Request ty+ -> IO (Result (Response ty)) switchResponse _ _ _ (Left e) _ = return (Left e) -- retry on connreset? -- if we attempt to use the same socket then there is an excellent@@ -141,24 +144,18 @@ Done -> return (Right $ Response cd rn hdrs (buf_empty bufferOps)) - DieHorribly str -> return $ Left $ ErrorParse ("Invalid response: " ++ str)-- ExpectEntity -> do- rslt <- - case tc of- Nothing -> - case cl of- Nothing -> hopefulTransfer bo (readLine conn) []- Just x -> - case reads x of- ((v,_):_) -> linearTransfer (readBlock conn) v- _ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x)))- Just x -> - case map toLower (trim x) of- "chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn)- _ -> uglyDeathTransfer- return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)-+ 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 where tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs@@ -166,49 +163,62 @@ -- reads and parses headers getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData)-getResponseHead conn = do- lor <- readTillEmpty1 bufferOps (readLine conn)- return $ lor `bindE` \es -> parseResponseHead (map (buf_toStr bufferOps) es)+getResponseHead conn = + fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es))+ (readTillEmpty1 bufferOps (readLine conn)) -- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions.-receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (HTTPRequest bufTy))+receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy)) receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest- where- -- reads and parses headers- getRequestHead :: IO (Result RequestData)- getRequestHead =- do { lor <- readTillEmpty1 bufferOps (readLine conn)- ; return $ lor `bindE` \es -> parseRequestHead (map (buf_toStr bufferOps) es)- }+ where+ -- reads and parses headers+ getRequestHead :: IO (Result RequestData)+ getRequestHead = do+ fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es))+ (readTillEmpty1 bufferOps (readLine conn)) - processRequest (rm,uri,hdrs) = do- rslt <- - case tc of- Nothing ->- case cl of- Nothing -> return (Right ([], buf_empty bo)) -- hopefulTransfer ""- Just x -> - case reads x of- ((v,_):_) -> linearTransfer (readBlock conn) v- _ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x)))- Just x ->- case map toLower (trim x) of- "chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn)- _ -> uglyDeathTransfer- - return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)- where- -- FIXME : Also handle 100-continue.- tc = lookupHeader HdrTransferEncoding hdrs- cl = lookupHeader HdrContentLength hdrs- bo = bufferOps+ processRequest (rm,uri,hdrs) =+ fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $+ maybe + (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""+ (\ x -> readsOne (linearTransfer (readBlock conn))+ (return$responseParseError "unrecognized Content-Length value" x)+ x)+ + cl)+ (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+ (uglyDeathTransfer "receiveHTTP"))+ tc+ where+ -- FIXME : Also handle 100-continue.+ tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs+ bo = bufferOps -- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types.-respondHTTP :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO ()+respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () respondHTTP conn rsp = do writeBlock conn (buf_fromStr bufferOps $ show rsp) -- write body immediately, don't wait for 100 CONTINUE writeBlock conn (rspBody rsp) return ()++------------------------------------------------------------------------------++readsOne :: Read a => (a -> b) -> b -> String -> b+readsOne f n str = + case reads str of+ ((v,_):_) -> f v+ _ -> n++headerName :: String -> String+headerName x = map toLower (trim x)++ifChunked :: a -> a -> String -> a+ifChunked a b s = + case headerName s of+ "chunked" -> a+ _ -> b+
Network/HTTP/Headers.hs view
@@ -60,14 +60,14 @@ ) where import Data.Char (toLower)-import Network.Stream (Result, ConnError(ErrorParse))+import Network.Stream (Result, failParse) import Network.HTTP.Utils ( trim, split, crlf ) -- | The @Header@ data type pairs header names & values. data Header = Header HeaderName String instance Show Header where- show (Header key value) = show key ++ ": " ++ value ++ crlf+ show (Header key value) = shows key (':':' ':value ++ crlf) -- | HTTP Header Name type: -- Why include this at all? I have some reasons@@ -257,8 +257,8 @@ parseHeader :: String -> Result Header parseHeader str = case split ':' str of- Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)- Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v)+ Nothing -> failParse ("Unable to parse header: " ++ str)+ Just (k,v) -> return $ Header (fn k) (trim $ drop 1 v) where fn k = case map snd $ filter (match k . fst) headerMap of [] -> (HdrCustom k)@@ -273,17 +273,19 @@ where -- Joins consecutive lines where the second line -- begins with ' ' or '\t'.+ joinExtended old [] = [old] joinExtended old (h : t)- | not (null h) && (head h == ' ' || head h == '\t')- = joinExtended (old ++ ' ' : tail h) t- | otherwise = old : joinExtended h t- joinExtended old [] = [old]+ | isLineExtension h = joinExtended (old ++ ' ' : tail h) t+ | otherwise = old : joinExtended h t+ + isLineExtension (x:_) = x == ' ' || x == '\t'+ isLineExtension _ = False clean [] = [] clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t | otherwise = h : clean t - -- tollerant of errors? should parse+ -- tolerant of errors? should parse -- errors here be reported or ignored? -- currently ignored. catRslts :: [a] -> [Result a] -> Result [a]
Network/HTTP/Stream.hs view
@@ -96,11 +96,11 @@ module Network.HTTP.Stream ( module Network.Stream - , simpleHTTP -- :: Request -> IO (Result Response)- , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response)- , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response)- , receiveHTTP -- :: Stream s => s -> IO (Result Request)- , respondHTTP -- :: Stream s => s -> Response -> IO ()+ , simpleHTTP -- :: Request_String -> IO (Result Response_String)+ , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String)+ , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String)+ , receiveHTTP -- :: Stream s => s -> IO (Result Request_String)+ , respondHTTP -- :: Stream s => s -> Response_String -> IO () ) where @@ -141,7 +141,7 @@ -- requires a Host header. -- Connection Where no allowance is made for persistant connections -- the Connection header will be set to "close"-simpleHTTP :: Request -> IO (Result Response)+simpleHTTP :: Request_String -> IO (Result Response_String) simpleHTTP r = do auth <- getAuth r@@ -149,11 +149,11 @@ simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream.-simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)+simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) simpleHTTP_ s r = do auth <- getAuth r- let r' = normalizeRequestURI auth r + let r' = normalizeRequestURI (host auth) r rsp <- if debug then do s' <- debugStream httpLogFile s sendHTTP s' r'@@ -163,7 +163,7 @@ --; close s return rsp -sendHTTP :: Stream s => s -> Request -> IO (Result Response)+sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) sendHTTP conn rq = do { let a_rq = normalizeHostHeader rq ; rsp <- catchIO (main a_rq)@@ -186,7 +186,7 @@ -- for an indefinite period before sending the request body.' -- -- Since we would wait forever, I have disabled use of 100-continue for now.- main :: Request -> IO (Result Response)+ main :: Request_String -> IO (Result Response_String) main rqst = do --let str = if null (rqBody rqst)@@ -202,7 +202,7 @@ getResponseHead :: IO (Result ResponseData) getResponseHead = do { lor <- readTillEmpty1 stringBufferOp (readLine conn)- ; return $ lor `bindE` parseResponseHead+ ; return $ lor >>= parseResponseHead } -- Hmmm, this could go bad if we keep getting "100 Continue"@@ -211,8 +211,8 @@ switchResponse :: Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData- -> Request- -> IO (Result Response)+ -> Request_String+ -> IO (Result Response_String) switchResponse _ _ (Left e) _ = return (Left e) -- retry on connreset?@@ -248,7 +248,7 @@ return (Right $ Response cd rn hdrs "") DieHorribly str ->- return $ Left $ ErrorParse ("Invalid response: " ++ str)+ return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) ExpectEntity -> let tc = lookupHeader HdrTransferEncoding hdrs@@ -263,20 +263,22 @@ case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn)- _ -> uglyDeathTransfer- ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) + _ -> uglyDeathTransfer "sendHTTP"+ ; return $ do+ (ftrs,bdy) <- rslt+ return (Response cd rn (hdrs++ftrs) bdy) } -- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions.-receiveHTTP :: Stream s => s -> IO (Result Request)+receiveHTTP :: Stream s => s -> IO (Result Request_String) receiveHTTP conn = getRequestHead >>= processRequest where -- reads and parses headers getRequestHead :: IO (Result RequestData) getRequestHead = do { lor <- readTillEmpty1 stringBufferOp (readLine conn)- ; return $ lor `bindE` parseRequestHead+ ; return $ lor >>= parseRequestHead } processRequest (Left e) = return $ Left e@@ -293,14 +295,15 @@ case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn)- _ -> uglyDeathTransfer+ _ -> uglyDeathTransfer "receiveHTTP" - return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)-+ return $ do+ (ftrs,bdy) <- rslt+ return (Request uri rm (hdrs++ftrs) bdy) -- | 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 -> IO ()+respondHTTP :: Stream s => s -> Response_String -> IO () respondHTTP conn rsp = do writeBlock conn (show rsp) -- write body immediately, don't wait for 100 CONTINUE writeBlock conn (rspBody rsp)
Network/Stream.hs view
@@ -25,8 +25,14 @@ , ConnError(..) , Result , bindE+ , fmapE++ , failParse -- :: String -> Result a+ , failWith -- :: ConnError -> Result a ) where +import Control.Monad.Error+ data ConnError = ErrorReset | ErrorClosed@@ -34,10 +40,27 @@ | ErrorMisc String deriving(Show,Eq) +instance Error ConnError where+ noMsg = strMsg "unknown error"+ strMsg x = ErrorMisc x++failParse :: String -> Result a+failParse x = failWith (ErrorParse x)++failWith :: ConnError -> Result a+failWith x = Left x+ bindE :: Result a -> (a -> Result b) -> Result b bindE (Left e) _ = Left e bindE (Right v) f = f v +fmapE :: (a -> Result b) -> IO (Result a) -> IO (Result b)+fmapE f a = do+ x <- a+ case x of+ Left e -> return (Left e)+ Right r -> return (f r) + -- | This is the type returned by many exported network functions. type Result a = Either ConnError {- error -} a {- result -}
Network/TCP.hs view
@@ -50,6 +50,7 @@ import Network.Stream ( ConnError(..) , Result+ , failWith ) import Network.BufferType @@ -57,7 +58,6 @@ import Network.Socket ( socketToHandle ) import Data.Char ( toLower )-import Data.Maybe ( fromMaybe ) import Data.Word ( Word8 ) import Control.Concurrent import Control.Monad ( liftM )@@ -247,86 +247,74 @@ readBlockBS :: HandleStream a -> Int -> IO (Result a)-readBlockBS ref n = do- conn <- readMVar (getRef ref)- x <- - case conn of- ConnClosed -> return (Left ErrorClosed)- MkConn{} -> bufferGetBlock ref n -- (connBuffer conn) (connInput conn) (connHandle conn) n- fromMaybe (return ()) (fmap (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) (connHooks' conn))+readBlockBS ref n = onNonClosedDo ref $ \ conn -> do+ x <- bufferGetBlock ref n+ maybe (return ())+ (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x)+ (connHooks' conn) return x -- This function uses a buffer, at this time the buffer is just 1000 characters. -- (however many bytes this is is left to the user to decypher) readLineBS :: HandleStream a -> IO (Result a)-readLineBS ref = do- conn <- readMVar (getRef ref)- x <- - case conn of- ConnClosed -> return (Left ErrorClosed)- MkConn{} -> bufferReadLine ref -- (connBuffer conn) (connHandle conn) (connInput conn)- fromMaybe (return ()) (fmap (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) (connHooks' conn))+readLineBS ref = onNonClosedDo ref $ \ conn -> do+ x <- bufferReadLine ref+ maybe (return ())+ (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x)+ (connHooks' conn) return x -- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlockBS :: HandleStream a -> a -> IO (Result ())-writeBlockBS ref b = do- conn <- readMVar (getRef ref)- x <- - case conn of- ConnClosed -> return (Left ErrorClosed)- MkConn{} -> bufferPutBlock (connBuffer conn) (connHandle conn) b- fromMaybe (return ()) (fmap (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x) (connHooks' conn))+writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do+ x <- bufferPutBlock (connBuffer conn) (connHandle conn) b+ maybe (return ())+ (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x)+ (connHooks' conn) return x closeIt :: 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)- fromMaybe (return ()) (fmap (\ h -> hook_close h) (connHooks' conn))-+ maybe (return ())+ (hook_close)+ (connHooks' conn) bufferGetBlock :: HandleStream a -> Int -> IO (Result a)-bufferGetBlock ref n = do- conn <- readMVar (getRef ref)- case conn of- ConnClosed -> return (Left ErrorClosed)- MkConn{} -> do- case connInput conn of- Just c -> do- let (a,b) = buf_splitAt (connBuffer conn) n c- modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b})- return (Right a)- _ -> do- Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.Right)- (\ e -> if isEOFError e - then return (Right (buf_empty (connBuffer conn)))- else return (Left (ErrorMisc (show e))))+bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do+ case connInput conn of+ Just c -> do+ let (a,b) = buf_splitAt (connBuffer conn) n c+ 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 -> if isEOFError e + then 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 (Right ()))- (\ e -> return (Left (ErrorMisc (show e))))+ 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 ref = do- conn <- readMVar (getRef ref)- case conn of- ConnClosed -> return (Left ErrorClosed)- MkConn{} -> do- case connInput conn of- Just c -> do- let (a,b0) = buf_span (connBuffer conn) (/='\n') c- let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0- modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1})- return (Right (buf_append (connBuffer conn) a newl))- _ -> Prelude.catch - (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . Right . appendNL (connBuffer conn))+bufferReadLine ref = onNonClosedDo ref $ \ conn -> do+ case connInput conn of+ Just c -> do+ let (a,b0) = buf_span (connBuffer conn) (/='\n') c+ 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 + (buf_hGetLine (connBuffer conn) (connHandle conn) >>= + return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e- then return (Right (buf_empty (connBuffer conn)))- else return (Left (ErrorMisc (show e))))+ then return (return (buf_empty (connBuffer conn)))+ else return (fail (show e))) where -- yes, this s**ks.. _may_ have to be addressed if perf -- suggests worthiness.@@ -334,3 +322,11 @@ nl :: Word8 nl = fromIntegral (fromEnum '\n')++onNonClosedDo :: HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b)+onNonClosedDo h act = do+ x <- readMVar (getRef h)+ case x of+ ConnClosed{} -> return (failWith ErrorClosed)+ c -> act c+