----------------------------------------------------------------------------- -- | -- Module : Network.Browser -- Copyright : (c) Warrick Gray 2002 -- License : BSD -- -- Maintainer : bjorn@bringert.net -- Stability : experimental -- Portability : non-portable (not tested) -- -- An HTTP\/1.1 compatible wrapper for the HTTP module. ----------------------------------------------------------------------------- {- Changes by Robin Bate Boerop : - Made dependencies explicit in import statements. - Added type signatures. - Imported new StreamDebugger module. Change Log: - altered 'closeTCP' to 'close', for consistency with altered HTTP - added debugging settings to browser. To Do: - testing!!! - remove BrowserAction type? Possibly replace with IORef? - (more todo's in the HTTP mod) -} module Network.Browser ( BrowserState, BrowserAction, -- browser monad, effectively a state monad. Cookie, Form(..), Proxy(..), browse, -- BrowserAction a -> IO a request, -- Request -> BrowserAction Response setAllowRedirects, getAllowRedirects, Authority(..), getAuthorities, setAuthorities, addAuthority, getAuthorityGen, setAuthorityGen, setAllowBasicAuth, setCookieFilter, defaultCookieFilter, userCookieFilter, getCookies, setCookies, addCookie, setErrHandler, setOutHandler, setProxy, setDebugLog, out, err, ioAction, -- :: IO a -> BrowserAction a defaultGETRequest, formToRequest, uriDefaultTo, uriTrimHost ) where import Network.URI ( URI(uriAuthority, uriScheme, uriPath, uriQuery) , URIAuth(..) , parseURI, parseURIReference, relativeTo ) import Network.StreamDebugger (debugByteStream) import Network.HTTP import qualified Network.HTTP.MD5 as MD5 (hash) import qualified Network.HTTP.Base64 as Base64 (encode) import Network.Stream ( ConnError(..) ) import Network.BufferType import Network.HTTP.Utils ( trim, splitBy ) 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 Text.ParserCombinators.Parsec ( Parser, char, many, many1, satisfy, parse, option, try , (<|>), spaces, sepBy1 ) import qualified System.IO ( hSetBuffering, hPutStr, stdout, stdin, hGetChar , BufferMode(NoBuffering, LineBuffering) ) import Data.Word (Word8) import Debug.Trace 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 = case a `relativeTo` b of Nothing -> a Just x -> x uriTrimHost :: URI -> URI uriTrimHost uri = uri { uriScheme="", uriAuthority=Nothing } ------------------------------------------------------------------ ----------------------- Cookie Stuff ----------------------------- ------------------------------------------------------------------ -- Some conventions: -- assume ckDomain is lowercase -- data Cookie = MkCookie { ckDomain , ckName , ckValue :: String , ckPath , ckComment , ckVersion :: Maybe String } deriving(Show,Read) instance Eq Cookie where a == b = ckDomain a == ckDomain b && ckName a == ckName b && ckPath a == ckPath b defaultCookieFilter :: URI -> Cookie -> IO Bool defaultCookieFilter _url _cky = return True userCookieFilter :: URI -> Cookie -> IO Bool userCookieFilter url cky = do putStrLn ("Set-Cookie received when requesting: " ++ show url) case ckComment cky of Nothing -> return () Just x -> putStrLn ("Cookie Comment:\n" ++ x) putStrLn ("Domain/Path: " ++ ckDomain cky ++ case ckPath cky of Nothing -> "" Just x -> "/" ++ x) putStrLn (ckName cky ++ '=' : ckValue cky) System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering System.IO.hPutStr System.IO.stdout "Accept [y/n]? " x <- System.IO.hGetChar System.IO.stdin System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering return (toLower x == 'y') -- | Serialise a Cookie for inclusion in a request. cookieToHeader :: Cookie -> Header cookieToHeader ck = Header HdrCookie text where text = "$Version=" ++ fromMaybe "0" (ckVersion ck) ++ ';' : ckName ck ++ "=" ++ ckValue ck ++ (case ckPath ck of Nothing -> "" Just x -> ";$Path=" ++ x) ++ ";$Domain=" ++ ckDomain ck {- replace "error" call with [] in final version? -} headerToCookies :: String -> Header -> [Cookie] headerToCookies dom (Header HdrSetCookie val) = case parse cookies "" val of Left e -> error ("Cookie parse failure on: " ++ val ++ " " ++ show e) Right x -> x where cookies :: Parser [Cookie] cookies = sepBy1 cookie (char ',') cookie :: Parser Cookie cookie = do { name <- word ; spaces_l ; char '=' ; spaces_l ; val1 <- cvalue ; args <- cdetail ; return $ mkCookie name val1 args } cvalue :: Parser String spaces_l = many (satisfy isSpace) cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return "" -- all keys in the result list MUST be in lower case cdetail :: Parser [(String,String)] cdetail = many $ try (do { spaces_l ; char ';' ; spaces_l ; s1 <- word ; spaces_l ; s2 <- option "" (do { char '=' ; spaces_l ; v <- cvalue ; return v }) ; return (map toLower s1,s2) }) mkCookie :: String -> String -> [(String,String)] -> Cookie mkCookie nm cval more = MkCookie { ckName = nm , ckValue = cval , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) , ckPath = lookup "path" more , ckVersion = lookup "version" more , ckComment = lookup "comment" more } headerToCookies _ _ = [] -- | 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 :: [Cookie] -> BrowserAction t () setCookies cs = alterBS (\b -> b { bsCookies=cs }) getCookies :: BrowserAction t [Cookie] getCookies = getBS bsCookies -- ...get domain specific cookies... -- ... this needs changing for consistency with rfc2109... -- ... currently too broad. getCookiesFor :: String -> String -> BrowserAction t [Cookie] getCookiesFor dom path = do cks <- getCookies return (filter cookiematch cks) where cookiematch :: Cookie -> Bool cookiematch ck = ckDomain ck `isSuffixOf` dom && case ckPath ck of Nothing -> True Just p -> p `isPrefixOf` path setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f }) getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) getCookieFilter = getBS bsCookieFilter ------------------------------------------------------------------ ----------------------- Authorisation Stuff ---------------------- ------------------------------------------------------------------ {- The browser handles 401 responses in the following manner: 1) extract all WWW-Authenticate headers from a 401 response 2) rewrite each as a Challenge object, using "headerToChallenge" 3) pick a challenge to respond to, usually the strongest challenge understood by the client, using "pickChallenge" 4) generate a username/password combination using the browsers "bsAuthorityGen" function (the default behaviour is to ask the user) 5) build an Authority object based upon the challenge and user data, store this new Authority in the browser state 6) convert the Authority to a request header and add this to a request using "withAuthority" 7) send the amended request Note that by default requests are annotated with authority headers before the first sending, based upon previously generated Authority objects (which contain domain information). Once a specific authority is added to a rejected request this predictive annotation is suppressed. 407 responses are handled in a similar manner, except a) Authorities are not collected, only a single proxy authority is kept by the browser b) If the proxy used by the browser (type Proxy) is NoProxy, then a 407 response will generate output on the "err" stream and the response will be returned. Notes: - digest authentication so far ignores qop, so fails to authenticate properly with qop=auth-int challenges - calculates a1 more than necessary - doesn't reverse authenticate - doesn't properly receive AuthenticationInfo headers, so fails to use next-nonce etc -} data Algorithm = AlgMD5 | AlgMD5sess deriving(Eq) instance Show Algorithm where 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] } -- | Convert WWW-Authenticate header into a Challenge object headerToChallenge :: URI -> Header -> Maybe Challenge headerToChallenge baseURI (Header _ str) = case parse challenge "" str of Left{} -> Nothing Right (name,props) -> case name of "basic" -> mkBasic props "digest" -> mkDigest props _ -> Nothing where challenge :: Parser (String,[(String,String)]) challenge = do { nme <- word ; spaces ; pps <- cprops ; return (map toLower nme,pps) } cprops = sepBy1 cprop comma comma = do { spaces ; char ',' ; spaces } cprop = do { nm <- word ; char '=' ; val <- quotedstring ; return (map toLower nm,val) } mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge mkBasic params = fmap ChalBasic (lookup "realm" params) mkDigest params = -- with Maybe monad do { r <- lookup "realm" params ; n <- lookup "nonce" params ; return $ ChalDigest { chRealm = r , chDomain = (annotateURIs $ map parseURI $ words $ fromMaybe [] $ lookup "domain" params) , chNonce = n , chOpaque = lookup "opaque" params , chStale = "true" == (map toLower $ fromMaybe "" (lookup "stale" params)) , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params) , chQop = readQop (fromMaybe "" $ lookup "qop" params) } } annotateURIs :: [Maybe URI] -> [URI] annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes -- Change These: readQop :: String -> [Qop] readQop = catMaybes . (map strToQop) . (splitBy ',') strToQop qs = case map toLower (trim qs) of "auth" -> Just QopAuth "auth-int" -> Just QopAuthInt _ -> Nothing readAlgorithm astr = case map toLower (trim astr) of "md5" -> Just AlgMD5 "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] } -- | 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) matchURI :: URI -> Bool matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) -- | Interacting with browser state: getAuthorities :: BrowserAction t [Authority] getAuthorities = getBS bsAuthorities setAuthorities :: [Authority] -> BrowserAction t () setAuthorities as = alterBS (\b -> b { bsAuthorities=as }) addAuthority :: Authority -> BrowserAction t () addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b }) getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) getAuthorityGen = getBS bsAuthorityGen setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f }) setAllowBasicAuth :: Bool -> BrowserAction t () setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba }) -- TO BE CHANGED!!! pickChallenge :: [Challenge] -> Maybe Challenge pickChallenge = listToMaybe -- | Retrieve a likely looking authority for a Request. anticipateChallenge :: HTTPRequest ty -> BrowserAction t (Maybe Authority) anticipateChallenge rq = let uri = rqURI rq in do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri) ; return (listToMaybe authlist) } -- | Asking the user to respond to a challenge challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) challengeToAuthority uri ch = -- prompt user for authority if answerable ch then do { prompt <- getAuthorityGen ; userdetails <- ioAction $ prompt uri (chRealm ch) ; case userdetails of Nothing -> return Nothing Just (u,p) -> return (Just $ buildAuth ch u p) } else return Nothing where answerable :: Challenge -> Bool answerable (ChalBasic _) = True answerable chall = (chAlgorithm chall) == Just AlgMD5 buildAuth :: Challenge -> String -> String -> Authority buildAuth (ChalBasic r) u p = AuthBasic { auSite=uri , auRealm=r , auUsername=u , auPassword=p } -- note to self: this is a pretty stupid operation -- to perform isn't it? ChalX and AuthX are so very -- similar. buildAuth (ChalDigest r d n o _stale a q) u p = AuthDigest { auRealm=r , auUsername=u , auPassword=p , auDomain=d , auNonce=n , auOpaque=o , auAlgorithm=a , auQop=q } -- | Generating a credentials value from an Authority, in -- the context of a specific request. If a client nonce -- was to be used then this function might need to -- be of type ... -> BrowserAction String withAuthority :: Authority -> HTTPRequest ty -> String withAuthority a rq = case a of AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) AuthDigest{} -> "Digest username=\"" ++ auUsername a -- " ++ "\",realm=\"" ++ auRealm a ++ "\",nonce=\"" ++ auNonce a ++ "\",uri=\"" ++ digesturi ++ ",response=\"" ++ rspdigest ++ "\"" -- plus optional stuff: ++ ( if isJust (auAlgorithm a) then "" else ",algorithm=\"" ++ show (fromJust $ auAlgorithm a) ++ "\"" ) ++ ( if isJust (auOpaque a) then "" else ",opaque=\"" ++ (fromJust $ auOpaque a) ++ "\"" ) ++ ( if null (auQop a) then "" else ",qop=auth" ) where rspdigest = "\"" ++ map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) ++ "\"" a1, a2 :: String a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a {- If the "qop" directive's value is "auth" or is unspecified, then A2 is: A2 = Method ":" digest-uri-value If the "qop" value is "auth-int", then A2 is: A2 = Method ":" digest-uri-value ":" H(entity-body) -} a2 = show (rqMethod rq) ++ ":" ++ digesturi digesturi = show (rqURI rq) noncevalue = auNonce a -- FIXME: these probably only work right for latin-1 strings stringToOctets :: String -> [Octet] stringToOctets = map (fromIntegral . fromEnum) octetsToString :: [Octet] -> String octetsToString = map (toEnum . fromIntegral) base64encode :: String -> String base64encode = Base64.encode . stringToOctets md5 :: String -> String md5 = octetsToString . MD5.hash . stringToOctets kd :: String -> String -> String kd a b = md5 (a ++ ":" ++ b) ------------------------------------------------------------------ ------------------ 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" ------------------------------------------------------------------ ------------------ Browser State Actions ------------------------- ------------------------------------------------------------------ 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 } instance Show (BrowserState t) where show bs = "BrowserState { " ++ shows (bsCookies bs) ("\n" {- ++ show (bsAuthorities bs) ++ "\n"-} ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") -- Simple DIY stateful behaviour, with IO 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)) instance Functor (BrowserAction conn) where fmap f = liftM f -- | Apply a browser action to a state. browse :: BrowserAction conn a -> IO a browse act = do x <- lift act defaultBrowserState return (snd x) defaultBrowserState :: BrowserState t defaultBrowserState = BS { bsErr = putStrLn , bsOut = putStrLn , bsCookies = [] , bsCookieFilter = defaultCookieFilter , bsAuthorityGen = (error "bsAuthGen wanted") , bsAuthorities = [] , bsAllowRedirects = True , bsAllowBasicAuth = False , bsConnectionPool = [] , bsProxy = NoProxy , bsDebug = Nothing } -- | Alter browser state alterBS :: (BrowserState t -> BrowserState t) -> BrowserAction t () alterBS f = BA (\b -> return (f b,())) getBS :: (BrowserState t -> a) -> BrowserAction t a getBS f = BA (\b -> return (b,f b)) -- | Do an io action ioAction :: IO a -> BrowserAction t a ioAction a = BA (\b -> a >>= \v -> return (b,v)) -- Stream handlers setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction t () setErrHandler h = alterBS (\b -> b { bsErr=h }) 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 :: Bool -> BrowserAction t () setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl}) getAllowRedirects :: BrowserAction t Bool getAllowRedirects = getBS bsAllowRedirects -- Proxy setProxy :: Proxy -> BrowserAction t () setProxy p = alterBS (\b -> b {bsProxy = p}) getProxy :: BrowserAction t Proxy getProxy = getBS bsProxy -- Debug setDebugLog :: Maybe String -> BrowserAction t () setDebugLog v = alterBS (\b -> b {bsDebug=v}) -- Page control 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 , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response } nullRequestState :: RequestState nullRequestState = RequestState { reqDenies = 0 , reqRedirects = 0 , reqRetries = 0 , reqStopOnDeny = True } -- limits we are willing to not go beyond for method retries and number of auth deny responses. maxRetries :: Int maxRetries = 4 maxDenies :: Int maxDenies = 2 -- Surely the most important bit: request :: HStream ty => HTTPRequest ty -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty) request req = request' nullVal initialState req where initialState = nullRequestState nullVal = buf_empty bufferOps request' :: HStream ty => ty -> RequestState -> HTTPRequest ty -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty) request' nullVal rqState rq = do -- add cookies to request let uri = rqURI rq cookies <- getCookiesFor (uriAuthToString $ reqURIAuth rq) (uriPath uri) when (not $ null cookies) (out $ "Adding cookies to request. Cookie names: " ++ foldl spaceappend "" (map ckName cookies)) -- add credentials to request rq' <- if not (reqStopOnDeny rqState) then return rq else do auth <- anticipateChallenge rq case auth of Nothing -> return rq Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) let rq'' = insertHeaders (map cookieToHeader cookies) rq' p <- getProxy out ("Sending:\n" ++ show rq'') e_rsp <- case p of NoProxy -> dorequest (reqURIAuth rq'') rq'' Proxy str ath -> do let rq''' = maybe rq'' (\x -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq'') ath let notURI | null pt || null hst = URIAuth{ uriUserInfo = "" , uriRegName = str , uriPort = "" } | otherwise = URIAuth{ uriUserInfo = "" , uriRegName = hst , uriPort = pt } -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! where (hst, pt) = span (':'/=) str -- Proxy can take multiple forms - look for http://host:port first, -- then host:port. Fall back to just the string given (probably a host name). let proxyURIAuth = maybe notURI (\parsed -> maybe notURI id (uriAuthority parsed)) (parseURI str) out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth dorequest proxyURIAuth rq''' 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) Right rsp -> do out ("Received:\n" ++ show rsp) -- add new cookies to browser state let cookieheaders = retrieveHeaders HdrSetCookie rsp let newcookies = concat (map (headerToCookies $ uriAuthToString $ reqURIAuth rq) cookieheaders) when (not $ null newcookies) (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newcookies) filterfn <- getCookieFilter newcookies' <- ioAction (filterM (filterfn uri) newcookies) foldM (\_ -> addCookie) () newcookies' when (not $ null newcookies) (out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies')) case rspCode rsp of (4,0,1) -- Credentials not sent or refused. | reqDenies rqState > maxDenies -> do out "401 - credentials again refused; exceeded retry count (2)" return (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 -} Just x -> do au <- challengeToAuthority uri x case au of Nothing -> return (uri,rsp) {- do nothing -} Just au' -> do out "Retrying request with new credentials" request' nullVal rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False} (insertHeader HdrAuthorization (withAuthority au' rq) rq) (4,0,7) -- Proxy Authentication required | reqDenies rqState > maxDenies -> do out "407 - proxy authentication required; max deny count exceeeded (2)" return (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 -} Just x -> do au <- challengeToAuthority uri x case au of Nothing -> return (uri,rsp) {- do nothing -} Just au' -> do pxy <- getBS bsProxy case pxy of NoProxy -> do err "Proxy authentication required without proxy!" return (uri,rsp) Proxy px _ -> do out "Retrying with proxy authentication" setProxy (Proxy px (Just au')) request' nullVal rqState{reqDenies=reqDenies rqState + 1, 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) else case retrieveHeaders HdrLocation rsp of [] -> do err "No Location header in redirect response" return (uri,rsp) (Header _ u:_) -> case parseURIReference u of Nothing -> do err ("Parse of Location header in a redirect response failed: " ++ u) return (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} (replaceHeader HdrContentLength "0" rq1) where newuri' = maybe newuri id (newuri `relativeTo` uri) (3,0,5) -> case retrieveHeaders HdrLocation rsp of [] -> do err "No Location header in proxy redirect response." return (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) 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 } rq (3,_,_) -> redirect uri rsp _ -> return (uri,rsp) where redirect uri rsp = do rd <- getAllowRedirects if not rd || reqRedirects rqState > maxRetries then return (uri,rsp) else do case retrieveHeaders HdrLocation rsp of [] -> do err "No Location header in redirect response." return (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} rq{rqURI=newuri'} Nothing -> do err ("Parse of Location header in a redirect response failed: " ++ u) return (uri,rsp) spaceappend :: String -> String -> String spaceappend x y = x ++ ' ' : y dorequest :: (HStream ty) => URIAuth -> HTTPRequest ty -> BrowserAction (HandleStream ty) (Either ConnError (HTTPResponse ty)) dorequest hst rqst = do { pool <- getBS bsConnectionPool ; conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool ; rsp <- case conn of [] -> do { out ("Creating new connection to " ++ uriAuthToString hst) ; let aport = case uriPort hst of (':':s) -> read s _ -> 80 ; c <- ioAction $ openStream (uriRegName hst) aport ; let pool' = if length pool > 5 then init pool else pool ; when (length pool > 5) (ioAction $ close (last pool)) ; alterBS (\b -> b { bsConnectionPool=c:pool' }) ; dorequest2 c rqst } (c:_) -> do { out ("Recovering connection to " ++ uriAuthToString hst) ; dorequest2 c rqst } ; ; return rsp } where dorequest2 c r = do dbg <- getBS bsDebug ioAction $ case dbg of Nothing -> sendHTTP c r Just f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c sendHTTP c' r reqURIAuth :: HTTPRequest 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 = "haskell-libwww/0.1" defaultGETRequest :: URI -> Request defaultGETRequest uri = Request { rqURI=uri , rqBody="" , rqHeaders=[ Header HdrContentLength "0" , Header HdrUserAgent libUA ] , rqMethod=GET } -- This form junk is completely untested... type FormVar = (String,String) data Form = Form RequestMethod URI [FormVar] formToRequest :: Form -> Request formToRequest (Form m u vs) = let enc = urlEncodeVars vs in case m of GET -> Request { rqMethod=GET , rqHeaders=[ Header HdrContentLength "0" ] , rqBody="" , rqURI=u { uriQuery= '?' : enc } -- What about old query? } POST -> Request { rqMethod=POST , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded", Header HdrContentLength (show $ length enc) ] , rqBody=enc , rqURI=u } _ -> error ("unexpected request: " ++ show m)