diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,14 @@ +Version 4004.0.6: release 2009-04-21; changes from 4004.0.5 + + * Patch release. + * Network.Browser: use HTTP.HandleStream.sendHTTP_notify, not HTTP.sendHTTP_notify + when issuing requests. The latter runs the risk of undoing request normalization. + * Network.HTTP.Base.normalizeRequest: when normalizing proxy-bound requests, + insert a Host: header if none present. Set it to the destination server authority, + not the proxy. + * Network.Browser: don't fail on seeing invalid cookie values, but report them + as errors and continue. + Version 4004.0.5: release 2009-03-30; changes from 4004.0.4 * Get serious about comments and Haddock documentation. diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.0.5 +Version: 4000.0.6 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3 diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -112,7 +112,8 @@ , parseURI, parseURIReference, relativeTo ) import Network.StreamDebugger (debugByteStream) -import Network.HTTP +import Network.HTTP hiding ( sendHTTP_notify ) +import Network.HTTP.HandleStream ( sendHTTP_notify ) import qualified Network.HTTP.MD5 as MD5 (hash) import qualified Network.HTTP.Base64 as Base64 (encode) import Network.Stream ( ConnError(..), Result ) @@ -168,7 +169,7 @@ -- user if he/she is willing to accept an incoming cookie before -- adding it to the store. userCookieFilter :: URI -> Cookie -> IO Bool -userCookieFilter url cky = +userCookieFilter url cky = do do putStrLn ("Set-Cookie received when requesting: " ++ show url) case ckComment cky of Nothing -> return () @@ -198,64 +199,9 @@ ++ ";$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 - where - cookies :: Parser [Cookie] - cookies = sepBy1 cookie (char ',') - - cookie :: Parser Cookie - cookie = - do { name <- word - ; spaces_l - ; char '=' - ; spaces_l - ; val1 <- cvalue - ; args <- cdetail - ; return $ mkCookie name val1 args - } - - cvalue :: Parser String - - spaces_l = many (satisfy isSpace) - - cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return "" - - -- all keys in the result list MUST be in lower case - cdetail :: Parser [(String,String)] - cdetail = many $ - try (do { spaces_l - ; char ';' - ; spaces_l - ; s1 <- word - ; spaces_l - ; s2 <- option "" (do { char '=' ; spaces_l ; v <- cvalue ; return v }) - ; return (map toLower s1,s2) - }) - - mkCookie :: String -> String -> [(String,String)] -> Cookie - mkCookie nm cval more = - MkCookie { ckName = nm - , ckValue = cval - , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) - , ckPath = lookup "path" more - , ckVersion = lookup "version" more - , ckComment = lookup "comment" more - } - -headerToCookies _ _ = [] - - - -- | @addCookie c@ adds a cookie to the browser state, removing duplicates. addCookie :: Cookie -> BrowserAction t () -addCookie c = alterBS (\b -> b { bsCookies=c : fn (bsCookies b) }) - where - fn = filter (not . (==c)) +addCookie c = alterBS (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) }) -- | @setCookies cookies@ replaces the set of cookies known to -- the browser to @cookies@. Useful when wanting to restore cookies @@ -570,7 +516,7 @@ withAuthority a rq = case a of AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) AuthDigest{} -> - "Digest username=\"" ++ auUsername a -- " + "Digest username=\"" ++ auUsername a ++ "\",realm=\"" ++ auRealm a ++ "\",nonce=\"" ++ auNonce a ++ "\",uri=\"" ++ digesturi @@ -720,11 +666,14 @@ withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a withBrowserState bs act = BA $ \ _ -> lift act bs -newRequest :: BrowserAction t a -> BrowserAction t a -newRequest act = do +-- | @nextRequest act@ performs the browser action @act@ as +-- the next request, i.e., setting up a new request context +-- before doing so. +nextRequest :: BrowserAction t a -> BrowserAction t a +nextRequest act = do let updReqID st = let - rid = 1 + bsRequestID st + rid = succ (bsRequestID st) in rid `seq` st{bsRequestID=rid} alterBS updReqID @@ -888,7 +837,7 @@ request :: HStream ty => Request ty -> BrowserAction (HandleStream ty) (URI,Response ty) -request req = newRequest $ do +request req = nextRequest $ do res <- request' nullVal initialState req reportEvent ResponseFinish (show (rqURI req)) case res of @@ -901,7 +850,8 @@ initialState = nullRequestState nullVal = buf_empty bufferOps --- | Internal helper function, carrying along per-request counts. +-- | Internal helper function, explicitly carrying along per-request +-- counts. request' :: HStream ty => ty -> RequestState @@ -918,8 +868,7 @@ xs -> case break (==':') xs of { (as,_:bs) -> withAuth AuthBasic{auUsername=as,auPassword=bs,auRealm="/",auSite=uri} ; _ -> id}) $ do -} when (not $ null cookies) - (out $ "Adding cookies to request. Cookie names: " ++ - foldl spaceappend "" (map ckName cookies)) + (out $ "Adding cookies to request. Cookie names: " ++ unwords (map ckName cookies)) -- add credentials to request rq' <- if not (reqStopOnDeny rqState) @@ -969,7 +918,7 @@ (parseURI str) out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth - dorequest proxyURIAuth final_req + dorequest proxyURIAuth final_req mbMx <- getMaxErrorRetries case e_rsp of Left v @@ -981,19 +930,8 @@ Right rsp -> do out ("Received:\n" ++ show rsp) -- add new cookies to browser state - let cookieheaders = retrieveHeaders HdrSetCookie rsp - let newcookies = concat (map (headerToCookies $ uriAuthToString $ reqURIAuth rq) cookieheaders) - - when (not $ null newcookies) - (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newcookies) - - filterfn <- getCookieFilter - newcookies' <- ioAction (filterM (filterfn uri) newcookies) - mapM_ addCookie newcookies' - - when (not $ null newcookies) - (out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies')) - + handleCookies uri (uriAuthToString $ reqURIAuth rq) + (retrieveHeaders HdrSetCookie rsp) mbMxAuths <- getMaxAuthAttempts case rspCode rsp of (4,0,1) -- Credentials not sent or refused. @@ -1092,7 +1030,7 @@ , reqStopOnDeny = True } rq - (3,_,_) -> redirect uri rsp + (3,_,_) -> redirect uri rsp _ -> return (Right (uri,rsp)) where @@ -1121,52 +1059,50 @@ err ("Parse of Location header in a redirect response failed: " ++ u) return (Right (uri,rsp)) -spaceappend :: String -> String -> String -spaceappend x y = x ++ ' ' : y - -- | The internal request handling state machine. dorequest :: (HStream 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 uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst - ; reportEvent OpenConnection (show (rqURI rqst)) - ; c <- ioAction $ openStream (uriRegName hst) uPort - ; updateConnectionPool c - ; dorequest2 c rqst - } - (c:_) -> - do { out ("Recovering connection to " ++ uriAuthToString hst) - ; reportEvent ReuseConnection (show (rqURI rqst)) - ; dorequest2 c rqst - } - ; case rsp of { Right (Response a b c _) -> reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return ()} - ; return rsp - } - where - dorequest2 c r = do - dbg <- getBS bsDebug - st <- getBrowserState - onSendComplete <- - case bsEvent st of - Nothing -> return (return ()) - Just evh -> return $ do - x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) - (lift (evh x)) st - return () - ioAction $ - case dbg of - Nothing -> sendHTTP_notify c r onSendComplete - Just f -> do - c' <- debugByteStream (f++'-': uriAuthToString hst) c - sendHTTP_notify c' r onSendComplete - +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 uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst + reportEvent OpenConnection (show (rqURI rqst)) + c <- ioAction $ openStream (uriRegName hst) uPort + updateConnectionPool c + dorequest2 c rqst + (c:_) -> do + out ("Recovering connection to " ++ uriAuthToString hst) + reportEvent ReuseConnection (show (rqURI rqst)) + dorequest2 c rqst + case rsp of + Right (Response a b c _) -> + reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return () + return rsp + where + dorequest2 c r = do + dbg <- getBS bsDebug + st <- getBrowserState + let + onSendComplete = + maybe (return ()) + (\evh -> do + x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) + (lift (evh x)) st + return ()) + (bsEvent st) + ioAction $ + maybe (sendHTTP_notify c r onSendComplete) + (\ f -> do + c' <- debugByteStream (f++'-': uriAuthToString hst) c + sendHTTP_notify c' r onSendComplete) + dbg updateConnectionPool :: HStream hTy => HandleStream hTy @@ -1208,6 +1144,73 @@ , rqURI=u } _ -> error ("unexpected request: " ++ show m) + + +handleCookies :: URI -> String -> [Header] -> BrowserAction t () +handleCookies _ _ [] = return () -- cut short the silliness. +handleCookies uri dom cookieHeaders = do + when (not $ null errs) + (err $ unlines ("Errors parsing these cookie values: ":errs)) + when (not $ null newCookies) + (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies) + filterfn <- getCookieFilter + newCookies' <- ioAction (filterM (filterfn uri) newCookies) + when (not $ null newCookies') + (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies')) + mapM_ addCookie newCookies' + where + (errs, newCookies) = foldr (headerToCookies dom) ([],[]) cookieHeaders + +headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = + case parse cookies "" val of + Left e -> (val:accErr, accCookie) + Right x -> (accErr, x ++ accCookie) + where + cookies :: Parser [Cookie] + cookies = sepBy1 cookie (char ',') + + cookie :: Parser Cookie + cookie = + do { name <- word + ; spaces_l + ; char '=' + ; spaces_l + ; val1 <- cvalue + ; args <- cdetail + ; return $ mkCookie name val1 args + } + + cvalue :: Parser String + + spaces_l = many (satisfy isSpace) + + cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return "" + + -- all keys in the result list MUST be in lower case + cdetail :: Parser [(String,String)] + cdetail = many $ + try (do { spaces_l + ; char ';' + ; spaces_l + ; s1 <- word + ; spaces_l + ; s2 <- option "" (do { char '=' ; spaces_l ; v <- cvalue ; return v }) + ; return (map toLower s1,s2) + }) + + mkCookie :: String -> String -> [(String,String)] -> Cookie + mkCookie nm cval more = + MkCookie { ckName = nm + , ckValue = cval + , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) + , ckPath = lookup "path" more + , ckVersion = lookup "version" more + , ckComment = lookup "comment" more + } +headerToCookies _ _ acc = acc + + ------------------------------------------------------------------ diff --git a/Network/BufferType.hs b/Network/BufferType.hs --- a/Network/BufferType.hs +++ b/Network/BufferType.hs @@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.BufferType +-- Description : Abstract representation of request and response buffer types. -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne -- License : BSD -- @@ -9,7 +10,14 @@ -- Stability : experimental -- Portability : non-portable (not tested) -- --- Operations over wire-transmitted values. +-- In order to give the user freedom in how request and response content +-- is represented, a sufficiently abstract representation is needed of +-- these internally. The "Network.BufferType" module provides this, defining +-- the 'BufferType' class and its ad-hoc representation of buffer operations +-- via the 'BufferOp' record. +-- +-- This module provides definitions for the standard buffer types that the +-- package supports, i.e., for @String@ and @ByteString@ (strict and lazy.) -- ----------------------------------------------------------------------------- module Network.BufferType @@ -35,7 +43,7 @@ -- | The @BufferType@ class encodes, in a mixed-mode way, the interface -- that the library requires to operate over data embedded in HTTP -- requests and responses. That is, we use explicit dictionaries --- for the operations, but overload the name of these dicts. +-- for the operations, but overload the name of the dicts themselves. -- class BufferType bufType where bufferOps :: BufferOp bufType @@ -49,9 +57,17 @@ instance BufferType String where bufferOps = stringBufferOp --- Encode the I/O operations of the underlying buffer over a Handle --- in an (explicit) dictionary type. May not be needed, but gives +-- | @BufferOp@ encodes the I/O operations of the underlying buffer over +-- a Handle in an (explicit) dictionary type. May not be needed, but gives -- us flexibility in explicit overriding and wrapping up of these methods. +-- +-- Along with IO operations is an ad-hoc collection of functions for working +-- with these abstract buffers, as needed by the internals of the code +-- that processes requests and responses. +-- +-- We supply three default @BufferOp@ values, for @String@ along with the +-- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@ +-- definitions for data BufferOp a = BufferOp { buf_hGet :: Handle -> Int -> IO a @@ -73,6 +89,8 @@ instance Eq (BufferOp a) where _ == _ = False +-- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-lazy kind. strictBufferOp :: BufferOp Strict.ByteString strictBufferOp = BufferOp @@ -94,6 +112,8 @@ where p_crlf = Strict.pack crlf +-- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-strict kind. lazyBufferOp :: BufferOp Lazy.ByteString lazyBufferOp = BufferOp @@ -115,12 +135,15 @@ where p_crlf = Lazy.pack crlf +-- | @stringBufferOp@ is the 'BufferOp' definition over @String@s. +-- It is defined in terms of @strictBufferOp@ operations, +-- unpacking/converting to @String@ when needed. stringBufferOp :: BufferOp String stringBufferOp =BufferOp - { buf_hGet = \ h n -> Strict.hGet h n >>= return . Strict.unpack - , buf_hGetContents = \ h -> Strict.hGetContents h >>= return . Strict.unpack - , buf_hPut = \ h s -> Strict.hPut h (Strict.pack s) - , buf_hGetLine = \ h -> Strict.hGetLine h >>= return . Strict.unpack + { buf_hGet = \ h n -> buf_hGet strictBufferOp h n >>= return . Strict.unpack + , buf_hGetContents = \ h -> buf_hGetContents strictBufferOp h >>= return . Strict.unpack + , buf_hPut = \ h s -> buf_hPut strictBufferOp h (Strict.pack s) + , buf_hGetLine = \ h -> buf_hGetLine strictBufferOp h >>= return . Strict.unpack , buf_append = (++) , buf_concat = concat , buf_fromStr = id diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -705,8 +705,8 @@ Nothing -> req -- no host/authority in sight..not much we can do...complain? Just{} -> req (h,uri_abs) - | forProxy -> req -- Note: _not_ stubbing out user:pass - | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} + | forProxy -> insertHeaderIfMissing HdrHost h req + | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass where uri0 = rqURI req -- stub out the user:pass diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs --- a/Network/HTTP/Headers.hs +++ b/Network/HTTP/Headers.hs @@ -8,56 +8,35 @@ -- Stability : experimental -- Portability : non-portable (not tested) -- --- * Changes by Robin Bate Boerop : --- - Made dependencies explicit in import statements. --- - Removed false dependencies in import statements. --- - Added missing type signatures. --- - Created Network.HTTP.Headers from Network.HTTP modules. --- --- See changes history and TODO list in Network.HTTP module. --- --- * Header notes: --- --- [@Host@] --- Required by HTTP\/1.1, if not supplied as part --- of a request a default Host value is extracted --- from the request-uri. --- --- [@Connection@] --- If this header is present in any request or --- response, and it's value is "close", then --- the current request\/response is the last --- to be allowed on that connection. +-- This module provides the data types for representing HTTP headers, and +-- operations for looking up header values and working with sequences of +-- header values in 'Request's and 'Response's. To avoid having to provide +-- separate set of operations for doing so, we introduce a type class 'HasHeaders' +-- to facilitate writing such processing using overloading instead. -- --- [@Expect@] --- Should a request contain a body, an Expect --- header will be added to the request. The added --- header has the value \"100-continue\". After --- a 417 \"Expectation Failed\" response the request --- is attempted again without this added Expect --- header. --- --- [@TransferEncoding,ContentLength,...@] --- if request is inconsistent with any of these --- header values then you may not receive any response --- or will generate an error response (probably 4xx). --- ----------------------------------------------------------------------------- module Network.HTTP.Headers - ( HasHeaders(..) + ( HasHeaders(..) -- type class + , Header(..) + , mkHeader -- :: HeaderName -> String -> Header + , hdrName -- :: Header -> HeaderName + , hdrValue -- :: Header -> String + , HeaderName(..) - , mkHeader - , insertHeader - , insertHeaderIfMissing - , insertHeaders - , retrieveHeaders - , replaceHeader - , findHeader - , lookupHeader - , parseHeaders + , insertHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaders -- :: HasHeaders a => [Header] -> a -> a + , retrieveHeaders -- :: HasHeaders a => HeaderName -> a -> [Header] + , replaceHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String + , lookupHeader -- :: HeaderName -> [Header] -> Maybe String + , parseHeader -- :: parseHeader :: String -> Result Header + , parseHeaders -- :: [String] -> Result [Header] + + , HeaderSetter ) where import Data.Char (toLower) @@ -67,6 +46,12 @@ -- | The @Header@ data type pairs header names & values. data Header = Header HeaderName String +hdrName :: Header -> HeaderName +hdrName (Header h _) = h + +hdrValue :: Header -> String +hdrValue (Header _ v) = v + -- | Header constructor as a function, hiding above rep. mkHeader :: HeaderName -> String -> Header mkHeader = Header @@ -74,17 +59,15 @@ instance Show Header where show (Header key value) = shows key (':':' ':value ++ crlf) --- | HTTP Header Name type: --- Why include this at all? I have some reasons --- 1) prevent spelling errors of header names, --- 2) remind everyone of what headers are available, --- 3) might speed up searches for specific headers. --- --- Arguments against: --- 1) makes customising header names laborious --- 2) increases code volume. +-- | HTTP @HeaderName@ type, a Haskell data constructor for each +-- specification-defined header, prefixed with @Hdr@ and CamelCased, +-- (i.e., eliding the @-@ in the process.) Should you require using +-- a custom header, there's the @HdrCustom@ constructor which takes +-- a @String@ argument. -- --- Long discussions can be had on this topic! +-- Encoding HTTP header names differently, as Strings perhaps, is an +-- equally fine choice..no decidedly clear winner, but let's stick +-- with data constructors here. -- data HeaderName -- Generic Headers -- @@ -147,8 +130,8 @@ | HdrCustom String -- not in header map below. deriving(Eq) --- Translation between header names and values, --- good candidate for improvement. +-- | @headerMap@ is a straight assoc list for translating between header names +-- and values. headerMap :: [ (String,HeaderName) ] headerMap = [ p "Cache-Control" HdrCacheControl @@ -212,24 +195,28 @@ [] -> error "headerMap incomplete" (h:_) -> fst h --- | This class allows us to write generic header manipulation functions --- for both 'Request' and 'Response' data types. +-- | @HasHeaders@ is a type class for types containing HTTP headers, allowing +-- you to write overloaded header manipulation functions +-- for both 'Request' and 'Response' data types, for instance. class HasHeaders x where getHeaders :: x -> [Header] setHeaders :: x -> [Header] -> x -- Header manipulation functions -insertHeader, replaceHeader, insertHeaderIfMissing - :: HasHeaders a => HeaderName -> String -> a -> a --- | Inserts a header with the given name and value. --- Allows duplicate header names. +type HeaderSetter a = HeaderName -> String -> a -> a + +-- | @insertHeader hdr val x@ inserts a header with the given header name +-- and value. Does not check for existing headers with same name, allowing +-- duplicates to be introduce (use 'replaceHeader' if you want to avoid this.) +insertHeader :: HasHeaders a => HeaderSetter a insertHeader name value x = setHeaders x newHeaders where newHeaders = (Header name value) : getHeaders x --- | Adds the new header only if no previous header shares --- the same name. +-- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous +-- header with name @hdr@ exists in @x@. +insertHeaderIfMissing :: HasHeaders a => HeaderSetter a insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) where newHeaders list@(h@(Header n _): rest) @@ -237,33 +224,39 @@ | otherwise = h : newHeaders rest newHeaders [] = [Header name value] --- | Removes old headers with duplicate name. +-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the +-- value @val@, dropping any existing +replaceHeader :: HasHeaders a => HeaderSetter a replaceHeader name value h = setHeaders h newHeaders where newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ] --- | Inserts multiple headers. +-- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing +-- set. insertHeaders :: HasHeaders a => [Header] -> a -> a insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) --- | Gets a list of headers with a particular 'HeaderName'. +-- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@. retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] retrieveHeaders name x = filter matchname (getHeaders x) where - matchname (Header n _) | n == name = True - matchname _ = False + matchname (Header n _) = n == name --- | Lookup presence of specific HeaderName in a list of Headers --- Returns the value from the first matching header. +-- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first +-- header that matches, if any. findHeader :: HasHeaders a => HeaderName -> a -> Maybe String findHeader n x = lookupHeader n (getHeaders x) --- An anomally really: +-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the +-- list @hdrs@. lookupHeader :: HeaderName -> [Header] -> Maybe String -lookupHeader v (Header n s:t) | v == n = Just s - | otherwise = lookupHeader v t -lookupHeader _ _ = Nothing +lookupHeader _ [] = Nothing +lookupHeader v (Header n s:t) + | v == n = Just s + | otherwise = lookupHeader v t +-- | @parseHeader headerNameAndValueString@ tries to unscramble a +-- @header: value@ pairing and returning it as a 'Header'. parseHeader :: String -> Result Header parseHeader str = case split ':' str of @@ -277,9 +270,14 @@ match :: String -> String -> Bool match s1 s2 = map toLower s1 == map toLower s2 +-- | @parseHeaders hdrs@ takes a sequence of strings holding header +-- information and parses them into a set of headers (preserving their +-- order in the input argument.) Handles header values split up over +-- multiple lines. parseHeaders :: [String] -> Result [Header] -parseHeaders = - catRslts [] . map (parseHeader . clean) . joinExtended "" +parseHeaders = catRslts [] . + map (parseHeader . clean) . + joinExtended "" where -- Joins consecutive lines where the second line -- begins with ' ' or '\t'. diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -9,16 +9,8 @@ -- Stability : experimental -- Portability : non-portable (not tested) -- --- An easy access TCP library. Makes the use of TCP in Haskell much easier. --- This was originally part of Gray's\/Bringert's HTTP module. --- --- * Changes by Robin Bate Boerop : --- - Made dependencies explicit in import statements. --- - Removed false dependencies from import statements. --- - Removed unused exported functions. --- --- * Changes by Simon Foster: --- - Split module up into to separate Network.[Stream,TCP,HTTP] modules +-- Some utility functions for working with the Haskell @network@ package. Mostly +-- for internal use by the @Network.HTTP@ code, but -- ----------------------------------------------------------------------------- module Network.TCP @@ -74,7 +66,7 @@ ----------------------------------------------------------------- -- | The 'Connection' newtype is a wrapper that allows us to make --- connections an instance of the Stream class, without ghc extensions. +-- connections an instance of the Stream class, without GHC extensions. -- While this looks sort of like a generic reference to the transport -- layer it is actually TCP specific, which can be seen in the -- implementation of the 'Stream Connection' instance. @@ -123,6 +115,16 @@ setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) +-- | @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. +-- +-- The package provides 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. +-- class BufferType bufType => HStream bufType where openStream :: String -> Int -> IO (HandleStream bufType) readLine :: HandleStream bufType -> IO (Result bufType)