HTTP 4000.0.4 → 4000.0.5

raw patch · 14 files changed

+1163/−675 lines, 14 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES +20/−0
• HTTP.cabal +23/−13
• Network/Browser.hs +415/−299
• Network/BufferType.hs +11/−6
• Network/HTTP.hs +149/−39
• Network/HTTP/Base.hs +383/−87
• Network/HTTP/HandleStream.hs +29/−41
• Network/HTTP/Headers.hs +15/−5
• Network/HTTP/Stream.hs +46/−140
• Network/HTTP/Utils.hs +23/−7
• Network/Stream.hs +1/−1
• Network/StreamDebugger.hs +1/−1
• Network/StreamSocket.hs +1/−1
• Network/TCP.hs +46/−35

@@ -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.+

@@ -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 <warrick.gray@hotmail.com> Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> 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 <git://code.galois.com/HTTPbis.git> +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

@@ -1,91 +1,113 @@--------------------------------------------------------------------------------- |--- Module      :  Network.Browser--- Copyright   :  (c) Warrick Gray 2002--- License     :  BSD--- --- Maintainer  :  Sigbjorn Finne <sigbjorn.finne@gmail.com>--- 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 <robin@bateboerop.name>:-   - Made dependencies explicit in import statements.-   - Added type signatures.-   - Imported new StreamDebugger module.+Maintainer  :  Sigbjorn Finne <sigbjorn.finne@gmail.com>+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==':'))

@@ -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"+

@@ -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 <sigbjorn.finne@gmail.com> -- 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---

@@ -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

@@ -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 <sigbjorn.finne@gmail.com> -- 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)

@@ -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 <sigbjorn.finne@gmail.com> -- 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)

@@ -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 <sigbjorn.finne@gmail.com> -- Stability   :  experimental -- Portability :  non-portable (not tested) ----- An easy HTTP interface enjoy.------ * Changes by Robin Bate Boerop <robin@bateboerop.name>:---      - Made dependencies explicit in import statements.---      - Removed false dependencies in import statements.---      - Added missing type signatures.---      - Moved Header-related code to Network.HTTP.Headers module.------ * Changes by Simon Foster:---      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules---      - Created functions receiveHTTP and responseHTTP to allow server side interactions---        (although 100-continue is unsupported and I haven't checked for standard compliancy).---      - Pulled the transfer functions from sendHTTP to global scope to allow access by---        above functions.------ * Changes by Graham Klyne:---      - export httpVersion---      - use new URI module (similar to old, but uses revised URI datatype)------ * Changes by Bjorn Bringert:------      - 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

@@ -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 <sigbjorn.finne@gmail.com>@@ -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 

@@ -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 <sigbjorn.finne@gmail.com> -- Stability   :  experimental -- Portability :  non-portable (not tested) --

@@ -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 <sigbjorn.finne@gmail.com> -- Stability   :  experimental -- Portability :  non-portable (not tested) --

@@ -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 <sigbjorn.finne@gmail.com> -- Stability   :  experimental -- Portability :  non-portable (not tested) --

@@ -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 <sigbjorn.finne@gmail.com> -- 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+