{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-}{- | Module : Network.Browser Copyright : See LICENSE file License : BSD Maintainer : Ganesh Sittampalam <ganesh@earth.li> Stability : experimental Portability : non-portable (not tested) 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: * HTTP Authentication handling * Transparent handling of redirects * Cookie stores + transmission. * Transaction logging * Proxy-mediated connections. Example use: > do > (_, rsp) > <- Network.Browser.browse $ do > setAllowRedirects True -- handle HTTP redirects > request $ getRequest "http://www.haskell.org/" > return (take 100 (rspBody rsp)) -}moduleNetwork.Browser(BrowserState ,BrowserAction -- browser monad, effectively a state monad.,Proxy (..),browse -- :: BrowserAction a -> IO a,request -- :: Request -> BrowserAction Response,getBrowserState -- :: BrowserAction t (BrowserState t),withBrowserState -- :: BrowserState t -> BrowserAction t a -> BrowserAction t a,setAllowRedirects -- :: Bool -> BrowserAction t (),getAllowRedirects -- :: BrowserAction t Bool,setMaxRedirects -- :: Int -> BrowserAction t (),getMaxRedirects -- :: BrowserAction t (Maybe Int),Authority (..),getAuthorities ,setAuthorities ,addAuthority ,Challenge (..),Qop (..),Algorithm (..),getAuthorityGen ,setAuthorityGen ,setAllowBasicAuth ,getAllowBasicAuth ,setMaxErrorRetries -- :: Maybe Int -> BrowserAction t (),getMaxErrorRetries -- :: BrowserAction t (Maybe Int),setMaxPoolSize -- :: Int -> BrowserAction t (),getMaxPoolSize -- :: BrowserAction t (Maybe Int),setMaxAuthAttempts -- :: Maybe Int -> BrowserAction t (),getMaxAuthAttempts -- :: BrowserAction t (Maybe Int),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 -> BrowserAction t ()) -> BrowserAction t (),BrowserEvent (..),BrowserEventType (..),RequestID ,setProxy -- :: Proxy -> BrowserAction t (),getProxy -- :: BrowserAction t Proxy,setCheckForProxy -- :: Bool -> BrowserAction t (),getCheckForProxy -- :: BrowserAction t Bool,setDebugLog -- :: Maybe String -> BrowserAction t (),getUserAgent -- :: BrowserAction t String,setUserAgent -- :: String -> BrowserAction t (),out -- :: String -> BrowserAction t (),err -- :: String -> BrowserAction t (),ioAction -- :: IO a -> BrowserAction a,defaultGETRequest ,defaultGETRequest_ ,formToRequest ,uriDefaultTo -- old and half-baked; don't use:,Form (..),FormVar )whereimportNetwork.URI(URI(..),URIAuth(..),parseURI,parseURIReference,relativeTo)importNetwork.StreamDebugger (debugByteStream )importNetwork.HTTP hiding(sendHTTP_notify )importNetwork.HTTP.HandleStream (sendHTTP_notify )importNetwork.HTTP.Auth importNetwork.HTTP.Cookie importNetwork.HTTP.Proxy importNetwork.Stream (ConnError (..),Result )importNetwork.BufferType #if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,13,0)) importControl.Monad.Fail#endif importData.Char(toLower)importData.List(isPrefixOf)importData.Maybe(fromMaybe,listToMaybe,catMaybes)importControl.Applicative(Applicative(..),(<$>))#ifdef MTL1 importControl.Monad(filterM,forM_,when,ap)#else importControl.Monad(filterM,forM_,when)#endif importControl.Monad.State(StateT(..),MonadIO(..),modify,gets,withStateT,evalStateT,MonadState(..))importqualifiedSystem.IO(hSetBuffering,hPutStr,stdout,stdin,hGetChar,BufferMode(NoBuffering,LineBuffering))importData.Time.Clock(UTCTime,getCurrentTime)----------------------------------------------------------------------------------------- Cookie Stuff ------------------------------------------------------------------------------------------------- | @defaultCookieFilter@ is the initial cookie acceptance filter.-- It welcomes them all into the store @:-)@defaultCookieFilter::URI->Cookie ->IOBooldefaultCookieFilter _url _cky =returnTrue-- | @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 ->IOBooluserCookieFilter url cky =dodoputStrLn("Set-Cookie received when requesting: "++showurl )caseckCommentcky ofNothing->return()Justx ->putStrLn("Cookie Comment:\n"++x )letpth =maybe""('/':)(ckPathcky )putStrLn("Domain/Path: "++ckDomaincky ++pth )putStrLn(ckNamecky ++'=':ckValuecky )System.IO.hSetBufferingSystem.IO.stdoutSystem.IO.NoBufferingSystem.IO.hSetBufferingSystem.IO.stdinSystem.IO.NoBufferingSystem.IO.hPutStrSystem.IO.stdout"Accept [y/n]? "x <-System.IO.hGetCharSystem.IO.stdinSystem.IO.hSetBufferingSystem.IO.stdinSystem.IO.LineBufferingSystem.IO.hSetBufferingSystem.IO.stdoutSystem.IO.LineBufferingreturn(toLowerx =='y')-- | @addCookie c@ adds a cookie to the browser state, removing duplicates.addCookie::Cookie ->BrowserAction t ()addCookie c =modify(\b ->b {bsCookies=c :filter(/=c )(bsCookiesb )})-- | @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 =modify(\b ->b {bsCookies=cs })-- | @getCookies@ returns the current set of cookies known to-- the browser.getCookies::BrowserAction t [Cookie ]getCookies =getsbsCookies-- ...get domain specific cookies...-- ... this needs changing for consistency with rfc2109...-- ... currently too broad.getCookiesFor::String->String->BrowserAction t [Cookie ]getCookiesFor dom path =docks <-getCookies return(filtercookiematch cks )wherecookiematch::Cookie ->Boolcookiematch =cookieMatch (dom ,path )-- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@.setCookieFilter::(URI->Cookie ->IOBool)->BrowserAction t ()setCookieFilter f =modify(\b ->b {bsCookieFilter=f })-- | @getCookieFilter@ returns the current cookie acceptance filter.getCookieFilter::BrowserAction t (URI->Cookie ->IOBool)getCookieFilter =getsbsCookieFilter----------------------------------------------------------------------------------------- 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 -}-- | Return authorities for a given domain and path.-- Assumes "dom" is lower casegetAuthFor::String->String->BrowserAction t [Authority ]getAuthFor dom pth =getAuthorities >>=return.(filtermatch )wherematch::Authority ->Boolmatch au @AuthBasic {}=matchURI (auSiteau )matchau @AuthDigest {}=or(mapmatchURI (auDomainau ))matchURI::URI->BoolmatchURI s =(uriToAuthorityString s ==dom )&&(uriPaths `isPrefixOf`pth )-- | @getAuthorities@ return the current set of @Authority@s known-- to the browser.getAuthorities::BrowserAction t [Authority ]getAuthorities =getsbsAuthorities-- @setAuthorities as@ replaces the Browser's known set-- of 'Authority's to @as@.setAuthorities::[Authority ]->BrowserAction t ()setAuthorities as=modify(\b ->b {bsAuthorities=as})-- @addAuthority a@ adds 'Authority' @a@ to the Browser's-- set of known authorities.addAuthority::Authority ->BrowserAction t ()addAuthority a =modify(\b ->b {bsAuthorities=a :bsAuthoritiesb })-- | @getAuthorityGen@ returns the current authority generatorgetAuthorityGen::BrowserAction t (URI->String->IO(Maybe(String,String)))getAuthorityGen =getsbsAuthorityGen-- | @setAuthorityGen genAct@ sets the auth generator to @genAct@.setAuthorityGen::(URI->String->IO(Maybe(String,String)))->BrowserAction t ()setAuthorityGen f =modify(\b ->b {bsAuthorityGen=f })-- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication.setAllowBasicAuth::Bool->BrowserAction t ()setAllowBasicAuth ba =modify(\b ->b {bsAllowBasicAuth=ba })getAllowBasicAuth::BrowserAction t BoolgetAllowBasicAuth =getsbsAllowBasicAuth-- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts-- to do. If @Nothing@, rever to default max.setMaxAuthAttempts::MaybeInt->BrowserAction t ()setMaxAuthAttempts mb |fromMaybe0mb <0=return()|otherwise=modify(\b ->b {bsMaxAuthAttempts=mb })-- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@,-- the browser's default is used.getMaxAuthAttempts::BrowserAction t (MaybeInt)getMaxAuthAttempts =getsbsMaxAuthAttempts-- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at-- transmitting a request. If @Nothing@, rever to default max.setMaxErrorRetries::MaybeInt->BrowserAction t ()setMaxErrorRetries mb |fromMaybe0mb <0=return()|otherwise=modify(\b ->b {bsMaxErrorRetries=mb })-- | @getMaxErrorRetries@ returns the current max number of error retries.getMaxErrorRetries::BrowserAction t (MaybeInt)getMaxErrorRetries =getsbsMaxErrorRetries-- TO BE CHANGED!!!pickChallenge::Bool->[Challenge ]->MaybeChallenge pickChallenge allowBasic []|allowBasic =Just(ChalBasic "/")-- manufacture a challenge if one missing; more robust.pickChallenge_ls =listToMaybels -- | Retrieve a likely looking authority for a Request.anticipateChallenge::Request ty ->BrowserAction t (MaybeAuthority )anticipateChallenge rq =leturi =rqURIrq indo{authlist <-getAuthFor (uriAuthToString $reqURIAuth rq )(uriPathuri );return(listToMaybeauthlist )}-- | Asking the user to respond to a challengechallengeToAuthority::URI->Challenge ->BrowserAction t (MaybeAuthority )challengeToAuthority uri ch |not(answerable ch )=returnNothing|otherwise=do-- prompt user for authorityprompt <-getAuthorityGen userdetails <-liftIO$prompt uri (chRealmch )caseuserdetails ofNothing->returnNothingJust(u ,p )->return(Just$buildAuth ch u p )whereanswerable::Challenge ->Boolanswerable ChalBasic {}=Trueanswerablechall =(chAlgorithmchall )==JustAlgMD5 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 }------------------------------------------------------------------------------------ Browser State Actions --------------------------------------------------------------------------------------------- | @BrowserState@ is the (large) record type tracking the current-- settings of the browser.dataBrowserState connection =BS {bsErr ,bsOut ::String->IO(),bsCookies ::[Cookie ],bsCookieFilter ::URI->Cookie ->IOBool,bsAuthorityGen ::URI->String->IO(Maybe(String,String)),bsAuthorities ::[Authority ],bsAllowRedirects ::Bool,bsAllowBasicAuth ::Bool,bsMaxRedirects ::MaybeInt,bsMaxErrorRetries ::MaybeInt,bsMaxAuthAttempts ::MaybeInt,bsMaxPoolSize ::MaybeInt,bsConnectionPool ::[connection ],bsCheckProxy ::Bool,bsProxy ::Proxy ,bsDebug ::MaybeString,bsEvent ::Maybe(BrowserEvent ->BrowserAction connection ()),bsRequestID ::RequestID ,bsUserAgent ::MaybeString}instanceShow(BrowserState t )whereshow bs ="BrowserState { "++shows(bsCookiesbs )("\n"{- ++ show (bsAuthorities bs) ++ "\n"-}++"AllowRedirects: "++shows(bsAllowRedirectsbs )"} ")-- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'.newtypeBrowserAction conn a =BA {unBA ::StateT(BrowserState conn )IOa }#ifdef MTL1 deriving(Functor,Monad,MonadIO,MonadState(BrowserStateconn))instanceApplicative(BrowserActionconn)wherepure=return(<*>)=ap#else deriving(Functor,Applicative,Monad,MonadIO,MonadState(BrowserState conn )#if MIN_VERSION_base(4,9,0) ,MonadFail#endif )#endif runBA::BrowserState conn ->BrowserAction conn a ->IOa runBA bs =flipevalStateTbs .unBA-- | @browse act@ is the toplevel action to perform a 'BrowserAction'.-- Example use: @browse (request (getRequest yourURL))@.browse::BrowserAction conn a ->IOa browse =runBA defaultBrowserState -- | The default browser state has the settings defaultBrowserState::BrowserState t defaultBrowserState =res whereres =BS {bsErr=putStrLn,bsOut=putStrLn,bsCookies=[],bsCookieFilter=defaultCookieFilter ,bsAuthorityGen=\_uri _realm ->dobsErrres "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing"returnNothing,bsAuthorities=[],bsAllowRedirects=True,bsAllowBasicAuth=False,bsMaxRedirects=Nothing,bsMaxErrorRetries=Nothing,bsMaxAuthAttempts=Nothing,bsMaxPoolSize=Nothing,bsConnectionPool=[],bsCheckProxy=defaultAutoProxyDetect ,bsProxy=noProxy ,bsDebug=Nothing,bsEvent=Nothing,bsRequestID=0,bsUserAgent=Nothing}{-# DEPRECATEDgetBrowserState"Use Control.Monad.State.get instead."#-}-- | @getBrowserState@ returns the current browser config. Useful-- for restoring state across 'BrowserAction's.getBrowserState::BrowserAction t (BrowserState t )getBrowserState =get-- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@.withBrowserState::BrowserState t ->BrowserAction t a ->BrowserAction t a withBrowserState bs =BA .withStateT(constbs ).unBA-- | @nextRequest act@ performs the browser action @act@ as-- the next request, i.e., setting up a new request context-- before doing so.nextRequest::BrowserAction t a ->BrowserAction t a nextRequest act =doletupdReqID st =letrid =succ(bsRequestIDst )inrid `seq`st {bsRequestID=rid }modifyupdReqID act -- | Lifts an IO action into the 'BrowserAction' monad.{-# DEPRECATEDioAction"Use Control.Monad.Trans.liftIO instead."#-}ioAction::IOa ->BrowserAction t a ioAction =liftIO-- | @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 =modify(\b ->b {bsErr=h })-- | @setOutHandler@ 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 =modify(\b ->b {bsOut=h })out,err::String->BrowserAction t ()out s =do{f <-getsbsOut;liftIO$f s }err s =do{f <-getsbsErr;liftIO$f s }-- | @setAllowRedirects onOff@ toggles the willingness to-- follow redirects (HTTP responses with 3xx status codes).setAllowRedirects::Bool->BrowserAction t ()setAllowRedirects bl =modify(\b ->b {bsAllowRedirects=bl })-- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag.getAllowRedirects::BrowserAction t BoolgetAllowRedirects =getsbsAllowRedirects-- | @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::MaybeInt->BrowserAction t ()setMaxRedirects c |fromMaybe0c <0=return()|otherwise=modify(\b ->b {bsMaxRedirects=c })-- | @getMaxRedirects@ returns the current setting for the max-redirect count.-- If @Nothing@, the "Network.Browser"'s default is used.getMaxRedirects::BrowserAction t (MaybeInt)getMaxRedirects =getsbsMaxRedirects-- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool-- that is used to cache connections between requestssetMaxPoolSize::MaybeInt->BrowserAction t ()setMaxPoolSize c =modify(\b ->b {bsMaxPoolSize=c })-- | @getMaxPoolSize@ gets the maximum size of the connection pool-- that is used to cache connections between requests.-- If @Nothing@, the "Network.Browser"'s default is used.getMaxPoolSize::BrowserAction t (MaybeInt)getMaxPoolSize =getsbsMaxPoolSize-- | @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 =-- Note: if user _explicitly_ sets the proxy, we turn-- off any auto-detection of proxies.modify(\b ->b {bsProxy=p ,bsCheckProxy=False})-- | @getProxy@ returns the current proxy settings. If-- the auto-proxy flag is set to @True@, @getProxy@ will-- perform the necessary getProxy::BrowserAction t Proxy getProxy =dop <-getsbsProxycasep of-- Note: if there is a proxy, no need to perform any auto-detect.-- Presumably this is the user's explicit and preferred proxy server.Proxy {}->returnp NoProxy {}->doflg <-getsbsCheckProxyifnotflg thenreturnp elsedonp <-liftIO$fetchProxy True{-issue warning on stderr if ill-formed...-}-- note: this resets the check-proxy flag; a one-off affair.setProxy np returnnp -- | @setCheckForProxy flg@ sets the one-time check for proxy-- flag to @flg@. If @True@, the session will try to determine-- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy'-- for details of how this done.setCheckForProxy::Bool->BrowserAction t ()setCheckForProxy flg =modify(\b ->b {bsCheckProxy=flg })-- | @getCheckForProxy@ returns the current check-proxy setting.-- Notice that this may not be equal to @True@ if the session has-- set it to that via 'setCheckForProxy' and subsequently performed-- some HTTP protocol interactions. i.e., the flag return represents-- whether a proxy will be checked for again before any future protocol-- interactions.getCheckForProxy::BrowserAction t BoolgetCheckForProxy =getsbsCheckProxy-- | @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::MaybeString->BrowserAction t ()setDebugLog v =modify(\b ->b {bsDebug=v })-- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It-- will be used if no explicit user agent header is found in subsequent requests.---- A common form of user agent string is @\"name\/version (details)\"@. For-- example @\"cabal-install/0.10.2 (HTTP 4000年1月2日)\"@. Including the version-- of this HTTP package can be helpful if you ever need to track down HTTP-- compatability quirks. This version is available via 'httpPackageVersion'.-- For more info see <http://en.wikipedia.org/wiki/User_agent>.--setUserAgent::String->BrowserAction t ()setUserAgent ua =modify(\b ->b {bsUserAgent=Justua })-- | @getUserAgent@ returns the current @User-Agent:@ default string.getUserAgent::BrowserAction t StringgetUserAgent =don <-getsbsUserAgentreturn(maybedefaultUserAgent idn )-- | @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.dataRequestState =RequestState {reqDenies ::Int-- ^ number of 401 responses so far,reqRedirects ::Int-- ^ number of redirects so far,reqRetries ::Int-- ^ number of retries so far,reqStopOnDeny ::Bool-- ^ whether to pre-empt 401 response}typeRequestID =Int-- yeah, it will wrap around.nullRequestState::RequestState nullRequestState =RequestState {reqDenies=0,reqRedirects=0,reqRetries=0,reqStopOnDeny=True}-- | @BrowserEvent@ is the event record type that a user-defined handler, set-- via 'setEventHandler', will be passed. It indicates various state changes-- encountered in the processing of a given 'RequestID', along with timestamps-- at which they occurred.dataBrowserEvent =BrowserEvent {browserTimestamp ::UTCTime,browserRequestID ::RequestID ,browserRequestURI ::{-URI-}String,browserEventType ::BrowserEventType }-- | 'BrowserEventType' is the enumerated list of events that the browser-- internals will report to a user-defined event handler.dataBrowserEventType =OpenConnection |ReuseConnection |RequestSent |ResponseEnd ResponseData |ResponseFinish {- not yet, you will have to determine these via the ResponseEnd event. | Redirect | AuthChallenge | AuthResponse -}-- | @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 ->BrowserAction ty ())->BrowserAction ty ()setEventHandler mbH =modify(\b ->b {bsEvent=mbH })buildBrowserEvent::BrowserEventType ->{-URI-}String->RequestID ->IOBrowserEvent buildBrowserEvent bt uri reqID =doct <-getCurrentTimereturnBrowserEvent {browserTimestamp=ct ,browserRequestID=reqID ,browserRequestURI=uri ,browserEventType=bt }reportEvent::BrowserEventType ->{-URI-}String->BrowserAction t ()reportEvent bt uri =dost <-getcasebsEventst ofNothing->return()JustevH ->doevt <-liftIO$buildBrowserEvent bt uri (bsRequestIDst )evH evt -- if it fails, we fail.-- | The default number of hops we are willing not to go beyond for -- request forwardings.defaultMaxRetries::IntdefaultMaxRetries =4-- | The default number of error retries we are willing to perform.defaultMaxErrorRetries::IntdefaultMaxErrorRetries =4-- | The default maximum HTTP Authentication attempts we will make for-- a single request.defaultMaxAuthAttempts::IntdefaultMaxAuthAttempts =2-- | The default setting for auto-proxy detection.-- You may change this within a session via 'setAutoProxyDetect'.-- To avoid initial backwards compatibility issues, leave this as @False@.defaultAutoProxyDetect::BooldefaultAutoProxyDetect =False-- | @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 =nextRequest $dores <-request' nullVal initialState req reportEvent ResponseFinish (show(rqURIreq ))caseres ofRightr ->returnr Lefte ->doleterrStr =("Network.Browser.request: Error raised "++showe )err errStr Prelude.failerrStr whereinitialState =nullRequestState nullVal =buf_emptybufferOps -- | Internal helper function, explicitly carrying along per-request -- counts.request'::HStream ty =>ty ->RequestState ->Request ty ->BrowserAction (HandleStream ty )(Result (URI,Response ty ))request' nullVal rqState rq =doleturi =rqURIrq failHTTPS uri leturia =reqURIAuth rq -- add cookies to requestcookies <-getCookiesFor (uriAuthToString uria )(uriPathuri ){- Not for now: (case uriUserInfo uria of "" -> id xs -> case chopAtDelim ':' xs of (_,[]) -> id (usr,pwd) -> withAuth AuthBasic{ auUserName = usr , auPassword = pwd , auRealm = "/" , auSite = uri }) $ do -}when(not$nullcookies )(out $"Adding cookies to request. Cookie names: "++unwords(mapckNamecookies ))-- add credentials to requestrq' <-ifnot(reqStopOnDenyrqState )thenreturnrq elsedoauth <-anticipateChallenge rq caseauth ofNothing->returnrq Justx ->return(insertHeader HdrAuthorization (withAuthority x rq )rq )letrq'' =ifnot$nullcookies theninsertHeaders [cookiesToHeader cookies ]rq' elserq' p <-getProxy def_ua <-getsbsUserAgentletdefaultOpts =casep ofNoProxy ->defaultNormalizeRequestOptions {normUserAgent=def_ua }Proxy _ath ->defaultNormalizeRequestOptions {normForProxy=True,normUserAgent=def_ua ,normCustoms=maybe[](\authS ->[\_r ->insertHeader HdrProxyAuthorization (withAuthority authS r )r ])ath }letfinal_req =normalizeRequest defaultOpts rq'' out ("Sending:\n"++showfinal_req )e_rsp <-casep ofNoProxy ->dorequest (reqURIAuth rq'' )final_req Proxy str _ath ->doletnotURI |nullpt ||nullhst =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).letproxyURIAuth =maybenotURI (\parsed ->maybenotURI id(uriAuthorityparsed ))(parseURIstr )out $"proxy uri host: "++uriRegNameproxyURIAuth ++", port: "++uriPortproxyURIAuth dorequest proxyURIAuth final_req mbMx <-getMaxErrorRetries casee_rsp ofLeftv |(reqRetriesrqState <fromMaybedefaultMaxErrorRetries mbMx )&&(v ==ErrorReset ||v ==ErrorClosed )->do--empty connnection pool in case connection has become invalidmodify(\b ->b {bsConnectionPool=[]})request' nullVal rqState {reqRetries=succ(reqRetriesrqState )}rq |otherwise->return(Leftv )Rightrsp ->doout ("Received:\n"++showrsp )-- add new cookies to browser statehandleCookies uri (uriAuthToString $reqURIAuth rq )(retrieveHeaders HdrSetCookie rsp )-- Deal with "Connection: close" in response.handleConnectionClose (reqURIAuth rq )(retrieveHeaders HdrConnection rsp )mbMxAuths <-getMaxAuthAttempts caserspCodersp of(4,0,1)-- Credentials not sent or refused.|reqDeniesrqState >fromMaybedefaultMaxAuthAttempts mbMxAuths ->doout "401 - credentials again refused; exceeded retry count (2)"return(Right(uri ,rsp ))|otherwise->doout "401 - credentials not supplied or refused; retrying.."lethdrs =retrieveHeaders HdrWWWAuthenticate rsp flg <-getAllowBasicAuth casepickChallenge flg (catMaybes$map(headerToChallenge uri )hdrs )ofNothing->doout "no challenge"return(Right(uri ,rsp )){- do nothing -}Justx ->doau <-challengeToAuthority uri x caseau ofNothing->doout "no auth"return(Right(uri ,rsp )){- do nothing -}Justau' ->doout "Retrying request with new credentials"request' nullVal rqState {reqDenies=succ(reqDeniesrqState ),reqStopOnDeny=False}(insertHeader HdrAuthorization (withAuthority au' rq )rq )(4,0,7)-- Proxy Authentication required|reqDeniesrqState >fromMaybedefaultMaxAuthAttempts mbMxAuths ->doout "407 - proxy authentication required; max deny count exceeeded (2)"return(Right(uri ,rsp ))|otherwise->doout "407 - proxy authentication required"lethdrs =retrieveHeaders HdrProxyAuthenticate rsp flg <-getAllowBasicAuth casepickChallenge flg (catMaybes$map(headerToChallenge uri )hdrs )ofNothing->return(Right(uri ,rsp )){- do nothing -}Justx ->doau <-challengeToAuthority uri x caseau ofNothing->return(Right(uri ,rsp )){- do nothing -}Justau' ->dopxy <-getsbsProxycasepxy ofNoProxy ->doerr "Proxy authentication required without proxy!"return(Right(uri ,rsp ))Proxy px _->doout "Retrying with proxy authentication"setProxy (Proxy px (Justau' ))request' nullVal rqState {reqDenies=succ(reqDeniesrqState ),reqStopOnDeny=False}rq (3,0,x )|x `elem`[2,3,1,7]->doout ("30"++showx ++" - redirect")allow_redirs <-allowRedirect rqState caseallow_redirs ofFalse->return(Right(uri ,rsp ))_->docaseretrieveHeaders HdrLocation rsp of[]->doerr "No Location: header in redirect response"return(Right(uri ,rsp ))(Header _u :_)->caseparseURIReferenceu ofNothing->doerr ("Parse of Location: header in a redirect response failed: "++u )return(Right(uri ,rsp ))JustnewURI |{-uriScheme newURI_abs /= uriScheme uri && -}(not(supportedScheme newURI_abs ))->doerr ("Unable to handle redirect, unsupported scheme: "++shownewURI_abs )return(Right(uri ,rsp ))|otherwise->doout ("Redirecting to "++shownewURI_abs ++" ...")-- Redirect using GET request method, depending on-- response code.lettoGet =x `elem`[2,3]method =iftoGet thenGET elserqMethodrq rq1 =rq {rqMethod=method ,rqURI=newURI_abs }rq2 =iftoGet then(replaceHeader HdrContentLength "0")(rq1 {rqBody=nullVal })elserq1 request' nullVal rqState {reqDenies=0,reqRedirects=succ(reqRedirectsrqState ),reqStopOnDeny=True}rq2 wherenewURI_abs =uriDefaultTo newURI uri (3,0,5)->caseretrieveHeaders HdrLocation rsp of[]->doerr "No Location header in proxy redirect response."return(Right(uri ,rsp ))(Header _u :_)->caseparseURIReferenceu ofNothing->doerr ("Parse of Location header in a proxy redirect response failed: "++u )return(Right(uri ,rsp ))Justnewuri ->doout ("Retrying with proxy "++shownewuri ++"...")setProxy (Proxy (uriToAuthorityString newuri )Nothing)request' nullVal rqState {reqDenies=0,reqRedirects=0,reqRetries=succ(reqRetriesrqState ),reqStopOnDeny=True}rq _->return(Right(uri ,rsp ))-- | The internal request handling state machine.dorequest::(HStream ty )=>URIAuth->Request ty ->BrowserAction (HandleStream ty )(Result (Response ty ))dorequest hst rqst =dopool <-getsbsConnectionPoolletuPort =uriAuthPort Nothing{-ToDo: feed in complete URL-}hst conn <-liftIO$filterM(\c ->c `isTCPConnectedTo `EndPoint (uriRegNamehst )uPort )pool rsp <-caseconn of[]->doout ("Creating new connection to "++uriAuthToString hst )reportEvent OpenConnection (show(rqURIrqst ))c <-liftIO$openStream (uriRegNamehst )uPort updateConnectionPool c dorequest2 c rqst (c :_)->doout ("Recovering connection to "++uriAuthToString hst )reportEvent ReuseConnection (show(rqURIrqst ))dorequest2 c rqst casersp ofRight(Response a b c _)->reportEvent (ResponseEnd (a ,b ,c ))(show(rqURIrqst ));_->return()returnrsp wheredorequest2 c r =dodbg <-getsbsDebugst <-getletonSendComplete =maybe(return())(\evh ->dox <-buildBrowserEvent RequestSent (show(rqURIr ))(bsRequestIDst )runBA st (evh x )return())(bsEventst )liftIO$maybe(sendHTTP_notify c r onSendComplete )(\f ->doc' <-debugByteStream (f ++'-':uriAuthToString hst )c sendHTTP_notify c' r onSendComplete )dbg updateConnectionPool::HStream hTy =>HandleStream hTy ->BrowserAction (HandleStream hTy )()updateConnectionPool c =dopool <-getsbsConnectionPoolletlen_pool =lengthpool maxPoolSize <-fromMaybedefaultMaxPoolSize <$>getsbsMaxPoolSizewhen(len_pool >maxPoolSize )(liftIO$close (lastpool ))letpool' |len_pool >maxPoolSize =initpool |otherwise=pool when(maxPoolSize >0)$modify(\b ->b {bsConnectionPool=c :pool' })return()-- | Default maximum number of open connections we are willing to have active.defaultMaxPoolSize::IntdefaultMaxPoolSize =5cleanConnectionPool::HStream hTy =>URIAuth->BrowserAction (HandleStream hTy )()cleanConnectionPool uri =doletep =EndPoint (uriRegNameuri )(uriAuthPort Nothinguri )pool <-getsbsConnectionPoolbad <-liftIO$mapM(\c ->c `isTCPConnectedTo `ep )pool lettmp =zipbad pool newpool =mapsnd$filter(not.fst)tmp toclose =mapsnd$filterfsttmp liftIO$forM_toclose close modify(\b ->b {bsConnectionPool=newpool })handleCookies::URI->String->[Header ]->BrowserAction t ()handleCookies __[]=return()-- cut short the silliness.handleCookiesuri dom cookieHeaders =dowhen(not$nullerrs )(err $unlines("Errors parsing these cookie values: ":errs ))when(not$nullnewCookies )(out $foldl(\x y ->x ++"\n "++showy )"Cookies received:"newCookies )filterfn <-getCookieFilter newCookies' <-liftIO(filterM(filterfn uri )newCookies )when(not$nullnewCookies' )(out $"Accepting cookies with names: "++unwords(mapckNamenewCookies' ))mapM_addCookie newCookies' where(errs ,newCookies )=processCookieHeaders dom cookieHeaders handleConnectionClose::HStream hTy =>URIAuth->[Header ]->BrowserAction (HandleStream hTy )()handleConnectionClose _[]=return()handleConnectionCloseuri headers =doletdoClose =any(=="close")$mapheaderToConnType headers whendoClose $cleanConnectionPool uri whereheaderToConnType (Header _t )=maptoLowert ----------------------------------------------------------------------------------------- Miscellaneous ----------------------------------------------------------------------------------------------allowRedirect::RequestState ->BrowserAction t BoolallowRedirect rqState =dord <-getAllowRedirects mbMxRetries <-getMaxRedirects return(rd &&(reqRedirectsrqState <=fromMaybedefaultMaxRetries mbMxRetries ))-- | Return @True@ iff the package is able to handle requests and responses-- over it.supportedScheme::URI->BoolsupportedScheme u =uriSchemeu =="http:"-- | @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#if MIN_VERSION_network(2,4,0) uriDefaultTo a b =a `relativeTo`b #else uriDefaultToab=maybeaid(a`relativeTo`b)#endif -- This form junk is completely untested...typeFormVar =(String,String)dataForm =Form RequestMethod URI[FormVar ]formToRequest::Form ->Request_String formToRequest (Form m u vs )=letenc =urlEncodeVars vs incasem ofGET ->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$lengthenc )],rqBody=enc ,rqURI=u }_->error("unexpected request: "++showm )