diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,20 @@ +Version 4004.0.5: release 2009-03-30; changes from 4004.0.4 + + * Get serious about comments and Haddock documentation. + * Cleaned up normalization of requests, fixing bugs and bringing together + previous disparate attempts at handling this. + * RequestMethod now supports custom verbs; use the (Custom String) constructor + * Beef up Network.HTTP.Base's support for normalizing requests and URIs: + + * added splitRequestURI which divides a URI into two; the Authority portion + (as a String) and the input URI sans the authority portion. Useful when + wanting to split up a request's URI into its Host: and abs_path pieces. + * added normalizeRequest :: Bool -> Request ty -> Request ty, which + fixes up a requests URI path and Host: info depending on whether it is + destined for a proxy or not (controlled by the Bool.) + * moved defaultRequest, defaultRequest_, libUA from Network.Browser + to Network.HTTP.Base + * added mkRequest :: RequestMethod -> URI -> Bool -> Request ty + for constructing normalized&sane Request bases on top of which + you can add custom headers, body payload etc. + diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.0.4 +Version: 4000.0.5 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3 @@ -12,7 +12,7 @@ Copyright (c) 2004, Ganesh Sittampalam Copyright (c) 2004-2005, Dominic Steinitz Copyright 2007 Robin Bate Boerop - Copyright 2008-2009 Sigbjorn Finne + Copyright 2008- Sigbjorn Finne Author: Warrick Gray Maintainer: Sigbjorn Finne Homepage: http://projects.haskell.org/http/ @@ -20,16 +20,29 @@ Synopsis: A library for client-side HTTP Description: - 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@. + 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: . - Inspired in part by Jonas Aadahl et al's work on ByteString'ifying HTTP - a couple of years ago. + > + > do + > rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/") + > -- fetch document and return it (as a 'String'.) + > fmap (take 100) (getResponseBody rsp) + > + > do + > rsp <- Network.Browser.browse $ do + > setAllowRedirects True -- handle HTTP redirects + > request $ getRequest "http://google.com/" + > fmap (take 100) (getResponseBody rsp) + > . Git repository available at +Extra-Source-Files: CHANGES + Flag old-base description: Old, monolithic base default: False @@ -53,11 +66,8 @@ Network.HTTP.MD5Aux, Network.HTTP.Utils GHC-options: -fwarn-missing-signatures -Wall - Build-depends: network, parsec, bytestring, mtl - + Build-depends: base >= 2, network, parsec, mtl if flag(old-base) Build-depends: base < 3 else - Build-depends: base >= 3 - - Build-depends: array, old-time + Build-depends: base >= 3, array, old-time, bytestring diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -1,91 +1,113 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.Browser --- Copyright : (c) Warrick Gray 2002 --- License : BSD --- --- Maintainer : Sigbjorn Finne --- Stability : experimental --- Portability : non-portable (not tested) --- --- An HTTP\/1.1 compatible wrapper for the HTTP module. ------------------------------------------------------------------------------ +{- | + +Module : Network.Browser +Copyright : (c) Warrick Gray 2002 +License : BSD -{- - Changes by Robin Bate Boerop : - - Made dependencies explicit in import statements. - - Added type signatures. - - Imported new StreamDebugger module. +Maintainer : Sigbjorn Finne +Stability : experimental +Portability : non-portable (not tested) - Change Log: - - altered 'closeTCP' to 'close', for consistency with altered HTTP - - added debugging settings to browser. +Session-level interactions over HTTP. + +The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in +providing support for more involved, and real, request/response interactions over +HTTP. Additional features supported are: - To Do: - - testing!!! - - remove BrowserAction type? Possibly replace with IORef? - - (more todo's in the HTTP mod) +* HTTP Authentication handling --} +* Transparent handling of redirects -module Network.Browser ( - BrowserState, - BrowserAction, -- browser monad, effectively a state monad. - Cookie, - Form(..), - Proxy(..), - - browse, -- BrowserAction a -> IO a - request, -- Request -> BrowserAction Response - - getBrowserState, - withBrowserState, - - setAllowRedirects, - getAllowRedirects, - - Authority(..), - getAuthorities, - setAuthorities, - addAuthority, - getAuthorityGen, - setAuthorityGen, - setAllowBasicAuth, +* Cookie stores + transmission. - setCookieFilter, - defaultCookieFilter, - userCookieFilter, - - getCookies, - setCookies, - addCookie, +* Transaction logging - setErrHandler, -- :: (String -> IO ()) -> BrowserAction t () - setOutHandler, -- :: (String -> IO ()) -> BrowserAction t () - - setEventHandler, -- :: (BrowserEvent t -> BrowserAction t ()) -> BrowserAction t () +* Proxy-mediated connections. + +Example use: + +> do +> rsp <- Network.Browser.browse $ do +> setAllowRedirects True -- handle HTTP redirects +> request $ getRequest "http://google.com/" +> fmap (take 100) (getResponseBody rsp) + +-} +module Network.Browser + ( BrowserState + , BrowserAction -- browser monad, effectively a state monad. + , Proxy(..) + + , browse -- :: BrowserAction a -> IO a + , request -- :: Request -> BrowserAction Response - BrowserEvent(..), - BrowserEventType(..), - RequestID, + , getBrowserState -- :: BrowserAction t (BrowserState t) + , withBrowserState -- :: BrowserState t -> BrowserAction t a -> BrowserAction t a + + , setAllowRedirects -- :: Bool -> BrowserAction t () + , getAllowRedirects -- :: BrowserAction t Bool - setProxy, + , setMaxRedirects -- :: Int -> BrowserAction t () + , getMaxRedirects -- :: BrowserAction t (Maybe Int) + + , Authority(..) + , getAuthorities + , setAuthorities + , addAuthority + , Challenge(..) + , Qop(..) + , Algorithm(..) + + , getAuthorityGen + , setAuthorityGen + , setAllowBasicAuth + + , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () + , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) - setDebugLog, + , setMaxAuthAttempts -- :: Maybe Int -> BrowserAction t () + , getMaxAuthAttempts -- :: BrowserAction t (Maybe Int) - out, - err, - ioAction, -- :: IO a -> BrowserAction a + , setCookieFilter -- :: (URI -> Cookie -> IO Bool) -> BrowserAction t () + , getCookieFilter -- :: BrowserAction t (URI -> Cookie -> IO Bool) + , defaultCookieFilter -- :: URI -> Cookie -> IO Bool + , userCookieFilter -- :: URI -> Cookie -> IO Bool + + , Cookie(..) + , getCookies -- :: BrowserAction t [Cookie] + , setCookies -- :: [Cookie] -> BrowserAction t () + , addCookie -- :: Cookie -> BrowserAction t () + + , setErrHandler -- :: (String -> IO ()) -> BrowserAction t () + , setOutHandler -- :: (String -> IO ()) -> BrowserAction t () + + , setEventHandler -- :: (BrowserEvent t -> BrowserAction t ()) -> BrowserAction t () + + , BrowserEvent(..) + , BrowserEventType(..) + , RequestID + + , setProxy -- :: Proxy -> BrowserAction t () + , getProxy -- :: BrowserAction t Proxy + , setDebugLog + + , out -- :: String -> BrowserAction t () + , err -- :: String -> BrowserAction t () + , ioAction -- :: IO a -> BrowserAction a - defaultGETRequest, - defaultGETRequest_, - formToRequest, - uriDefaultTo, - uriTrimHost -) where + , defaultGETRequest + , defaultGETRequest_ + + , formToRequest + , uriDefaultTo + + -- old and half-baked; don't use: + , Form(..) + , FormVar + ) where import Network.URI - ( URI(uriAuthority, uriScheme, uriPath, uriQuery) + ( URI(uriAuthority, uriPath, uriQuery) , URIAuth(..) , parseURI, parseURIReference, relativeTo ) @@ -101,7 +123,8 @@ import Data.Char (toLower,isAlphaNum,isSpace) import Data.List (isPrefixOf,isSuffixOf) import Data.Maybe (fromMaybe, listToMaybe, catMaybes, fromJust, isJust) -import Control.Monad (foldM, filterM, liftM, when) +import Control.Monad (filterM, liftM, when) + import Text.ParserCombinators.Parsec ( Parser, char, many, many1, satisfy, parse, option, try , (<|>), spaces, sepBy1 @@ -114,40 +137,12 @@ import Data.Word (Word8) -type Octet = Word8 - ------------------------------------------------------------------ ------------------------ Miscellaneous ---------------------------- ------------------------------------------------------------------- - -word, quotedstring :: Parser String -quotedstring = - do { char '"' -- " - ; str <- many (satisfy $ not . (=='"')) - ; char '"' - ; return str - } - -word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) - - --- | Returns a URI that is consistent with the first --- argument uri when read in the context of a second. --- If second argument is not sufficient context for --- determining a full URI then anarchy reins. -uriDefaultTo :: URI -> URI -> URI -uriDefaultTo a b = maybe a id (a `relativeTo` b) - -uriTrimHost :: URI -> URI -uriTrimHost uri = uri { uriScheme="", uriAuthority=Nothing } - ------------------------------------------------------------------- ----------------------- Cookie Stuff ----------------------------- ------------------------------------------------------------------ --- Some conventions: --- assume ckDomain is lowercase --- +-- | @Cookie@ is the Haskell representation of HTTP cookie values. +-- See its relevant specs for authoritative details. data Cookie = MkCookie { ckDomain :: String @@ -159,17 +154,19 @@ } deriving(Show,Read) - instance Eq Cookie where a == b = ckDomain a == ckDomain b && ckName a == ckName b && ckPath a == ckPath b - - +-- | @defaultCookieFilter@ is the initial cookie acceptance filter. +-- It welcomes them all into the store @:-)@ defaultCookieFilter :: URI -> Cookie -> IO Bool defaultCookieFilter _url _cky = return True +-- | @userCookieFilter@ is a handy acceptance filter, asking the +-- 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 = do putStrLn ("Set-Cookie received when requesting: " ++ show url) @@ -188,7 +185,6 @@ return (toLower x == 'y') - -- | Serialise a Cookie for inclusion in a request. cookieToHeader :: Cookie -> Header cookieToHeader ck = Header HdrCookie text @@ -255,15 +251,20 @@ --- | Adds a cookie to the browser state, removing duplicates. +-- | @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)) +-- | @setCookies cookies@ replaces the set of cookies known to +-- the browser to @cookies@. Useful when wanting to restore cookies +-- used across 'browse' invocations. setCookies :: [Cookie] -> BrowserAction t () setCookies cs = alterBS (\b -> b { bsCookies=cs }) +-- | @getCookies@ returns the current set of cookies known to +-- the browser. getCookies :: BrowserAction t [Cookie] getCookies = getBS bsCookies @@ -282,9 +283,11 @@ Just p -> p `isPrefixOf` path +-- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f }) +-- | @getCookieFilter@ returns the current cookie acceptance filter. getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) getCookieFilter = getBS bsCookieFilter @@ -331,7 +334,7 @@ -} - +-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. data Algorithm = AlgMD5 | AlgMD5sess deriving(Eq) @@ -339,22 +342,24 @@ show AlgMD5 = "md5" show AlgMD5sess = "md5-sess" - +-- | data Qop = QopAuth | QopAuthInt deriving(Eq,Show) -data Challenge = ChalBasic { chRealm :: String } - | ChalDigest { chRealm :: String - , chDomain :: [URI] - , chNonce :: String - , chOpaque :: Maybe String - , chStale :: Bool - , chAlgorithm ::Maybe Algorithm - , chQop :: [Qop] - } +data Challenge + = ChalBasic { chRealm :: String } + | ChalDigest { chRealm :: String + , chDomain :: [URI] + , chNonce :: String + , chOpaque :: Maybe String + , chStale :: Bool + , chAlgorithm ::Maybe Algorithm + , chQop :: [Qop] + } --- | Convert WWW-Authenticate header into a Challenge object +-- | @headerChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header +-- @www_auth@ into a 'Challenge' value. headerToChallenge :: URI -> Header -> Maybe Challenge headerToChallenge baseURI (Header _ str) = case parse challenge "" str of @@ -424,67 +429,91 @@ "md5-sess" -> Just AlgMD5sess _ -> Nothing - -data Authority = AuthBasic { auRealm :: String - , auUsername :: String - , auPassword :: String - , auSite :: URI - } - | AuthDigest { auRealm :: String - , auUsername :: String - , auPassword :: String - , auNonce :: String - , auAlgorithm :: Maybe Algorithm - , auDomain :: [URI] - , auOpaque :: Maybe String - , auQop :: [Qop] - } - +-- | @Authority@ specifies the HTTP Authentication method to use for +-- a given domain/realm; @Basic@ or @Digest@. +data Authority + = AuthBasic { auRealm :: String + , auUsername :: String + , auPassword :: String + , auSite :: URI + } + | AuthDigest{ auRealm :: String + , auUsername :: String + , auPassword :: String + , auNonce :: String + , auAlgorithm :: Maybe Algorithm + , auDomain :: [URI] + , auOpaque :: Maybe String + , auQop :: [Qop] + } -- | Return authorities for a given domain and path. -- Assumes "dom" is lower case getAuthFor :: String -> String -> BrowserAction t [Authority] -getAuthFor dom pth = - do { list <- getAuthorities - ; return (filter match list) - } - where - match :: Authority -> Bool - match (AuthBasic _ _ _ s) = matchURI s - match (AuthDigest _ _ _ _ _ ds _ _) = or (map matchURI ds) +getAuthFor dom pth = getAuthorities >>= return . (filter match) + where + match :: Authority -> Bool + match au@AuthBasic{} = matchURI (auSite au) + match au@AuthDigest{} = or (map matchURI (auDomain au)) - matchURI :: URI -> Bool - matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) + matchURI :: URI -> Bool + matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) --- | Interacting with browser state: +-- | @getAuthorities@ return the current set of @Authority@s known +-- to the browser. getAuthorities :: BrowserAction t [Authority] getAuthorities = getBS bsAuthorities +-- @setAuthorities as@ replaces the Browser's known set +-- of 'Authority's to @as@. setAuthorities :: [Authority] -> BrowserAction t () setAuthorities as = alterBS (\b -> b { bsAuthorities=as }) +-- @addAuthority a@ adds 'Authority' @a@ to the Browser's +-- set of known authorities. addAuthority :: Authority -> BrowserAction t () addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b }) +-- | @getAuthorityGen@ returns the current authority generator getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) getAuthorityGen = getBS bsAuthorityGen +-- | @setAuthorityGen genAct@ sets the auth generator to @genAct@. setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f }) +-- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication. setAllowBasicAuth :: Bool -> BrowserAction t () setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba }) +-- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts +-- to do. If @Nothing@, rever to default max. +setMaxAuthAttempts :: Maybe Int -> BrowserAction t () +setMaxAuthAttempts mb + | fromMaybe 0 mb < 0 = return () + | otherwise = alterBS (\ b -> b{bsMaxAuthAttempts=mb}) +-- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@, +-- the browser's default is used. +getMaxAuthAttempts :: BrowserAction t (Maybe Int) +getMaxAuthAttempts = getBS bsMaxAuthAttempts +-- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at +-- transmitting a request. If @Nothing@, rever to default max. +setMaxErrorRetries :: Maybe Int -> BrowserAction t () +setMaxErrorRetries mb + | fromMaybe 0 mb < 0 = return () + | otherwise = alterBS (\ b -> b{bsMaxErrorRetries=mb}) +-- | @getMaxErrorRetries@ returns the current max number of error retries. +getMaxErrorRetries :: BrowserAction t (Maybe Int) +getMaxErrorRetries = getBS bsMaxErrorRetries + -- TO BE CHANGED!!! pickChallenge :: [Challenge] -> Maybe Challenge pickChallenge = listToMaybe - - -- | Retrieve a likely looking authority for a Request. anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority) anticipateChallenge rq = @@ -493,7 +522,6 @@ ; return (listToMaybe authlist) } - -- | Asking the user to respond to a challenge challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) challengeToAuthority uri ch = @@ -572,6 +600,8 @@ digesturi = show (rqURI rq) noncevalue = auNonce a +type Octet = Word8 + -- FIXME: these probably only work right for latin-1 strings stringToOctets :: String -> [Octet] stringToOctets = map (fromIntegral . fromEnum) @@ -593,29 +623,35 @@ ------------------ Proxy Stuff ----------------------------------- ------------------------------------------------------------------ --- | Specifies if a proxy should be used for the request. -data Proxy = NoProxy -- ^ Don't use a proxy. - | Proxy String (Maybe Authority) -- ^ Use the proxy given. Should be of the form "http:\/\/host:port", "host", "host:port", or "http:\/\/host" - +-- | @Proxy@ specifies if a proxy should be used for the request. +data Proxy + = NoProxy -- ^ Don't use a proxy. + | Proxy String + (Maybe Authority) -- ^ Use the proxy given. Should be of the form "http:\/\/host:port", "host", "host:port", or "http:\/\/host". Optional 'Authority' to authenticate with the proxy as. ------------------------------------------------------------------ ------------------ Browser State Actions ------------------------- ------------------------------------------------------------------ +-- | @BrowserState@ is the (large) record type tracking the current +-- settings of the browser. data BrowserState connection - = BS { bsErr, bsOut :: String -> IO () - , bsCookies :: [Cookie] - , bsCookieFilter :: URI -> Cookie -> IO Bool - , bsAuthorityGen :: URI -> String -> IO (Maybe (String,String)) - , bsAuthorities :: [Authority] - , bsAllowRedirects :: Bool - , bsAllowBasicAuth :: Bool - , bsConnectionPool :: [connection] - , bsProxy :: Proxy - , bsDebug :: Maybe String - , bsEvent :: Maybe (BrowserEvent connection -> BrowserAction connection ()) - , bsRequestID :: RequestID + = BS { bsErr, bsOut :: String -> IO () + , bsCookies :: [Cookie] + , bsCookieFilter :: URI -> Cookie -> IO Bool + , bsAuthorityGen :: URI -> String -> IO (Maybe (String,String)) + , bsAuthorities :: [Authority] + , bsAllowRedirects :: Bool + , bsAllowBasicAuth :: Bool + , bsMaxRedirects :: Maybe Int + , bsMaxErrorRetries :: Maybe Int + , bsMaxAuthAttempts :: Maybe Int + , bsConnectionPool :: [connection] + , bsProxy :: Proxy + , bsDebug :: Maybe String + , bsEvent :: Maybe (BrowserEvent connection -> BrowserAction connection ()) + , bsRequestID :: RequestID } instance Show (BrowserState t) where @@ -624,23 +660,25 @@ {- ++ show (bsAuthorities bs) ++ "\n"-} ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") - --- Simple DIY stateful behaviour, with IO +-- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'. data BrowserAction conn a = BA { lift :: BrowserState conn -> IO (BrowserState conn,a) } instance Monad (BrowserAction conn) where a >>= f = BA (\b -> do { (nb,v) <- lift a b ; lift (f v) nb}) return x = BA (\b -> return (b,x)) + fail x = BA (\_ -> fail x) instance Functor (BrowserAction conn) where fmap f = liftM f --- | Apply a browser action to a state. +-- | @browse act@ is the toplevel action to perform a 'BrowserAction'. +-- Example use: @browse (request (getRequest yourURL))@. browse :: BrowserAction conn a -> IO a browse act = do x <- lift act defaultBrowserState return (snd x) +-- | Default browser state.. defaultBrowserState :: BrowserState t defaultBrowserState = res where @@ -649,11 +687,16 @@ , bsOut = putStrLn , bsCookies = [] , bsCookieFilter = defaultCookieFilter - , bsAuthorityGen = \ _uri _realm -> - (bsErr res) ("No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing") >> return Nothing + , bsAuthorityGen = \ _uri _realm -> do + bsErr res "No action for prompting/generating user+password credentials \ + \ provided (use: setAuthorityGen); returning Nothing" + return Nothing , bsAuthorities = [] , bsAllowRedirects = True , bsAllowBasicAuth = False + , bsMaxRedirects = Nothing + , bsMaxErrorRetries = Nothing + , bsMaxAuthAttempts = Nothing , bsConnectionPool = [] , bsProxy = NoProxy , bsDebug = Nothing @@ -668,9 +711,12 @@ getBS :: (BrowserState t -> a) -> BrowserAction t a getBS f = BA (\b -> return (b,f b)) +-- | @getBrowserState@ returns the current browser config. Useful +-- for restoring state across 'BrowserAction's. getBrowserState :: BrowserAction t (BrowserState t) getBrowserState = getBS id +-- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@. withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a withBrowserState bs act = BA $ \ _ -> lift act bs @@ -684,46 +730,76 @@ alterBS updReqID act --- | Do an io action +-- | Lifts an IO action into the 'BrowserAction' monad. ioAction :: IO a -> BrowserAction t a ioAction a = BA (\b -> a >>= \v -> return (b,v)) --- Stream handlers -setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction t () +-- | @setErrHandler@ sets the IO action to call when +-- the browser reports running errors. To disable any +-- such, set it to @const (return ())@. +setErrHandler :: (String -> IO ()) -> BrowserAction t () setErrHandler h = alterBS (\b -> b { bsErr=h }) + +-- | @setErrHandler@ 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 () setOutHandler h = alterBS (\b -> b { bsOut=h }) out, err :: String -> BrowserAction t () out s = do { f <- getBS bsOut ; ioAction $ f s } err s = do { f <- getBS bsErr ; ioAction $ f s } --- Redirects +-- | @setAllowRedirects onOff@ toggles the willingness to +-- follow redirects (HTTP responses with 3xx status codes). setAllowRedirects :: Bool -> BrowserAction t () setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl}) +-- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag. getAllowRedirects :: BrowserAction t Bool getAllowRedirects = getBS bsAllowRedirects +-- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops +-- we are willing to jump through. A no-op if the count is negative; if zero, +-- the max is set to whatever default applies. Notice that setting the max +-- redirects count does /not/ enable following of redirects itself; use +-- 'setAllowRedirects' to do so. +setMaxRedirects :: Maybe Int -> BrowserAction t () +setMaxRedirects c + | fromMaybe 0 c < 0 = return () + | otherwise = alterBS (\b -> b{bsMaxRedirects=c}) --- Proxy +-- | @getMaxRedirects@ returns the current setting for the max-redirect count. +-- If @Nothing@, the "Network.Browser"'s default is used. +getMaxRedirects :: BrowserAction t (Maybe Int) +getMaxRedirects = getBS bsMaxRedirects + +-- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@. +-- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted +-- as the URL of the proxy to use, possibly authenticating via +-- 'Authority' information in @mbAuth@. setProxy :: Proxy -> BrowserAction t () setProxy p = alterBS (\b -> b {bsProxy = p}) +-- | @getProxy@ returns the current proxy settings. getProxy :: BrowserAction t Proxy getProxy = getBS bsProxy - --- Debug +-- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@ +-- is @Nothing@. If set to @Just fStem@, logs of browser activity +-- is appended to files of the form @fStem-url-authority@, i.e., +-- @fStem@ is just the prefix for a set of log files, one per host/authority. setDebugLog :: Maybe String -> BrowserAction t () setDebugLog v = alterBS (\b -> b {bsDebug=v}) - --- Page control +-- | @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. data RequestState = RequestState { reqDenies :: Int -- ^ number of 401 responses so far , reqRedirects :: Int -- ^ number of redirects so far - , reqRetries :: Int -- ^ number of retrys so far + , reqRetries :: Int -- ^ number of retries so far , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response } @@ -737,9 +813,10 @@ , reqStopOnDeny = True } --- | 'BrowserEvent' is the event record type that a user-defined handler, set +-- | @BrowserEvent@ is the event record type that a user-defined handler, set -- via 'setEventHandler', will be passed. It indicates various state changes --- in the processing of a given Request ID. +-- encountered in the processing of a given 'RequestID', along with timestamps +-- at which they occurred. data BrowserEvent ty = BrowserEvent { browserTimestamp :: ClockTime @@ -762,8 +839,13 @@ | ResponseEnd ResponseData | ResponseFinish -setEventHandler :: (BrowserEvent ty -> BrowserAction ty ()) -> BrowserAction ty () -setEventHandler h = alterBS (\b -> b { bsEvent=Just h}) +-- | @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 mbH = alterBS (\b -> b { bsEvent=mbH}) buildBrowserEvent :: BrowserEventType t -> {-URI-}String -> RequestID -> IO (BrowserEvent t) buildBrowserEvent bt uri reqID = do @@ -784,34 +866,57 @@ evt <- ioAction $ buildBrowserEvent bt uri (bsRequestID st) evH evt -- if it fails, we fail. --- limits we are willing to not go beyond for method retries and number of auth deny responses. -maxRetries :: Int -maxRetries = 4 +-- | The default number of hops we are willing not to go beyond for +-- request forwardings. +defaultMaxRetries :: Int +defaultMaxRetries = 4 -maxDenies :: Int -maxDenies = 2 +-- | The default number of error retries we are willing to perform. +defaultMaxErrorRetries :: Int +defaultMaxErrorRetries = 4 --- Surely the most important bit: + +-- | The default maximum HTTP Authentication attempts we will make for +-- a single request. +defaultMaxAuthAttempts :: Int +defaultMaxAuthAttempts = 2 + +-- | @request httpRequest@ tries to submit the 'Request' @httpRequest@ +-- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.) +-- Upon successful delivery, the URL where the response was fetched from +-- is returned along with the 'Response' itself. request :: HStream ty => Request ty -> BrowserAction (HandleStream ty) (URI,Response ty) request req = newRequest $ do res <- request' nullVal initialState req reportEvent ResponseFinish (show (rqURI req)) - return res + case res of + Left e -> do + let errStr = ("Error raised during request handling: " ++ show e) + err errStr + fail errStr + Right r -> return r where initialState = nullRequestState nullVal = buf_empty bufferOps +-- | Internal helper function, carrying along per-request counts. request' :: HStream ty => ty -> RequestState -> Request ty - -> BrowserAction (HandleStream ty) (URI,Response ty) + -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) request' nullVal rqState rq = do - -- add cookies to request let uri = rqURI rq - cookies <- getCookiesFor (uriAuthToString $ reqURIAuth rq) (uriPath uri) + let uria = reqURIAuth rq + -- add cookies to request + cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) +{- Not for now: + (case uriUserInfo uria of + "" -> id + 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)) @@ -826,19 +931,23 @@ Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) let rq'' = insertHeaders (map cookieToHeader cookies) rq' p <- getProxy - let rq_to_go = normalizeRequestURI False{-no close-} - (uriToAuthorityString $ rqURI rq'') - rq'' - out ("Sending:\n" ++ show rq_to_go) + let defaultOpts = + case p of + NoProxy -> defaultNormalizeRequestOptions + Proxy _ ath -> + defaultNormalizeRequestOptions + { normForProxy=True + , normCustoms = + maybe [] + (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) + ath + } + let final_req = normalizeRequest defaultOpts rq'' + out ("Sending:\n" ++ show final_req) e_rsp <- case p of - NoProxy -> dorequest (reqURIAuth rq'') rq_to_go - Proxy str ath -> do - -- note: don't split off the authority for proxies.. - let rq_to_go' = maybe rq'' - (\x -> insertHeader HdrProxyAuthorization - (withAuthority x rq'') rq'') - ath + NoProxy -> dorequest (reqURIAuth rq'') final_req + Proxy str _ath -> do let notURI | null pt || null hst = URIAuth{ uriUserInfo = "" @@ -860,12 +969,15 @@ (parseURI str) out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth - dorequest proxyURIAuth rq_to_go' + dorequest proxyURIAuth final_req + mbMx <- getMaxErrorRetries case e_rsp of Left v - | (reqRetries rqState < maxRetries) && (v == ErrorReset || v == ErrorClosed) -> - request' nullVal rqState{reqRetries=reqRetries rqState + 1} rq - | otherwise -> error ("Exception raised in request: " ++ show v) + | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && + (v == ErrorReset || v == ErrorClosed) -> + request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq + | otherwise -> + return (Left v) Right rsp -> do out ("Received:\n" ++ show rsp) -- add new cookies to browser state @@ -875,79 +987,88 @@ when (not $ null newcookies) (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newcookies) - filterfn <- getCookieFilter + filterfn <- getCookieFilter newcookies' <- ioAction (filterM (filterfn uri) newcookies) - foldM (\_ -> addCookie) () newcookies' + mapM_ addCookie newcookies' when (not $ null newcookies) (out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies')) + mbMxAuths <- getMaxAuthAttempts case rspCode rsp of (4,0,1) -- Credentials not sent or refused. - | reqDenies rqState > maxDenies -> do + | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do out "401 - credentials again refused; exceeded retry count (2)" - return (uri,rsp) + return (Right (uri,rsp)) | otherwise -> do out "401 - credentials not supplied or refused; retrying.." let hdrs = retrieveHeaders HdrWWWAuthenticate rsp case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of - Nothing -> return (uri,rsp) {- do nothing -} + Nothing -> return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x case au of - Nothing -> return (uri,rsp) {- do nothing -} + Nothing -> return (Right (uri,rsp)) {- do nothing -} Just au' -> do out "Retrying request with new credentials" request' nullVal - rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False} + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } (insertHeader HdrAuthorization (withAuthority au' rq) rq) (4,0,7) -- Proxy Authentication required - | reqDenies rqState > maxDenies -> do + | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do out "407 - proxy authentication required; max deny count exceeeded (2)" - return (uri,rsp) + return (Right (uri,rsp)) | otherwise -> do out "407 - proxy authentication required" let hdrs = retrieveHeaders HdrProxyAuthenticate rsp case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of - Nothing -> return (uri,rsp) {- do nothing -} + Nothing -> return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x case au of - Nothing -> return (uri,rsp) {- do nothing -} + Nothing -> return (Right (uri,rsp)) {- do nothing -} Just au' -> do pxy <- getBS bsProxy case pxy of NoProxy -> do err "Proxy authentication required without proxy!" - return (uri,rsp) + return (Right (uri,rsp)) Proxy px _ -> do out "Retrying with proxy authentication" setProxy (Proxy px (Just au')) request' nullVal - rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False} + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } rq (3,0,x) | x == 3 || x == 2 -> do -- Redirect using GET request method. out ("30" ++ show x ++ " - redirect using GET") rd <- getAllowRedirects - if not rd || reqRedirects rqState > maxRetries - then return (uri,rsp) + mbMxRetries <- getMaxRedirects + if not rd || reqRedirects rqState > fromMaybe defaultMaxRetries mbMxRetries + then return (Right (uri,rsp)) else case retrieveHeaders HdrLocation rsp of [] -> do - err "No Location header in redirect response" - return (uri,rsp) + err "No Location: header in redirect response" + return (Right (uri,rsp)) (Header _ u:_) -> case parseURIReference u of Nothing -> do - err ("Parse of Location header in a redirect response failed: " ++ u) - return (uri,rsp) + 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=reqRedirects rqState + 1, reqStopOnDeny=True} + rqState{ reqDenies = 0 + , reqRedirects = succ(reqRedirects rqState) + , reqStopOnDeny = True + } (replaceHeader HdrContentLength "0" rq1) where newuri' = maybe newuri id (newuri `relativeTo` uri) @@ -956,50 +1077,54 @@ case retrieveHeaders HdrLocation rsp of [] -> do err "No Location header in proxy redirect response." - return (uri,rsp) + return (Right (uri,rsp)) (Header _ u:_) -> case parseURIReference u of Nothing -> do err ("Parse of Location header in a proxy redirect response failed: " ++ u) - return (uri,rsp) + return (Right (uri,rsp)) Just newuri -> do out ("Retrying with proxy " ++ show newuri ++ "...") setProxy (Proxy (uriToAuthorityString newuri) Nothing) - request' nullVal rqState{ reqDenies=0 - , reqRedirects=0 - , reqRetries=reqRetries rqState + 1 - , reqStopOnDeny=True + request' nullVal rqState{ reqDenies = 0 + , reqRedirects = 0 + , reqRetries = succ (reqRetries rqState) + , reqStopOnDeny = True } rq (3,_,_) -> redirect uri rsp - _ -> return (uri,rsp) + _ -> return (Right (uri,rsp)) where redirect uri rsp = do - rd <- getAllowRedirects - if not rd || reqRedirects rqState > maxRetries - then return (uri,rsp) + rd <- getAllowRedirects + mbMxRetries <- getMaxRedirects + if not rd || reqRedirects rqState > fromMaybe defaultMaxRetries mbMxRetries + then return (Right (uri,rsp)) else do case retrieveHeaders HdrLocation rsp of [] -> do err "No Location header in redirect response." - return (uri,rsp) + 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' ++ " ...") request' nullVal - rqState{reqDenies=0, reqRedirects=reqRedirects rqState + 1, reqStopOnDeny=True} + rqState{ reqDenies = 0 + , reqRedirects = succ (reqRedirects rqState) + , reqStopOnDeny = True + } rq{rqURI=newuri'} Nothing -> do err ("Parse of Location header in a redirect response failed: " ++ u) - return (uri,rsp) + 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 @@ -1010,27 +1135,17 @@ ; 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) -> - case reads s of { ((v,_):_) -> v ; _ -> 80} - _ -> 80 + ; let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst ; reportEvent OpenConnection (show (rqURI rqst)) - ; c <- ioAction $ openStream (uriRegName hst) aport - ; 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 + ; 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 } @@ -1053,44 +1168,23 @@ sendHTTP_notify c' r onSendComplete -reqURIAuth :: Request ty -> URIAuth -reqURIAuth req = - case uriAuthority (rqURI req) of - Just ua -> ua - _ -> case lookupHeader HdrHost (rqHeaders req) of - Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req) - Just h -> URIAuth { uriUserInfo = "" - , uriRegName = h - , uriPort = "" - } - ------------------------------------------------------------------- ------------------- Request Building ------------------------------ ------------------------------------------------------------------- - -libUA :: String -libUA = "hs-HTTP/4.0.3" - -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=empty - , rqHeaders=[ Header HdrContentLength "0" - , Header HdrUserAgent libUA - ] - , rqMethod=GET - } - - toBufOps :: BufferType a => Request a -> BufferOp a - toBufOps _ = bufferOps +updateConnectionPool :: HStream hTy + => HandleStream hTy + -> BrowserAction (HandleStream hTy) () +updateConnectionPool c = do + pool <- getBS bsConnectionPool + let len_pool = length pool + when (len_pool > maxPoolSize) + (ioAction $ close (last pool)) + let pool' + | len_pool > maxPoolSize = init pool + | otherwise = pool + alterBS (\b -> b { bsConnectionPool=c:pool' }) + return () + +-- | Maximum number of open connections we are willing to have active. +maxPoolSize :: Int +maxPoolSize = 5 -- This form junk is completely untested... @@ -1098,7 +1192,6 @@ data Form = Form RequestMethod URI [FormVar] - formToRequest :: Form -> Request_String formToRequest (Form m u vs) = let enc = urlEncodeVars vs @@ -1115,3 +1208,26 @@ , rqURI=u } _ -> error ("unexpected request: " ++ show m) + + +------------------------------------------------------------------ +----------------------- Miscellaneous ---------------------------- +------------------------------------------------------------------ + +-- | @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@. +-- If the second argument is not sufficient context for determining +-- a full URI then anarchy reins. +uriDefaultTo :: URI -> URI -> URI +uriDefaultTo a b = maybe a id (a `relativeTo` b) + + +word, quotedstring :: Parser String +quotedstring = + do { char '"' -- " + ; str <- many (satisfy $ not . (=='"')) + ; char '"' + ; return str + } + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff --git a/Network/BufferType.hs b/Network/BufferType.hs --- a/Network/BufferType.hs +++ b/Network/BufferType.hs @@ -30,6 +30,8 @@ import System.IO ( Handle ) import Data.Word ( Word8 ) +import Network.HTTP.Utils ( crlf ) + -- | 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 @@ -58,6 +60,7 @@ , buf_hGetLine :: Handle -> IO a , buf_empty :: a , buf_append :: a -> a -> a + , buf_concat :: [a] -> a , buf_fromStr :: String -> a , buf_toStr :: a -> String , buf_snoc :: a -> Word8 -> a @@ -78,17 +81,18 @@ , buf_hPut = Strict.hPut , buf_hGetLine = Strict.hGetLine , buf_append = Strict.append + , buf_concat = Strict.concat , buf_fromStr = Strict.pack , buf_toStr = Strict.unpack , buf_snoc = Strict.snoc , buf_splitAt = Strict.splitAt , buf_span = Strict.span , buf_empty = Strict.empty - , buf_isLineTerm = \ b -> Strict.length b == 2 && crlf == b + , buf_isLineTerm = \ b -> Strict.length b == 2 && p_crlf == b , buf_isEmpty = Strict.null } where - crlf = Strict.pack "\r\n" + p_crlf = Strict.pack crlf lazyBufferOp :: BufferOp Lazy.ByteString lazyBufferOp = @@ -98,17 +102,18 @@ , buf_hPut = Lazy.hPut , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) , buf_append = Lazy.append + , buf_concat = Lazy.concat , buf_fromStr = Lazy.pack , buf_toStr = Lazy.unpack , buf_snoc = Lazy.snoc , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x , buf_span = Lazy.span , buf_empty = Lazy.empty - , buf_isLineTerm = \ b -> Lazy.length b == 2 && crlf == b + , buf_isLineTerm = \ b -> Lazy.length b == 2 && p_crlf == b , buf_isEmpty = Lazy.null } where - crlf = Lazy.pack "\r\n" + p_crlf = Lazy.pack crlf stringBufferOp :: BufferOp String stringBufferOp =BufferOp @@ -117,6 +122,7 @@ , buf_hPut = \ h s -> Strict.hPut h (Strict.pack s) , buf_hGetLine = \ h -> Strict.hGetLine h >>= return . Strict.unpack , buf_append = (++) + , buf_concat = concat , buf_fromStr = id , buf_toStr = id , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] @@ -128,5 +134,4 @@ , buf_isLineTerm = \ b -> b == crlf , buf_isEmpty = null } - where - crlf = "\r\n" + diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -4,23 +4,164 @@ -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop -- License : BSD -- --- Maintainer : bjorn@bringert.net +-- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- --- An easy HTTP interface, toplevel module. +-- The 'Network.HTTP' module provides a simple interface for sending and +-- receiving content over HTTP in Haskell. Here's how to fetch a document from +-- a URL and return it as a String: -- --- The 'Network.HTTP' module provides functionality for sending --- HTTP requests and processing their responses, along with a supporting --- cast of types and utility functions. +-- > +-- > simpleHTTP (getRequest "http://www.haskell.org/") >>= fmap (take 100) . getResponseBody +-- > -- fetch document and return it (as a 'String'.) -- +-- Other functions let you control the submission and transfer of HTTP +-- 'Request's and 'Response's more carefully, letting you integrate the use +-- of 'Network.HTTP' functionality into your application. +-- +-- The module also exports the main types of the package, 'Request' and 'Response', +-- along with 'Header' and functions for working with these. +-- -- 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 +-- namespace, letting you either use the default implementation here +-- by importing @Network.HTTP@ or, for more specific uses, 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.) +-- supported. (see "Network.HTTP.HandleStream".) -- +-- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission. +-- Normalization such as having the request path be in the expected form and, possibly, +-- introduce a default @Host:@ header if one isn't already present. If you do not +-- want the requests tampered with, but sent as-is, please import and use the +-- the "Network.HTTP.HandleStream" or "Network.HTTP.Stream" modules instead. They +-- export the same functions, but leaves construction and any normalization of +-- @Request@s to the user. +-- +----------------------------------------------------------------------------- +module Network.HTTP + ( module Network.HTTP.Base + , module Network.HTTP.Headers + + {- the functionality that the implementation modules, + 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) + , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response) + , receiveHTTP -- :: Stream s => s -> IO (Result Request) + , respondHTTP -- :: Stream s => s -> Response -> IO () + + , module Network.TCP + + , getRequest -- :: String -> Request_String + , postRequest -- :: String -> Request_String + + , getResponseBody -- :: Requesty ty -> ty + ) where + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.HTTP.Headers +import Network.HTTP.Base +import qualified Network.HTTP.HandleStream as S +-- old implementation: import Network.HTTP.Stream +import Network.TCP +import Network.Stream ( Result ) +import Network.URI ( parseURI ) + +import Data.Maybe ( fromMaybe ) + +{- + Note: if you switch over/back to using Network.HTTP.Stream here, you'll + have to wrap the results from 'openStream' as Connections via 'hstreamToConnection' + prior to delegating to the Network.HTTP.Stream functions. +-} + +-- | @simpleHTTP req@ transmits the 'Request' @req@ by opening a /direct/, non-persistent +-- connection to the HTTP server that @req@ is destined for, followed by transmitting +-- it and gathering up the response as a 'Result'. Prior to sending the request, +-- it is normalized (via 'normalizeRequest'). If you have to mediate the request +-- via an HTTP proxy, you will have to normalize the request yourself. Or switch to +-- using 'Network.Browser' instead. +-- +-- Examples: +-- +-- > simpleHTTP (getRequest "http://hackage.haskell.org/") +-- > simpleHTTP (getRequest "http://hackage.haskell.org:8012/") + +simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty)) +simpleHTTP r = do + auth <- getAuth r + c <- openStream (host auth) (fromMaybe 80 (port auth)) + let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r + simpleHTTP_ c norm_r + +-- | Identical to 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +simpleHTTP_ s r = do + let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r + S.sendHTTP s norm_r + +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ (after normalization) over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- closed upon receiving the response. +sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +sendHTTP conn rq = do + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + S.sendHTTP conn norm_r + +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + S.sendHTTP_notify conn norm_r onSendComplete + +-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ +receiveHTTP :: HStream ty => HandleStream ty -> IO (Result (Request ty)) +receiveHTTP conn = S.receiveHTTP conn + +-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over +-- the 'HandleStream' @hStream@. It could be used to implement simple web +-- server interactions, performing the dual role to 'sendHTTP'. +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 +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 +postRequest urlString = + case parseURI urlString of + Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) + Just u -> mkRequest POST u + +-- | @getResponseBody response@ takes the response of a HTTP requesting action and +-- tries to extricate the body of the 'Response' @response@. If the request action +-- returned an error, an IO exception is raised. +getResponseBody :: Result (Response ty) -> IO ty +getResponseBody (Left err) = fail (show err) +getResponseBody (Right r) = return (rspBody r) + +-- -- * TODO -- - request pipelining -- - https upgrade (includes full TLS, i.e. SSL, implementation) @@ -70,34 +211,3 @@ -- added to a request. Receipt of 417 will induce another -- request attempt (without Expect header), unless no Expect header -- had been added (in which case 417 response is returned). --- ------------------------------------------------------------------------------ -module Network.HTTP - ( module Network.HTTP.HandleStream - , 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) - , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response) - , receiveHTTP -- :: Stream s => s -> IO (Result Request) - , respondHTTP -- :: Stream s => s -> Response -> IO () --} - , module Network.TCP - ) where - ------------------------------------------------------------------ ------------------- Imports -------------------------------------- ------------------------------------------------------------------ - -import Network.HTTP.Headers -import Network.HTTP.Base ---import Network.HTTP.Stream -import Network.HTTP.HandleStream -import Network.TCP - - - diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -8,13 +8,19 @@ -- Stability : experimental -- Portability : non-portable (not tested) -- --- An easy HTTP interface; base types. +-- Definitions of @Request@ and @Response@ types along with functions +-- for normalizing them. It is assumed to be an internal module; user +-- code should, if possible, import @Network.HTTP@ to access the functionality +-- that this module provides. -- +-- Additionally, the module exports internal functions for working with URLs, +-- and for handling the processing of requests and responses coming back. +-- ----------------------------------------------------------------------------- module Network.HTTP.Base ( -- ** Constants - httpVersion + httpVersion -- :: String -- ** HTTP , Request(..) @@ -36,18 +42,28 @@ , parseURIAuthority -- internal - , crlf - , sp - , uriToAuthorityString -- :: URI -> String + , uriToAuthorityString -- :: URI -> String , uriAuthToString -- :: URIAuth -> String - , parseResponseHead - , parseRequestHead + , uriAuthPort -- :: Maybe URI -> URIAuth -> Int + , reqURIAuth -- :: Request ty -> URIAuth + + , parseResponseHead -- :: [String] -> Result ResponseData + , parseRequestHead -- :: [String] -> Result RequestData + , ResponseNextStep(..) , matchResponse , ResponseData , ResponseCode , RequestData + , NormalizeRequestOptions(..) + , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty + , RequestNormalizer + + , normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty + + , splitRequestURI + , getAuth , normalizeRequestURI , normalizeHostHeader @@ -61,28 +77,42 @@ , readTillEmpty1 , readTillEmpty2 + , defaultGETRequest + , defaultGETRequest_ + , mkRequest + + , defaultUserAgent + , libUA {- backwards compatibility, will disappear..soon -} + , catchIO , catchIO_ , responseParseError + + , getRequestVersion + , getResponseVersion + , setRequestVersion + , setResponseVersion + ) where import Network.URI ( URI(uriAuthority, uriPath, uriScheme) - , URIAuth(uriUserInfo, uriRegName, uriPort) + , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort) , parseURIReference ) import Control.Monad ( guard ) -import Control.Monad.Error -import Data.Char ( ord, digitToInt, intToDigit, toLower ) -import Data.List ( partition ) -import Data.Maybe ( listToMaybe ) -import Numeric ( showHex, readHex ) +import Control.Monad.Error () +import Data.Char ( digitToInt, intToDigit, toLower, isDigit, + isAscii, isAlphaNum ) +import Data.List ( partition, find ) +import Data.Maybe ( listToMaybe, fromMaybe ) +import Numeric ( readHex ) import Network.Stream -import Network.BufferType ( BufferOp(..) ) +import Network.BufferType ( BufferOp(..), BufferType(..) ) import Network.HTTP.Headers -import Network.HTTP.Utils ( trim ) +import Network.HTTP.Utils ( trim, crlf, sp, readsOne ) import Text.Read.Lex (readDecP) import Text.ParserCombinators.ReadP @@ -143,6 +173,43 @@ , uriPort ua ] +uriAuthPort :: Maybe URI -> URIAuth -> Int +uriAuthPort mbURI u = + case uriPort u of + (':':s) -> readsOne id (default_port mbURI) s + _ -> default_port mbURI + where + default_port Nothing = default_http + default_port (Just url) = + case map toLower $ uriScheme url of + "http:" -> default_http + "https:" -> default_https + -- todo: refine + _ -> default_http + + default_http = 80 + default_https = 443 + +-- Fish out the authority from a possibly normalized Request, i.e., +-- the information may either be in the request's URI or inside +-- the Host: header. +reqURIAuth :: Request ty -> URIAuth +reqURIAuth req = + case uriAuthority (rqURI req) of + Just ua -> ua + _ -> case lookupHeader HdrHost (rqHeaders req) of + Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req) + Just h -> + case toHostPort h of + (ht,p) -> URIAuth { uriUserInfo = "" + , uriRegName = ht + , uriPort = p + } + where + -- Note: just in case you're wondering..the convention is to include the ':' + -- in the port part.. + toHostPort h = break (==':') h + ----------------------------------------------------------------- ------------------ HTTP Messages -------------------------------- ----------------------------------------------------------------- @@ -156,9 +223,22 @@ -- | The HTTP request method, to be used in the 'Request' object. -- We are missing a few of the stranger methods, but these are -- not really necessary until we add full TLS. -data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE - deriving(Show,Eq) +data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String + deriving(Eq) +instance Show RequestMethod where + show x = + case x of + HEAD -> "HEAD" + PUT -> "PUT" + GET -> "GET" + POST -> "POST" + DELETE -> "DELETE" + OPTIONS -> "OPTIONS" + TRACE -> "TRACE" + CONNECT -> "CONNECT" + Custom c -> c + rqMethodMap :: [(String, RequestMethod)] rqMethodMap = [("HEAD", HEAD), ("PUT", PUT), @@ -166,7 +246,8 @@ ("POST", POST), ("DELETE", DELETE), ("OPTIONS", OPTIONS), - ("TRACE", TRACE)] + ("TRACE", TRACE), + ("CONNECT", CONNECT)] -- -- for backwards-ish compatibility; suggest @@ -190,26 +271,21 @@ -- 2) transparent support for both relative -- & absolute uris, although this should -- already work (leave scheme & host parts empty). - , rqMethod :: RequestMethod + , rqMethod :: RequestMethod , rqHeaders :: [Header] , rqBody :: a } - - -crlf, sp :: String -crlf = "\r\n" -sp = " " - -- Notice that request body is not included, -- this show function is used to serialise -- a request for the transport link, we send -- the body separately where possible. instance Show (Request a) where - show (Request u m h _) = - show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf - ++ foldr (++) [] (map show h) ++ crlf + show req@(Request u m h _) = + show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf + ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf where + ver = fromMaybe httpVersion (getRequestVersion req) alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' then u { uriPath = '/' : uriPath u } else u @@ -246,14 +322,69 @@ -- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1 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 + show rsp@(Response (a,b,c) reason headers _) = + ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf + ++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf + where + ver = fromMaybe httpVersion (getResponseVersion rsp) instance HasHeaders (Response a) where getHeaders = rspHeaders setHeaders rsp hdrs = rsp { rspHeaders=hdrs } + +------------------------------------------------------------------ +------------------ Request Building ------------------------------ +------------------------------------------------------------------ +libUA :: String +libUA = "hs-HTTP-4000.0.5" + +defaultUserAgent :: String +defaultUserAgent = libUA + +defaultGETRequest :: URI -> Request_String +defaultGETRequest uri = defaultGETRequest_ uri + +defaultGETRequest_ :: BufferType a => URI -> Request a +defaultGETRequest_ uri = mkRequest GET uri + +-- | 'mkRequest method uri' constructs a well formed +-- request for the given HTTP method and URI. It does not +-- normalize the URI for the request _nor_ add the required +-- Host: header. That is done either explicitly by the user +-- or when requests are normalized prior to transmission. +mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty +mkRequest meth uri = req + where + req = + Request { rqURI = uri + , rqBody = empty + , rqHeaders = [ Header HdrContentLength "0" + , Header HdrUserAgent defaultUserAgent + ] + , rqMethod = meth + } + + empty = buf_empty (toBufOps req) + +{- + -- stub out the user info. + updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri) + + withHost = + case uriToAuthorityString uri{uriAuthority=updAuth} of + "" -> id + h -> ((Header HdrHost h):) + + uri_req + | forProxy = uri + | otherwise = snd (splitRequestURI uri) +-} + + +toBufOps :: BufferType a => Request a -> BufferOp a +toBufOps _ = bufferOps + ----------------------------------------------------------------- ------------------ Parsing -------------------------------------- ----------------------------------------------------------------- @@ -262,13 +393,17 @@ parseRequestHead :: [String] -> Result RequestData parseRequestHead [] = Left ErrorClosed parseRequestHead (com:hdrs) = do - (_version,rqm,uri) <- requestCommand com (words com) + (version,rqm,uri) <- requestCommand com (words com) hdrs' <- parseHeaders hdrs - return (rqm,uri,hdrs') + return (rqm,uri,withVer version hdrs') where + withVer [] hs = hs + withVer (h:_) hs = withVersion h hs + requestCommand l _yes@(rqm:uri:version) = case (parseURIReference uri, lookup rqm rqMethodMap) of (Just u, Just r) -> return (version,r,u) + (Just u, Nothing) -> return (version,Custom rqm,u) _ -> parse_err l requestCommand l _ | null l = failWith ErrorClosed @@ -281,9 +416,9 @@ parseResponseHead :: [String] -> Result ResponseData parseResponseHead [] = failWith ErrorClosed parseResponseHead (sts:hdrs) = do - (_version,code,reason) <- responseStatus sts (words sts) + (version,code,reason) <- responseStatus sts (words sts) hdrs' <- parseHeaders hdrs - return (code,reason,hdrs') + return (code,reason, withVersion version hdrs') where responseStatus _l _yes@(version:code:reason) = return (version,match code,concatMap (++" ") reason) @@ -301,9 +436,69 @@ digitToInt c) match _ = (-1,-1,-1) -- will create appropriate behaviour +-- To avoid changing the @RequestData@ and @ResponseData@ types +-- just for this (and the upstream backwards compat. woes that +-- will result in), encode version info as a custom header. +-- Used by 'parseResponseData' and 'parseRequestData'. +-- +-- Note: the Request and Response types do not currently represent +-- the version info explicitly in their record types. You have to use +-- {get,set}{Request,Response}Version for that. +withVersion :: String -> [Header] -> [Header] +withVersion v hs + | v == httpVersion = hs -- don't bother adding it if the default. + | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs - +-- | @getRequestVersion req@ returns the HTTP protocol version of +-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed. +getRequestVersion :: Request a -> Maybe String +getRequestVersion r = getHttpVersion r +-- | @setRequestVersion v req@ returns a new request, identical to +-- @req@, but with its HTTP version set to @v@. +setRequestVersion :: String -> Request a -> Request a +setRequestVersion s r = setHttpVersion r s + + +-- | @getResponseVersion rsp@ returns the HTTP protocol version of +-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be +-- assumed. +getResponseVersion :: Response a -> Maybe String +getResponseVersion r = getHttpVersion r + +-- | @setResponseVersion v rsp@ returns a new response, identical to +-- @rsp@, but with its HTTP version set to @v@. +setResponseVersion :: String -> Response a -> Response a +setResponseVersion s r = setHttpVersion r s + +-- internal functions for accessing HTTP-version info in +-- requests and responses. Not exported as it exposes ho +-- version info is represented internally. + +getHttpVersion :: HasHeaders a => a -> Maybe String +getHttpVersion r = + fmap toVersion $ + find isHttpVersion $ + getHeaders r + where + toVersion (Header _ x) = x + +setHttpVersion :: HasHeaders a => a -> String -> a +setHttpVersion r v = + setHeaders r $ + withVersion v $ + dropHttpVersion $ + getHeaders r + +dropHttpVersion :: [Header] -> [Header] +dropHttpVersion hs = filter (not.isHttpVersion) hs + +isHttpVersion :: Header -> Bool +isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True +isHttpVersion _ = False + + + ----------------------------------------------------------------- ------------------ HTTP Send / Recv ---------------------------------- ----------------------------------------------------------------- @@ -360,34 +555,33 @@ Escape method: char -> '%' a b where a, b :: Hex digits -} -urlEncode, urlDecode :: String -> String - +urlDecode :: String -> String urlDecode ('%':a:b:rest) = toEnum (16 * digitToInt a + digitToInt b) : urlDecode rest urlDecode (h:t) = h : urlDecode t urlDecode [] = [] -urlEncode (h:t) = - let str = if reserved (ord h) then escape h else [h] - in str ++ urlEncode t - where - reserved x - | x >= ord 'a' && x <= ord 'z' = False - | x >= ord 'A' && x <= ord 'Z' = False - | x >= ord '0' && x <= ord '9' = False - | x <= 0x20 || x >= 0x7F = True - | otherwise = x `elem` map ord [';','/','?',':','@','&' - ,'=','+',',','$','{','}' - ,'|','\\','^','[',']','`' - ,'<','>','#','%','"'] - -- wouldn't it be nice if the compiler - -- optimised the above for us? - escape x = '%':showHex (ord x) "" - -urlEncode [] = [] - +urlEncode :: String -> String +urlEncode [] = [] +urlEncode (ch:t) + | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t + | not (isAscii ch) = foldr escape (urlEncode t) (eightBs [] (fromEnum ch)) + | otherwise = escape (fromEnum ch) (urlEncode t) + where + escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs) + + showH x xs + | x <= 9 = toEnum (o_0 + x) : xs + | otherwise = toEnum (o_A + (x-10)) : xs + where + o_0 = fromEnum '0' + o_A = fromEnum 'A' + eightBs :: [Int] -> Int -> [Int] + eightBs acc x + | x <= 0xff = (x:acc) + | otherwise = eightBs ((x `mod` 256) : acc) (x `div` 256) -- Encode form variables, useable in either the -- query part of a URI, or the body of a POST request. @@ -411,21 +605,10 @@ Just x -> return x Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" where - auth = - case findHeader HdrHost r of - Just h -> h - Nothing -> uriToAuthorityString (rqURI r) + auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r) + uri = rqURI r - {- RFC 2616, section 5.1.2: - "The most common form of Request-URI is that used to identify a - resource on an origin server or gateway. In this case the absolute - path of the URI MUST be transmitted (see section 3.2.1, abs_path) as - the Request-URI, and the network location of the URI (authority) MUST - be transmitted in a Host header field." -} - -- we assume that this is the case, so we take the host name from - -- 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. +{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty normalizeRequestURI doClose h r = (if doClose then replaceHeader HdrConnection "close" else id) $ @@ -434,7 +617,121 @@ , uriAuthority = Nothing }} --- Adds a Host header if one is NOT ALREADY PRESENT +-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options +-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option +data NormalizeRequestOptions ty + = NormalizeRequestOptions + { normDoClose :: Bool + , normForProxy :: Bool + , normUserAgent :: Maybe String + , normCustoms :: [RequestNormalizer ty] + } + +-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites +-- a request into some normalized form. +type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty + +defaultNormalizeRequestOptions :: NormalizeRequestOptions ty +defaultNormalizeRequestOptions = NormalizeRequestOptions + { normDoClose = False + , normForProxy = False + , normUserAgent = Just defaultUserAgent + , normCustoms = [] + } + +-- | @normalizeRequest opts req@ is the entry point to use to normalize your +-- request prior to transmission (or other use.) Normalization is controlled +-- via the @NormalizeRequestOptions@ record. +normalizeRequest :: NormalizeRequestOptions ty + -> Request ty + -> Request ty +normalizeRequest opts req = foldr (\ f -> f opts) req normalizers + where + --normalizers :: [RequestNormalizer ty] + normalizers = + ( normalizeHostURI + : normalizeConnectionClose + : normalizeUserAgent + : normCustoms opts + ) + +-- | @normalizeUserAgent ua x req@ augments the request @req@ with +-- a @User-Agent: ua@ header if @req@ doesn't already have a +-- a @User-Agent:@ set. +normalizeUserAgent :: RequestNormalizer ty +normalizeUserAgent opts req = + case normUserAgent opts of + Nothing -> req + Just ua -> + case findHeader HdrUserAgent req of + Nothing -> setHeaders req (mkHeader HdrUserAgent ua : getHeaders req) + Just{} -> req + +-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ +-- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then +-- _replaces_ any an existing @Connection:@ header in @req@. +normalizeConnectionClose :: RequestNormalizer ty +normalizeConnectionClose opts req + | normDoClose opts = replaceHeader HdrConnection "close" req + | otherwise = req + +-- | @normalizeHostURI forProxy req@ rewrites your request to have it +-- follow the expected formats by the receiving party (proxy or server.) +-- +normalizeHostURI :: RequestNormalizer ty +normalizeHostURI opts req = + case splitRequestURI uri of + ("",_uri_abs) + | forProxy -> + case findHeader HdrHost req of + Nothing -> req -- no host/authority in sight..not much we can do. + Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum} + , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri + }} + where + hst = case span (/='@') user_hst of + (as,'@':bs) -> + case span (/=':') as of + (_,_:_) -> bs + _ -> user_hst + _ -> user_hst + + (user_hst, pNum) = + case span isDigit (reverse h) of + (ds,':':bs) -> (reverse bs, ':':reverse ds) + _ -> (h,"") + | otherwise -> + case findHeader HdrHost req of + 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} + where + uri0 = rqURI req + -- stub out the user:pass + uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} + + forProxy = normForProxy opts + +{- Comments re: above rewriting: + RFC 2616, section 5.1.2: + "The most common form of Request-URI is that used to identify a + resource on an origin server or gateway. In this case the absolute + path of the URI MUST be transmitted (see section 3.2.1, abs_path) as + the Request-URI, and the network location of the URI (authority) MUST + be transmitted in a Host header field." + We assume that this is the case, so we take the host name from + 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. +-} + +splitRequestURI :: URI -> ({-authority-}String, URI) +splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing}) + +-- Adds a Host header if one is NOT ALREADY PRESENT.. +{-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeHostHeader :: Request ty -> Request ty normalizeHostHeader rq = insertHeaderIfMissing HdrHost @@ -449,7 +746,6 @@ (\ x -> map toLower (trim x) == "close") (lookupHeader HdrConnection hdrs) - -- | Used when we know exactly how many bytes to expect. linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) @@ -476,36 +772,36 @@ -> IO (Result a) -> (Int -> IO (Result a)) -> IO (Result ([Header], a)) -chunkedTransfer bufOps readL readBlk = - fmapE (\ (ftrs,count,info) -> - let myftrs = Header HdrContentLength (show count) : ftrs - in Right (myftrs,info)) - (chunkedTransferC bufOps readL readBlk 0) +chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0 chunkedTransferC :: BufferOp a -> IO (Result a) -> (Int -> IO (Result a)) + -> [a] -> Int - -> IO (Result ([Header],Int,a)) -chunkedTransferC bufOps readL readBlk n = do + -> IO (Result ([Header], a)) +chunkedTransferC bufOps readL readBlk acc n = do v <- readL case v of Left e -> return (Left e) Right line | size == 0 -> + -- last chunk read; look for trailing headers.. fmapE (\ strs -> do ftrs <- parseHeaders (map (buf_toStr bufOps) strs) - return (ftrs,n,buf_empty bufOps)) + -- insert (computed) Content-Length header. + let ftrs' = Header HdrContentLength (show n) : ftrs + return (ftrs',buf_concat bufOps (reverse acc))) + (readTillEmpty2 bufOps readL []) | otherwise -> do some <- readBlk size - readL - more <- chunkedTransferC bufOps readL readBlk (n+size) - return $ do - cdata <- some - (ftrs,m,mdata) <- more - return (ftrs,m,buf_append bufOps cdata mdata) + case some of + Left e -> return (Left e) + Right cdata -> do + readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.? + chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size) where size | buf_isEmpty bufOps line = 0 diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -1,15 +1,21 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.HandleStream --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- Copyright : (c) 2008- Sigbjorn Finne -- License : BSD -- -- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- --- A HandleStream version of Network.HTTP.Stream's public offerings. +-- A 'HandleStream'-based version of "Network.HTTP" interface. -- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- not perform any kind of normalization prior to transmission (or receipt); you are +-- responsible for doing any such yourself, or, if you prefer, just switch to using +-- "Network.HTTP" function instead. +-- ----------------------------------------------------------------------------- module Network.HTTP.HandleStream ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) @@ -27,13 +33,13 @@ ----------------------------------------------------------------- import Network.BufferType -import Network.Stream ( ConnError(..), fmapE, Result ) +import Network.Stream ( fmapE, Result ) import Network.StreamDebugger ( debugByteStream ) import Network.TCP (HStream(..), HandleStream ) import Network.HTTP.Base import Network.HTTP.Headers -import Network.HTTP.Utils ( trim ) +import Network.HTTP.Utils ( trim, readsOne ) import Data.Char (toLower) import Data.Maybe (fromMaybe) @@ -43,53 +49,43 @@ ------------------ Misc ----------------------------------------- ----------------------------------------------------------------- --- | Simple way to get a resource across a non-persistant connection. --- Headers that may be altered: --- Host Altered only if no Host header is supplied, HTTP\/1.1 --- requires a Host header. --- Connection Where no allowance is made for persistant connections --- the Connection header will be set to "close" +-- | @simpleHTTP@ transmits a resource across a non-persistent connection. 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 debugFile req@ behaves like 'simpleHTTP', but logs +-- the HTTP operation via the debug file @debugFile@. 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)) - c <- debugByteStream httpLogFile c0 + c0 <- openStream (host auth) (fromMaybe 80 (port auth)) + c <- debugByteStream httpLogFile c0 simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) -simpleHTTP_ s r = do - auth <- getAuth r - let r' = normalizeRequestURI True{-do close-} (host auth) r - rsp <- sendHTTP s r' - return rsp +simpleHTTP_ s r = sendHTTP s r +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- closed upon receiving the response. 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 (return ())) - (\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 conn rq = sendHTTP_notify conn rq (return ()) +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do - let a_rq = normalizeHostHeader rq - rsp <- catchIO (sendMain conn a_rq onSendComplete) + rsp <- catchIO (sendMain conn rq onSendComplete) (\e -> do { close conn; ioError e }) let fn list = when (or $ map findConnClose list) (close conn) @@ -98,8 +94,6 @@ rsp return rsp - - -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows -- ambiguous situations in which a client may send "Expect: 100- @@ -188,8 +182,7 @@ 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@ reads a 'Request' from the 'HandleStream' @hStream@ receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy)) receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest where @@ -217,8 +210,9 @@ 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 httpResponse@ transmits an HTTP 'Response' over +-- the 'HandleStream' @hStream@. It could be used to implement simple web +-- 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) @@ -227,12 +221,6 @@ 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) diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs --- a/Network/HTTP/Headers.hs +++ b/Network/HTTP/Headers.hs @@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Headers --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne -- License : BSD -- --- Maintainer : bjorn@bringert.net +-- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- @@ -47,6 +47,7 @@ ( HasHeaders(..) , Header(..) , HeaderName(..) + , mkHeader , insertHeader , insertHeaderIfMissing @@ -66,6 +67,10 @@ -- | The @Header@ data type pairs header names & values. data Header = Header HeaderName String +-- | Header constructor as a function, hiding above rep. +mkHeader :: HeaderName -> String -> Header +mkHeader = Header + instance Show Header where show (Header key value) = shows key (':':' ':value ++ crlf) @@ -118,6 +123,8 @@ | HdrRetryAfter | HdrServer | HdrSetCookie + | HdrTE + | HdrTrailer | HdrVary | HdrWarning | HdrWWWAuthenticate @@ -156,6 +163,8 @@ , p "Accept-Encoding" HdrAcceptEncoding , p "Accept-Language" HdrAcceptLanguage , p "Authorization" HdrAuthorization + , p "Cookie" HdrCookie + , p "Expect" HdrExpect , p "From" HdrFrom , p "Host" HdrHost , p "If-Modified-Since" HdrIfModifiedSince @@ -174,6 +183,9 @@ , p "Public" HdrPublic , p "Retry-After" HdrRetryAfter , p "Server" HdrServer + , p "Set-Cookie" HdrSetCookie + , p "TE" HdrTE + , p "Trailer" HdrTrailer , p "Vary" HdrVary , p "Warning" HdrWarning , p "WWW-Authenticate" HdrWWWAuthenticate @@ -189,9 +201,7 @@ , p "ETag" HdrETag , p "Expires" HdrExpires , p "Last-Modified" HdrLastModified - , p "Set-Cookie" HdrSetCookie - , p "Cookie" HdrCookie - , p "Expect" HdrExpect + , p "Content-Transfer-Encoding" HdrContentTransferEncoding ] where p a b = (a,b) diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs --- a/Network/HTTP/Stream.hs +++ b/Network/HTTP/Stream.hs @@ -1,97 +1,26 @@ ----------------------------------------------------------------------------- -- | --- Module : Network.HTTP +-- Module : Network.HTTP.Stream -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop -- License : BSD -- --- Maintainer : bjorn@bringert.net +-- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- --- An easy HTTP interface enjoy. --- --- * Changes by Robin Bate Boerop : --- - 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: --- --- - 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. --- --- * 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. --- --- * TODO --- - request pipelining --- - https upgrade (includes full TLS, i.e. SSL, implementation) --- - use of Stream classes will pay off --- - consider C implementation of encryption\/decryption --- - comm timeouts --- - MIME & entity stuff (happening in separate module) --- - support \"*\" uri-request-string for OPTIONS request method --- --- --- * 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. --- --- [@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). --- --- --- * Response code notes --- Some response codes induce special behaviour: +-- Transmitting HTTP requests and responses holding @String@ in their payload bodies. +-- This is one of the implementation modules for the "Network.HTTP" interface, representing +-- request and response content as @String@s and transmitting them in non-packed form +-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles. +-- It is mostly here for backwards compatibility, representing how requests and responses +-- were transmitted up until the 4.x releases of the HTTP package. -- --- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. --- \"101 Upgrade\" will be returned. --- Other 1xx responses are ignored. +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- not perform any kind of normalization prior to transmission (or receipt); you are +-- responsible for doing any such yourself, or, if you prefer, just switch to using +-- "Network.HTTP" function instead. -- --- [@417@] The reason for this code is \"Expectation failed\", indicating --- that the server did not like the Expect \"100-continue\" header --- added to a request. Receipt of 417 will induce another --- request attempt (without Expect header), unless no Expect header --- had been added (in which case 417 response is returned). --- ----------------------------------------------------------------------------- module Network.HTTP.Stream ( module Network.Stream @@ -136,59 +65,36 @@ ----------------------------------------------------------------- --- | Simple way to get a resource across a non-persistant connection. --- Headers that may be altered: --- Host Altered only if no Host header is supplied, HTTP\/1.1 --- requires a Host header. --- Connection Where no allowance is made for persistant connections --- the Connection header will be set to "close" +-- | Simple way to transmit a resource across a non-persistent connection. simpleHTTP :: Request_String -> IO (Result Response_String) -simpleHTTP r = - do - auth <- getAuth r - c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) - simpleHTTP_ c r +simpleHTTP r = do + auth <- getAuth r + c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) -simpleHTTP_ s r = - do - auth <- getAuth r - let r' = normalizeRequestURI True{-do close-} (host auth) r - rsp <- if debug then do - s' <- debugStream httpLogFile s - sendHTTP s' r' - else - sendHTTP s r' - -- already done by sendHTTP because of "Connection: close" header - --; close s - return rsp +simpleHTTP_ s r + | not debug = sendHTTP s r + | 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 = - do { let a_rq = normalizeHostHeader rq - ; rsp <- catchIO (sendMain conn a_rq (return ())) - (\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 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 { let a_rq = normalizeHostHeader rq - ; rsp <- catchIO (sendMain conn a_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 + 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 -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows @@ -202,21 +108,21 @@ -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) sendMain conn rqst onSendComplete = do - --let str = if null (rqBody rqst) - -- then show rqst - -- else show (insertHeader HdrExpect "100-continue" rqst) - writeBlock conn (show rqst) - -- write body immediately, don't wait for 100 CONTINUE - writeBlock conn (rqBody rqst) - onSendComplete - rsp <- getResponseHead conn - switchResponse conn True False rsp rqst + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + writeBlock conn (show rqst) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst -- reads and parses headers getResponseHead :: Stream s => s -> IO (Result ResponseData) getResponseHead conn = do - lor <- readTillEmpty1 stringBufferOp (readLine conn) - return $ lor >>= parseResponseHead + lor <- readTillEmpty1 stringBufferOp (readLine conn) + return $ lor >>= parseResponseHead -- Hmmm, this could go bad if we keep getting "100 Continue" -- responses... Except this should never happen according diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs --- a/Network/HTTP/Utils.hs +++ b/Network/HTTP/Utils.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Utils --- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne -- License : BSD -- -- Maintainer : Sigbjorn Finne @@ -11,15 +11,18 @@ -- Set of utility functions and definitions used by package modules. -- module Network.HTTP.Utils - ( trim -- :: String -> String - , trimL -- :: String -> String - , trimR -- :: String -> String + ( trim -- :: String -> String + , trimL -- :: String -> String + , trimR -- :: String -> String - , crlf -- :: String + , crlf -- :: String + , sp -- :: String - , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) - , splitBy -- :: Eq a => a -> [a] -> [[a]] + , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) + , splitBy -- :: Eq a => a -> [a] -> [[a]] + , readsOne -- :: Read a => (a -> b) -> b -> String -> b + ) where import Data.Char @@ -30,6 +33,10 @@ crlf :: String crlf = "\r\n" +-- | @sp@ lets you save typing one character. +sp :: String +sp = " " + -- | @split delim ls@ splits a list into two parts, the @delim@ occurring -- at the head of the second list. If @delim@ isn't in @ls@, @Nothing@ is -- returned. @@ -64,4 +71,13 @@ case break (==c) xs of (_,[]) -> [xs] (as,_:bs) -> as : splitBy c bs + +-- | @readsOne f def str@ tries to 'read' @str@, taking +-- the first result and passing it to @f@. If the 'read' +-- doesn't succeed, return @def@. +readsOne :: Read a => (a -> b) -> b -> String -> b +readsOne f n str = + case reads str of + ((v,_):_) -> f v + _ -> n diff --git a/Network/Stream.hs b/Network/Stream.hs --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop -- License : BSD -- --- Maintainer : bjorn@bringert.net +-- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs --- a/Network/StreamDebugger.hs +++ b/Network/StreamDebugger.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop -- License : BSD -- --- Maintainer : bjorn@bringert.net +-- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop. -- License : BSD -- --- Maintainer : bjorn@bringert.net +-- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -5,7 +5,7 @@ -- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004 -- License : BSD -- --- Maintainer : bjorn@bringert.net +-- Maintainer : Sigbjorn Finne -- Stability : experimental -- Portability : non-portable (not tested) -- @@ -35,6 +35,8 @@ , StreamHooks(..) , nullHooks , setStreamHooks + , hstreamToConnection + ) where import Network.BSD (getHostByName, hostAddresses) @@ -91,6 +93,9 @@ | ConnClosed deriving(Eq) +hstreamToConnection :: HandleStream String -> Connection +hstreamToConnection h = Connection h + connHooks' :: Conn a -> Maybe (StreamHooks a) connHooks' ConnClosed{} = Nothing connHooks' x = connHooks x @@ -109,10 +114,10 @@ nullHooks :: StreamHooks ty nullHooks = StreamHooks - { hook_readLine = \ _ _ -> return () - , hook_readBlock = \ _ _ _ -> return () + { hook_readLine = \ _ _ -> return () + , hook_readBlock = \ _ _ _ -> return () , hook_writeBlock = \ _ _ _ -> return () - , hook_close = return () + , hook_close = return () } setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () @@ -162,10 +167,9 @@ -- (I think the behaviour here is TCP specific) close c = closeIt c null --- | This function establishes a connection to a remote --- host, it uses "getHostByName" which interrogates the --- DNS system, hence may trigger a network connection. --- +-- | @openTCPPort uri port@ establishes a connection to a remote +-- host, using 'getHostByName' which possibly queries the DNS system, hence +-- may trigger a network connection. openTCPPort :: String -> Int -> IO Connection openTCPPort uri port = openTCPConnection uri port >>= return.Connection @@ -173,31 +177,39 @@ -- Use "Result" type for synchronous exception reporting? openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty) openTCPConnection uri port = openTCPConnection_ uri port False + openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) -openTCPConnection_ uri port stashInput = - do { s <- socket AF_INET Stream 6 - ; setSocketOption s KeepAlive 1 - ; host <- catchIO (inet_addr uri) -- handles ascii IP numbers - (\ _ -> getHostByName uri >>= \host -> - case hostAddresses host of - [] -> return (error "no addresses in host entry") - (h:_) -> return h) - ; let a = SockAddrInet (toEnum port) host - ; catchIO (connect s a) (\e -> sClose s >> ioError e) - ; h <- socketToHandle s ReadWriteMode - ; mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing } - ; let conn = - (MkConn { connSock = s - , connHandle = h - , connBuffer = bufferOps - , connInput = mb - , connHost = uri - , connHooks = Nothing - }) - ; v <- newMVar conn - ; return (HandleStream v) - } +openTCPConnection_ uri port stashInput = do + s <- socket AF_INET Stream 6 + setSocketOption s KeepAlive 1 + hostA <- getHostAddr uri + let a = SockAddrInet (toEnum port) hostA + catchIO (connect s a) (\e -> sClose s >> ioError e) + h <- socketToHandle s ReadWriteMode + mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing } + let conn = MkConn + { connSock = s + , connHandle = h + , connBuffer = bufferOps + , connInput = mb + , connHost = uri + , connHooks = Nothing + } + v <- newMVar conn + return (HandleStream v) + where + getHostAddr h = do + catchIO (inet_addr uri) -- handles ascii IP numbers + (\ _ -> do + host <- getHostByName_safe uri + case hostAddresses host of + [] -> fail ("openTCPConnection: no addresses in host entry for " ++ show h) + (ha:_) -> return ha) + getHostByName_safe h = + catchIO (getHostByName h) + (\ _ -> fail ("openTCPConnection: host lookup failure for " ++ show h)) + closeConnection :: HandleStream a -> IO Bool -> IO () closeConnection ref readL = do -- won't hold onto the lock for the duration @@ -245,7 +257,6 @@ | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v) | otherwise -> return False - readBlockBS :: HandleStream a -> Int -> IO (Result a) readBlockBS ref n = onNonClosedDo ref $ \ conn -> do x <- bufferGetBlock ref n @@ -255,7 +266,7 @@ 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) +-- (however many bytes this is is left for the user to decipher) readLineBS :: HandleStream a -> IO (Result a) readLineBS ref = onNonClosedDo ref $ \ conn -> do x <- bufferReadLine ref @@ -328,5 +339,5 @@ x <- readMVar (getRef h) case x of ConnClosed{} -> return (failWith ErrorClosed) - c -> act c - + _ -> act x +