{-# 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))
 
-}
module Network.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
       ) where

import Network.URI
   ( URI(..)
   , URIAuth(..)
   , parseURI, parseURIReference, relativeTo
   )
import Network.StreamDebugger (debugByteStream)
import Network.HTTP hiding ( sendHTTP_notify )
import Network.HTTP.HandleStream ( sendHTTP_notify )
import Network.HTTP.Auth
import Network.HTTP.Cookie
import Network.HTTP.Proxy

import Network.Stream ( ConnError(..), Result )
import Network.BufferType
#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,13,0))
import Control.Monad.Fail
#endif

import Data.Char (toLower)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe, listToMaybe, catMaybes )
import Control.Applicative (Applicative (..), (<$>))
#ifdef MTL1
import Control.Monad (filterM, forM_, when, ap)
#else
import Control.Monad (filterM, forM_, when)
#endif
import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..))

import qualified System.IO
   ( hSetBuffering, hPutStr, stdout, stdin, hGetChar
   , BufferMode(NoBuffering, LineBuffering)
   )
import Data.Time.Clock ( UTCTime, getCurrentTime )


------------------------------------------------------------------
----------------------- Cookie Stuff -----------------------------
------------------------------------------------------------------

-- | @defaultCookieFilter@ is the initial cookie acceptance filter.
-- It welcomes them all into the store @:-)@
defaultCookieFilter :: URI -> Cookie -> IO Bool
defaultCookieFilter :: URI -> Cookie -> IO Bool
defaultCookieFilter URI
_url Cookie
_cky = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 :: URI -> Cookie -> IO Bool
userCookieFilter URI
url Cookie
cky = do
    do String -> IO ()
putStrLn (String
"Set-Cookie received when requesting: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
url)
       case Cookie -> Maybe String
ckComment Cookie
cky of
          Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just String
x  -> String -> IO ()
putStrLn (String
"Cookie Comment:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
       let pth :: String
pth = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:) (Cookie -> Maybe String
ckPath Cookie
cky)
       String -> IO ()
putStrLn (String
"Domain/Path: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cookie -> String
ckDomain Cookie
cky String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pth)
       String -> IO ()
putStrLn (Cookie -> String
ckName Cookie
cky String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'=' Char -> String -> String
forall a. a -> [a] -> [a]
: Cookie -> String
ckValue Cookie
cky)
       Handle -> BufferMode -> IO ()
System.IO.hSetBuffering Handle
System.IO.stdout BufferMode
System.IO.NoBuffering
       Handle -> BufferMode -> IO ()
System.IO.hSetBuffering Handle
System.IO.stdin BufferMode
System.IO.NoBuffering
       Handle -> String -> IO ()
System.IO.hPutStr Handle
System.IO.stdout String
"Accept [y/n]? "
       Char
x <- Handle -> IO Char
System.IO.hGetChar Handle
System.IO.stdin
       Handle -> BufferMode -> IO ()
System.IO.hSetBuffering Handle
System.IO.stdin BufferMode
System.IO.LineBuffering
       Handle -> BufferMode -> IO ()
System.IO.hSetBuffering Handle
System.IO.stdout BufferMode
System.IO.LineBuffering
       Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Char
toLower Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'y')

-- | @addCookie c@ adds a cookie to the browser state, removing duplicates.
addCookie :: Cookie -> BrowserAction t ()
addCookie :: Cookie -> BrowserAction t ()
addCookie Cookie
c = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b{bsCookies :: [Cookie]
bsCookies = Cookie
c Cookie -> [Cookie] -> [Cookie]
forall a. a -> [a] -> [a]
: (Cookie -> Bool) -> [Cookie] -> [Cookie]
forall a. (a -> Bool) -> [a] -> [a]
filter (Cookie -> Cookie -> Bool
forall a. Eq a => a -> a -> Bool
/=Cookie
c) (BrowserState t -> [Cookie]
forall connection. BrowserState connection -> [Cookie]
bsCookies BrowserState t
b) })

-- | @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 :: [Cookie] -> BrowserAction t ()
setCookies [Cookie]
cs = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsCookies :: [Cookie]
bsCookies=[Cookie]
cs })

-- | @getCookies@ returns the current set of cookies known to
-- the browser.
getCookies :: BrowserAction t [Cookie]
getCookies :: BrowserAction t [Cookie]
getCookies = (BrowserState t -> [Cookie]) -> BrowserAction t [Cookie]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> [Cookie]
forall connection. BrowserState connection -> [Cookie]
bsCookies

-- ...get domain specific cookies...
-- ... this needs changing for consistency with rfc2109...
-- ... currently too broad.
getCookiesFor :: String -> String -> BrowserAction t [Cookie]
getCookiesFor :: String -> String -> BrowserAction t [Cookie]
getCookiesFor String
dom String
path =
    do [Cookie]
cks <- BrowserAction t [Cookie]
forall t. BrowserAction t [Cookie]
getCookies
       [Cookie] -> BrowserAction t [Cookie]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Cookie -> Bool) -> [Cookie] -> [Cookie]
forall a. (a -> Bool) -> [a] -> [a]
filter Cookie -> Bool
cookiematch [Cookie]
cks)
    where
        cookiematch :: Cookie -> Bool
        cookiematch :: Cookie -> Bool
cookiematch = (String, String) -> Cookie -> Bool
cookieMatch (String
dom,String
path)
      

-- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@.
setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()
setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()
setCookieFilter URI -> Cookie -> IO Bool
f = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsCookieFilter :: URI -> Cookie -> IO Bool
bsCookieFilter=URI -> Cookie -> IO Bool
f })

-- | @getCookieFilter@ returns the current cookie acceptance filter.
getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool)
getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool)
getCookieFilter = (BrowserState t -> URI -> Cookie -> IO Bool)
-> BrowserAction t (URI -> Cookie -> IO Bool)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> URI -> Cookie -> IO Bool
forall connection.
BrowserState connection -> URI -> Cookie -> IO Bool
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

-}

-- | Return authorities for a given domain and path.
-- Assumes "dom" is lower case
getAuthFor :: String -> String -> BrowserAction t [Authority]
getAuthFor :: String -> String -> BrowserAction t [Authority]
getAuthFor String
dom String
pth = BrowserAction t [Authority]
forall t. BrowserAction t [Authority]
getAuthorities BrowserAction t [Authority]
-> ([Authority] -> BrowserAction t [Authority])
-> BrowserAction t [Authority]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Authority] -> BrowserAction t [Authority]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Authority] -> BrowserAction t [Authority])
-> ([Authority] -> [Authority])
-> [Authority]
-> BrowserAction t [Authority]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Authority -> Bool) -> [Authority] -> [Authority]
forall a. (a -> Bool) -> [a] -> [a]
filter Authority -> Bool
match)
   where
    match :: Authority -> Bool
    match :: Authority -> Bool
match au :: Authority
au@AuthBasic{}  = URI -> Bool
matchURI (Authority -> URI
auSite Authority
au)
    match au :: Authority
au@AuthDigest{} = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((URI -> Bool) -> [URI] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map URI -> Bool
matchURI (Authority -> [URI]
auDomain Authority
au))

    matchURI :: URI -> Bool
    matchURI :: URI -> Bool
matchURI URI
s = (URI -> String
uriToAuthorityString URI
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
dom) Bool -> Bool -> Bool
&& (URI -> String
uriPath URI
s String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
pth)
    

-- | @getAuthorities@ return the current set of @Authority@s known
-- to the browser.
getAuthorities :: BrowserAction t [Authority]
getAuthorities :: BrowserAction t [Authority]
getAuthorities = (BrowserState t -> [Authority]) -> BrowserAction t [Authority]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> [Authority]
forall connection. BrowserState connection -> [Authority]
bsAuthorities

-- @setAuthorities as@ replaces the Browser's known set
-- of 'Authority's to @as@.
setAuthorities :: [Authority] -> BrowserAction t ()
setAuthorities :: [Authority] -> BrowserAction t ()
setAuthorities [Authority]
as = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsAuthorities :: [Authority]
bsAuthorities=[Authority]
as })

-- @addAuthority a@ adds 'Authority' @a@ to the Browser's
-- set of known authorities.
addAuthority :: Authority -> BrowserAction t ()
addAuthority :: Authority -> BrowserAction t ()
addAuthority Authority
a = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsAuthorities :: [Authority]
bsAuthorities=Authority
aAuthority -> [Authority] -> [Authority]
forall a. a -> [a] -> [a]
:BrowserState t -> [Authority]
forall connection. BrowserState connection -> [Authority]
bsAuthorities BrowserState t
b })

-- | @getAuthorityGen@ returns the current authority generator
getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String)))
getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String, String)))
getAuthorityGen = (BrowserState t -> URI -> String -> IO (Maybe (String, String)))
-> BrowserAction t (URI -> String -> IO (Maybe (String, String)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> URI -> String -> IO (Maybe (String, String))
forall connection.
BrowserState connection
-> URI -> String -> IO (Maybe (String, String))
bsAuthorityGen

-- | @setAuthorityGen genAct@ sets the auth generator to @genAct@.
setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t ()
setAuthorityGen :: (URI -> String -> IO (Maybe (String, String)))
-> BrowserAction t ()
setAuthorityGen URI -> String -> IO (Maybe (String, String))
f = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsAuthorityGen :: URI -> String -> IO (Maybe (String, String))
bsAuthorityGen=URI -> String -> IO (Maybe (String, String))
f })

-- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication.
setAllowBasicAuth :: Bool -> BrowserAction t ()
setAllowBasicAuth :: Bool -> BrowserAction t ()
setAllowBasicAuth Bool
ba = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsAllowBasicAuth :: Bool
bsAllowBasicAuth=Bool
ba })

getAllowBasicAuth :: BrowserAction t Bool
getAllowBasicAuth :: BrowserAction t Bool
getAllowBasicAuth = (BrowserState t -> Bool) -> BrowserAction t Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Bool
forall connection. BrowserState connection -> Bool
bsAllowBasicAuth

-- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts
-- to do. If @Nothing@, rever to default max.
setMaxAuthAttempts :: Maybe Int -> BrowserAction t ()
setMaxAuthAttempts :: Maybe Int -> BrowserAction t ()
setMaxAuthAttempts Maybe Int
mb 
 | Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
mb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = () -> BrowserAction t ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 | Bool
otherwise          = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ BrowserState t
b -> BrowserState t
b{bsMaxAuthAttempts :: Maybe Int
bsMaxAuthAttempts=Maybe Int
mb})

-- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@,
-- the browser's default is used.
getMaxAuthAttempts :: BrowserAction t (Maybe Int)
getMaxAuthAttempts :: BrowserAction t (Maybe Int)
getMaxAuthAttempts = (BrowserState t -> Maybe Int) -> BrowserAction t (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Maybe Int
forall connection. BrowserState connection -> Maybe Int
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 :: Maybe Int -> BrowserAction t ()
setMaxErrorRetries Maybe Int
mb
 | Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
mb Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = () -> BrowserAction t ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 | Bool
otherwise          = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ BrowserState t
b -> BrowserState t
b{bsMaxErrorRetries :: Maybe Int
bsMaxErrorRetries=Maybe Int
mb})

-- | @getMaxErrorRetries@ returns the current max number of error retries.
getMaxErrorRetries :: BrowserAction t (Maybe Int)
getMaxErrorRetries :: BrowserAction t (Maybe Int)
getMaxErrorRetries = (BrowserState t -> Maybe Int) -> BrowserAction t (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Maybe Int
forall connection. BrowserState connection -> Maybe Int
bsMaxErrorRetries

-- TO BE CHANGED!!!
pickChallenge :: Bool -> [Challenge] -> Maybe Challenge
pickChallenge :: Bool -> [Challenge] -> Maybe Challenge
pickChallenge Bool
allowBasic []
 | Bool
allowBasic = Challenge -> Maybe Challenge
forall a. a -> Maybe a
Just (String -> Challenge
ChalBasic String
"/") -- manufacture a challenge if one missing; more robust.
pickChallenge Bool
_ [Challenge]
ls = [Challenge] -> Maybe Challenge
forall a. [a] -> Maybe a
listToMaybe [Challenge]
ls

-- | Retrieve a likely looking authority for a Request.
anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority)
anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority)
anticipateChallenge Request ty
rq =
    let uri :: URI
uri = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rq in
    do { [Authority]
authlist <- String -> String -> BrowserAction t [Authority]
forall t. String -> String -> BrowserAction t [Authority]
getAuthFor (URIAuth -> String
uriAuthToString (URIAuth -> String) -> URIAuth -> String
forall a b. (a -> b) -> a -> b
$ Request ty -> URIAuth
forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq) (URI -> String
uriPath URI
uri)
       ; Maybe Authority -> BrowserAction t (Maybe Authority)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Authority] -> Maybe Authority
forall a. [a] -> Maybe a
listToMaybe [Authority]
authlist)
       }

-- | Asking the user to respond to a challenge
challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority URI
uri Challenge
ch
 | Bool -> Bool
not (Challenge -> Bool
answerable Challenge
ch) = Maybe Authority -> BrowserAction t (Maybe Authority)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Authority
forall a. Maybe a
Nothing
 | Bool
otherwise = do
      -- prompt user for authority
    URI -> String -> IO (Maybe (String, String))
prompt <- BrowserAction t (URI -> String -> IO (Maybe (String, String)))
forall t.
BrowserAction t (URI -> String -> IO (Maybe (String, String)))
getAuthorityGen
    Maybe (String, String)
userdetails <- IO (Maybe (String, String))
-> BrowserAction t (Maybe (String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (String, String))
 -> BrowserAction t (Maybe (String, String)))
-> IO (Maybe (String, String))
-> BrowserAction t (Maybe (String, String))
forall a b. (a -> b) -> a -> b
$ URI -> String -> IO (Maybe (String, String))
prompt URI
uri (Challenge -> String
chRealm Challenge
ch)
    case Maybe (String, String)
userdetails of
     Maybe (String, String)
Nothing    -> Maybe Authority -> BrowserAction t (Maybe Authority)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Authority
forall a. Maybe a
Nothing
     Just (String
u,String
p) -> Maybe Authority -> BrowserAction t (Maybe Authority)
forall (m :: * -> *) a. Monad m => a -> m a
return (Authority -> Maybe Authority
forall a. a -> Maybe a
Just (Authority -> Maybe Authority) -> Authority -> Maybe Authority
forall a b. (a -> b) -> a -> b
$ Challenge -> String -> String -> Authority
buildAuth Challenge
ch String
u String
p)
 where
  answerable :: Challenge -> Bool
  answerable :: Challenge -> Bool
answerable ChalBasic{} = Bool
True
  answerable Challenge
chall       = (Challenge -> Maybe Algorithm
chAlgorithm Challenge
chall) Maybe Algorithm -> Maybe Algorithm -> Bool
forall a. Eq a => a -> a -> Bool
== Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
Just Algorithm
AlgMD5

  buildAuth :: Challenge -> String -> String -> Authority
  buildAuth :: Challenge -> String -> String -> Authority
buildAuth (ChalBasic String
r) String
u String
p = 
       AuthBasic :: String -> String -> String -> URI -> Authority
AuthBasic { auSite :: URI
auSite=URI
uri
                 , auRealm :: String
auRealm=String
r
                 , auUsername :: String
auUsername=String
u
                 , auPassword :: String
auPassword=String
p
                 }

    -- note to self: this is a pretty stupid operation
    -- to perform isn't it? ChalX and AuthX are so very
    -- similar.
  buildAuth (ChalDigest String
r [URI]
d String
n Maybe String
o Bool
_stale Maybe Algorithm
a [Qop]
q) String
u String
p =
            AuthDigest :: String
-> String
-> String
-> String
-> Maybe Algorithm
-> [URI]
-> Maybe String
-> [Qop]
-> Authority
AuthDigest { auRealm :: String
auRealm=String
r
                       , auUsername :: String
auUsername=String
u
                       , auPassword :: String
auPassword=String
p
                       , auDomain :: [URI]
auDomain=[URI]
d
                       , auNonce :: String
auNonce=String
n
                       , auOpaque :: Maybe String
auOpaque=Maybe String
o
                       , auAlgorithm :: Maybe Algorithm
auAlgorithm=Maybe Algorithm
a
                       , auQop :: [Qop]
auQop=[Qop]
q
                       }


------------------------------------------------------------------
------------------ Browser State Actions -------------------------
------------------------------------------------------------------


-- | @BrowserState@ is the (large) record type tracking the current
-- settings of the browser.
data BrowserState connection
 = BS { BrowserState connection -> String -> IO ()
bsErr, BrowserState connection -> String -> IO ()
bsOut      :: String -> IO ()
      , BrowserState connection -> [Cookie]
bsCookies         :: [Cookie]
      , BrowserState connection -> URI -> Cookie -> IO Bool
bsCookieFilter    :: URI -> Cookie -> IO Bool
      , BrowserState connection
-> URI -> String -> IO (Maybe (String, String))
bsAuthorityGen    :: URI -> String -> IO (Maybe (String,String))
      , BrowserState connection -> [Authority]
bsAuthorities     :: [Authority]
      , BrowserState connection -> Bool
bsAllowRedirects  :: Bool
      , BrowserState connection -> Bool
bsAllowBasicAuth  :: Bool
      , BrowserState connection -> Maybe Int
bsMaxRedirects    :: Maybe Int
      , BrowserState connection -> Maybe Int
bsMaxErrorRetries :: Maybe Int
      , BrowserState connection -> Maybe Int
bsMaxAuthAttempts :: Maybe Int
      , BrowserState connection -> Maybe Int
bsMaxPoolSize     :: Maybe Int
      , BrowserState connection -> [connection]
bsConnectionPool  :: [connection]
      , BrowserState connection -> Bool
bsCheckProxy      :: Bool
      , BrowserState connection -> Proxy
bsProxy           :: Proxy
      , BrowserState connection -> Maybe String
bsDebug           :: Maybe String
      , BrowserState connection
-> Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent           :: Maybe (BrowserEvent -> BrowserAction connection ())
      , BrowserState connection -> Int
bsRequestID       :: RequestID
      , BrowserState connection -> Maybe String
bsUserAgent       :: Maybe String
      }

instance Show (BrowserState t) where
    show :: BrowserState t -> String
show BrowserState t
bs =  String
"BrowserState { " 
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Cookie] -> String -> String
forall a. Show a => a -> String -> String
shows (BrowserState t -> [Cookie]
forall connection. BrowserState connection -> [Cookie]
bsCookies BrowserState t
bs) (String
"\n"
           {- ++ show (bsAuthorities bs) ++ "\n"-}
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"AllowRedirects: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String -> String
forall a. Show a => a -> String -> String
shows (BrowserState t -> Bool
forall connection. BrowserState connection -> Bool
bsAllowRedirects BrowserState t
bs) String
"} ")

-- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'.
newtype BrowserAction conn a
 = BA { BrowserAction conn a -> StateT (BrowserState conn) IO a
unBA :: StateT (BrowserState conn) IO a }
#ifdef MTL1
 deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn))

instance Applicative (BrowserAction conn) where
  pure  = return
  (<*>) = ap
#else
 deriving
 ( a -> BrowserAction conn b -> BrowserAction conn a
(a -> b) -> BrowserAction conn a -> BrowserAction conn b
(forall a b.
 (a -> b) -> BrowserAction conn a -> BrowserAction conn b)
-> (forall a b. a -> BrowserAction conn b -> BrowserAction conn a)
-> Functor (BrowserAction conn)
forall a b. a -> BrowserAction conn b -> BrowserAction conn a
forall a b.
(a -> b) -> BrowserAction conn a -> BrowserAction conn b
forall conn a b. a -> BrowserAction conn b -> BrowserAction conn a
forall conn a b.
(a -> b) -> BrowserAction conn a -> BrowserAction conn b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> BrowserAction conn b -> BrowserAction conn a
$c<$ :: forall conn a b. a -> BrowserAction conn b -> BrowserAction conn a
fmap :: (a -> b) -> BrowserAction conn a -> BrowserAction conn b
$cfmap :: forall conn a b.
(a -> b) -> BrowserAction conn a -> BrowserAction conn b
Functor, Functor (BrowserAction conn)
a -> BrowserAction conn a
Functor (BrowserAction conn)
-> (forall a. a -> BrowserAction conn a)
-> (forall a b.
    BrowserAction conn (a -> b)
    -> BrowserAction conn a -> BrowserAction conn b)
-> (forall a b c.
    (a -> b -> c)
    -> BrowserAction conn a
    -> BrowserAction conn b
    -> BrowserAction conn c)
-> (forall a b.
    BrowserAction conn a
    -> BrowserAction conn b -> BrowserAction conn b)
-> (forall a b.
    BrowserAction conn a
    -> BrowserAction conn b -> BrowserAction conn a)
-> Applicative (BrowserAction conn)
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn a
BrowserAction conn (a -> b)
-> BrowserAction conn a -> BrowserAction conn b
(a -> b -> c)
-> BrowserAction conn a
-> BrowserAction conn b
-> BrowserAction conn c
forall conn. Functor (BrowserAction conn)
forall a. a -> BrowserAction conn a
forall conn a. a -> BrowserAction conn a
forall a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn a
forall a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
forall a b.
BrowserAction conn (a -> b)
-> BrowserAction conn a -> BrowserAction conn b
forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn a
forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
forall conn a b.
BrowserAction conn (a -> b)
-> BrowserAction conn a -> BrowserAction conn b
forall a b c.
(a -> b -> c)
-> BrowserAction conn a
-> BrowserAction conn b
-> BrowserAction conn c
forall conn a b c.
(a -> b -> c)
-> BrowserAction conn a
-> BrowserAction conn b
-> BrowserAction conn c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn a
$c<* :: forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn a
*> :: BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
$c*> :: forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
liftA2 :: (a -> b -> c)
-> BrowserAction conn a
-> BrowserAction conn b
-> BrowserAction conn c
$cliftA2 :: forall conn a b c.
(a -> b -> c)
-> BrowserAction conn a
-> BrowserAction conn b
-> BrowserAction conn c
<*> :: BrowserAction conn (a -> b)
-> BrowserAction conn a -> BrowserAction conn b
$c<*> :: forall conn a b.
BrowserAction conn (a -> b)
-> BrowserAction conn a -> BrowserAction conn b
pure :: a -> BrowserAction conn a
$cpure :: forall conn a. a -> BrowserAction conn a
$cp1Applicative :: forall conn. Functor (BrowserAction conn)
Applicative, Applicative (BrowserAction conn)
a -> BrowserAction conn a
Applicative (BrowserAction conn)
-> (forall a b.
    BrowserAction conn a
    -> (a -> BrowserAction conn b) -> BrowserAction conn b)
-> (forall a b.
    BrowserAction conn a
    -> BrowserAction conn b -> BrowserAction conn b)
-> (forall a. a -> BrowserAction conn a)
-> Monad (BrowserAction conn)
BrowserAction conn a
-> (a -> BrowserAction conn b) -> BrowserAction conn b
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
forall conn. Applicative (BrowserAction conn)
forall a. a -> BrowserAction conn a
forall conn a. a -> BrowserAction conn a
forall a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
forall a b.
BrowserAction conn a
-> (a -> BrowserAction conn b) -> BrowserAction conn b
forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
forall conn a b.
BrowserAction conn a
-> (a -> BrowserAction conn b) -> BrowserAction conn b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> BrowserAction conn a
$creturn :: forall conn a. a -> BrowserAction conn a
>> :: BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
$c>> :: forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
>>= :: BrowserAction conn a
-> (a -> BrowserAction conn b) -> BrowserAction conn b
$c>>= :: forall conn a b.
BrowserAction conn a
-> (a -> BrowserAction conn b) -> BrowserAction conn b
$cp1Monad :: forall conn. Applicative (BrowserAction conn)
Monad, Monad (BrowserAction conn)
Monad (BrowserAction conn)
-> (forall a. IO a -> BrowserAction conn a)
-> MonadIO (BrowserAction conn)
IO a -> BrowserAction conn a
forall conn. Monad (BrowserAction conn)
forall a. IO a -> BrowserAction conn a
forall conn a. IO a -> BrowserAction conn a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> BrowserAction conn a
$cliftIO :: forall conn a. IO a -> BrowserAction conn a
$cp1MonadIO :: forall conn. Monad (BrowserAction conn)
MonadIO, MonadState (BrowserState conn)
#if MIN_VERSION_base(4,9,0)
 , Monad (BrowserAction conn)
Monad (BrowserAction conn)
-> (forall a. String -> BrowserAction conn a)
-> MonadFail (BrowserAction conn)
String -> BrowserAction conn a
forall conn. Monad (BrowserAction conn)
forall a. String -> BrowserAction conn a
forall conn a. String -> BrowserAction conn a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> BrowserAction conn a
$cfail :: forall conn a. String -> BrowserAction conn a
$cp1MonadFail :: forall conn. Monad (BrowserAction conn)
MonadFail
#endif
 )
#endif

runBA :: BrowserState conn -> BrowserAction conn a -> IO a
runBA :: BrowserState conn -> BrowserAction conn a -> IO a
runBA BrowserState conn
bs = (StateT (BrowserState conn) IO a -> BrowserState conn -> IO a)
-> BrowserState conn -> StateT (BrowserState conn) IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (BrowserState conn) IO a -> BrowserState conn -> IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT BrowserState conn
bs (StateT (BrowserState conn) IO a -> IO a)
-> (BrowserAction conn a -> StateT (BrowserState conn) IO a)
-> BrowserAction conn a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrowserAction conn a -> StateT (BrowserState conn) IO a
forall conn a.
BrowserAction conn a -> StateT (BrowserState conn) IO a
unBA

-- | @browse act@ is the toplevel action to perform a 'BrowserAction'.
-- Example use: @browse (request (getRequest yourURL))@.
browse :: BrowserAction conn a -> IO a
browse :: BrowserAction conn a -> IO a
browse = BrowserState conn -> BrowserAction conn a -> IO a
forall conn a. BrowserState conn -> BrowserAction conn a -> IO a
runBA BrowserState conn
forall t. BrowserState t
defaultBrowserState

-- | The default browser state has the settings 
defaultBrowserState :: BrowserState t
defaultBrowserState :: BrowserState t
defaultBrowserState = BrowserState t
forall t. BrowserState t
res
 where
   res :: BrowserState connection
res = BS :: forall connection.
(String -> IO ())
-> (String -> IO ())
-> [Cookie]
-> (URI -> Cookie -> IO Bool)
-> (URI -> String -> IO (Maybe (String, String)))
-> [Authority]
-> Bool
-> Bool
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> [connection]
-> Bool
-> Proxy
-> Maybe String
-> Maybe (BrowserEvent -> BrowserAction connection ())
-> Int
-> Maybe String
-> BrowserState connection
BS
     { bsErr :: String -> IO ()
bsErr              = String -> IO ()
putStrLn
     , bsOut :: String -> IO ()
bsOut              = String -> IO ()
putStrLn
     , bsCookies :: [Cookie]
bsCookies          = []
     , bsCookieFilter :: URI -> Cookie -> IO Bool
bsCookieFilter     = URI -> Cookie -> IO Bool
defaultCookieFilter
     , bsAuthorityGen :: URI -> String -> IO (Maybe (String, String))
bsAuthorityGen     = \ URI
_uri String
_realm -> do
          BrowserState connection -> String -> IO ()
forall connection. BrowserState connection -> String -> IO ()
bsErr BrowserState connection
res String
"No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing"
          Maybe (String, String) -> IO (Maybe (String, String))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String, String)
forall a. Maybe a
Nothing
     , bsAuthorities :: [Authority]
bsAuthorities      = []
     , bsAllowRedirects :: Bool
bsAllowRedirects   = Bool
True
     , bsAllowBasicAuth :: Bool
bsAllowBasicAuth   = Bool
False
     , bsMaxRedirects :: Maybe Int
bsMaxRedirects     = Maybe Int
forall a. Maybe a
Nothing
     , bsMaxErrorRetries :: Maybe Int
bsMaxErrorRetries  = Maybe Int
forall a. Maybe a
Nothing
     , bsMaxAuthAttempts :: Maybe Int
bsMaxAuthAttempts  = Maybe Int
forall a. Maybe a
Nothing
     , bsMaxPoolSize :: Maybe Int
bsMaxPoolSize      = Maybe Int
forall a. Maybe a
Nothing
     , bsConnectionPool :: [connection]
bsConnectionPool   = []
     , bsCheckProxy :: Bool
bsCheckProxy       = Bool
defaultAutoProxyDetect
     , bsProxy :: Proxy
bsProxy            = Proxy
noProxy
     , bsDebug :: Maybe String
bsDebug            = Maybe String
forall a. Maybe a
Nothing 
     , bsEvent :: Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent            = Maybe (BrowserEvent -> BrowserAction connection ())
forall a. Maybe a
Nothing
     , bsRequestID :: Int
bsRequestID        = Int
0
     , bsUserAgent :: Maybe String
bsUserAgent        = Maybe String
forall a. Maybe a
Nothing
     }

{-# DEPRECATED getBrowserState "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 :: BrowserAction t (BrowserState t)
getBrowserState = BrowserAction t (BrowserState t)
forall s (m :: * -> *). MonadState s m => m s
get

-- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@.
withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a
withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a
withBrowserState BrowserState t
bs = StateT (BrowserState t) IO a -> BrowserAction t a
forall conn a.
StateT (BrowserState conn) IO a -> BrowserAction conn a
BA (StateT (BrowserState t) IO a -> BrowserAction t a)
-> (BrowserAction t a -> StateT (BrowserState t) IO a)
-> BrowserAction t a
-> BrowserAction t a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BrowserState t -> BrowserState t)
-> StateT (BrowserState t) IO a -> StateT (BrowserState t) IO a
forall s (m :: * -> *) a. (s -> s) -> StateT s m a -> StateT s m a
withStateT (BrowserState t -> BrowserState t -> BrowserState t
forall a b. a -> b -> a
const BrowserState t
bs) (StateT (BrowserState t) IO a -> StateT (BrowserState t) IO a)
-> (BrowserAction t a -> StateT (BrowserState t) IO a)
-> BrowserAction t a
-> StateT (BrowserState t) IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrowserAction t a -> StateT (BrowserState t) IO a
forall conn a.
BrowserAction conn a -> StateT (BrowserState conn) IO a
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 :: BrowserAction t a -> BrowserAction t a
nextRequest BrowserAction t a
act = do
  let updReqID :: BrowserState connection -> BrowserState connection
updReqID BrowserState connection
st = 
       let 
        rid :: Int
rid = Int -> Int
forall a. Enum a => a -> a
succ (BrowserState connection -> Int
forall connection. BrowserState connection -> Int
bsRequestID BrowserState connection
st)
       in
       Int
rid Int -> BrowserState connection -> BrowserState connection
`seq` BrowserState connection
st{bsRequestID :: Int
bsRequestID=Int
rid}
  (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify BrowserState t -> BrowserState t
forall connection.
BrowserState connection -> BrowserState connection
updReqID
  BrowserAction t a
act

-- | Lifts an IO action into the 'BrowserAction' monad.
{-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-}
ioAction :: IO a -> BrowserAction t a
ioAction :: IO a -> BrowserAction t a
ioAction = IO a -> BrowserAction t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
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 :: (String -> IO ()) -> BrowserAction t ()
setErrHandler String -> IO ()
h = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsErr :: String -> IO ()
bsErr=String -> IO ()
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 :: (String -> IO ()) -> BrowserAction t ()
setOutHandler String -> IO ()
h = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsOut :: String -> IO ()
bsOut=String -> IO ()
h })

out, err :: String -> BrowserAction t ()
out :: String -> BrowserAction t ()
out String
s = do { String -> IO ()
f <- (BrowserState t -> String -> IO ())
-> BrowserAction t (String -> IO ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> String -> IO ()
forall connection. BrowserState connection -> String -> IO ()
bsOut ; IO () -> BrowserAction t ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BrowserAction t ()) -> IO () -> BrowserAction t ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
f String
s }
err :: String -> BrowserAction t ()
err String
s = do { String -> IO ()
f <- (BrowserState t -> String -> IO ())
-> BrowserAction t (String -> IO ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> String -> IO ()
forall connection. BrowserState connection -> String -> IO ()
bsErr ; IO () -> BrowserAction t ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BrowserAction t ()) -> IO () -> BrowserAction t ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
f String
s }

-- | @setAllowRedirects onOff@ toggles the willingness to
-- follow redirects (HTTP responses with 3xx status codes).
setAllowRedirects :: Bool -> BrowserAction t ()
setAllowRedirects :: Bool -> BrowserAction t ()
setAllowRedirects Bool
bl = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b {bsAllowRedirects :: Bool
bsAllowRedirects=Bool
bl})

-- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag.
getAllowRedirects :: BrowserAction t Bool
getAllowRedirects :: BrowserAction t Bool
getAllowRedirects = (BrowserState t -> Bool) -> BrowserAction t Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Bool
forall connection. BrowserState connection -> Bool
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 :: Maybe Int -> BrowserAction t ()
setMaxRedirects Maybe Int
c 
 | Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0  = () -> BrowserAction t ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 | Bool
otherwise          = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b{bsMaxRedirects :: Maybe Int
bsMaxRedirects=Maybe Int
c})

-- | @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 :: BrowserAction t (Maybe Int)
getMaxRedirects = (BrowserState t -> Maybe Int) -> BrowserAction t (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Maybe Int
forall connection. BrowserState connection -> Maybe Int
bsMaxRedirects

-- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool
-- that is used to cache connections between requests
setMaxPoolSize :: Maybe Int -> BrowserAction t ()
setMaxPoolSize :: Maybe Int -> BrowserAction t ()
setMaxPoolSize Maybe Int
c = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b{bsMaxPoolSize :: Maybe Int
bsMaxPoolSize=Maybe Int
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 (Maybe Int)
getMaxPoolSize :: BrowserAction t (Maybe Int)
getMaxPoolSize = (BrowserState t -> Maybe Int) -> BrowserAction t (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Maybe Int
forall connection. BrowserState connection -> Maybe Int
bsMaxPoolSize

-- | @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 :: Proxy -> BrowserAction t ()
setProxy Proxy
p =
   -- Note: if user _explicitly_ sets the proxy, we turn
   -- off any auto-detection of proxies.
  (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b {bsProxy :: Proxy
bsProxy = Proxy
p, bsCheckProxy :: Bool
bsCheckProxy=Bool
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 :: BrowserAction t Proxy
getProxy = do
  Proxy
p <- (BrowserState t -> Proxy) -> BrowserAction t Proxy
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Proxy
forall connection. BrowserState connection -> Proxy
bsProxy
  case Proxy
p 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{} -> Proxy -> BrowserAction t Proxy
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
p
    NoProxy{} -> do
     Bool
flg <- (BrowserState t -> Bool) -> BrowserAction t Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Bool
forall connection. BrowserState connection -> Bool
bsCheckProxy
     if Bool -> Bool
not Bool
flg
      then Proxy -> BrowserAction t Proxy
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
p 
      else do
       Proxy
np <- IO Proxy -> BrowserAction t Proxy
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Proxy -> BrowserAction t Proxy)
-> IO Proxy -> BrowserAction t Proxy
forall a b. (a -> b) -> a -> b
$ Bool -> IO Proxy
fetchProxy Bool
True{-issue warning on stderr if ill-formed...-}
        -- note: this resets the check-proxy flag; a one-off affair.
       Proxy -> BrowserAction t ()
forall t. Proxy -> BrowserAction t ()
setProxy Proxy
np
       Proxy -> BrowserAction t Proxy
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
np

-- | @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 :: Bool -> BrowserAction t ()
setCheckForProxy Bool
flg = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\ BrowserState t
b -> BrowserState t
b{bsCheckProxy :: Bool
bsCheckProxy=Bool
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 Bool
getCheckForProxy :: BrowserAction t Bool
getCheckForProxy = (BrowserState t -> Bool) -> BrowserAction t Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Bool
forall connection. BrowserState connection -> Bool
bsCheckProxy

-- | @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 :: Maybe String -> BrowserAction t ()
setDebugLog Maybe String
v = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b {bsDebug :: Maybe String
bsDebug=Maybe String
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 :: String -> BrowserAction t ()
setUserAgent String
ua = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b{bsUserAgent :: Maybe String
bsUserAgent=String -> Maybe String
forall a. a -> Maybe a
Just String
ua})

-- | @getUserAgent@ returns the current @User-Agent:@ default string.
getUserAgent :: BrowserAction t String
getUserAgent :: BrowserAction t String
getUserAgent  = do
  Maybe String
n <- (BrowserState t -> Maybe String) -> BrowserAction t (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState t -> Maybe String
forall connection. BrowserState connection -> Maybe String
bsUserAgent
  String -> BrowserAction t String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
defaultUserAgent String -> String
forall a. a -> a
id Maybe String
n)

-- | @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
      { RequestState -> Int
reqDenies     :: Int   -- ^ number of 401 responses so far
      , RequestState -> Int
reqRedirects  :: Int   -- ^ number of redirects so far
      , RequestState -> Int
reqRetries    :: Int   -- ^ number of retries so far
      , RequestState -> Bool
reqStopOnDeny :: Bool  -- ^ whether to pre-empt 401 response
      }

type RequestID = Int -- yeah, it will wrap around.

nullRequestState :: RequestState
nullRequestState :: RequestState
nullRequestState = RequestState :: Int -> Int -> Int -> Bool -> RequestState
RequestState
      { reqDenies :: Int
reqDenies     = Int
0
      , reqRedirects :: Int
reqRedirects  = Int
0
      , reqRetries :: Int
reqRetries    = Int
0
      , reqStopOnDeny :: Bool
reqStopOnDeny = Bool
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.
data BrowserEvent
 = BrowserEvent
      { BrowserEvent -> UTCTime
browserTimestamp  :: UTCTime
      , BrowserEvent -> Int
browserRequestID  :: RequestID
      , BrowserEvent -> String
browserRequestURI :: {-URI-}String
      , BrowserEvent -> BrowserEventType
browserEventType  :: BrowserEventType
      }

-- | 'BrowserEventType' is the enumerated list of events that the browser
-- internals will report to a user-defined event handler.
data BrowserEventType
 = 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 :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty ()
setEventHandler Maybe (BrowserEvent -> BrowserAction ty ())
mbH = (BrowserState ty -> BrowserState ty) -> BrowserAction ty ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState ty
b -> BrowserState ty
b { bsEvent :: Maybe (BrowserEvent -> BrowserAction ty ())
bsEvent=Maybe (BrowserEvent -> BrowserAction ty ())
mbH})

buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent
buildBrowserEvent :: BrowserEventType -> String -> Int -> IO BrowserEvent
buildBrowserEvent BrowserEventType
bt String
uri Int
reqID = do
  UTCTime
ct <- IO UTCTime
getCurrentTime
  BrowserEvent -> IO BrowserEvent
forall (m :: * -> *) a. Monad m => a -> m a
return BrowserEvent :: UTCTime -> Int -> String -> BrowserEventType -> BrowserEvent
BrowserEvent 
         { browserTimestamp :: UTCTime
browserTimestamp  = UTCTime
ct
         , browserRequestID :: Int
browserRequestID  = Int
reqID
         , browserRequestURI :: String
browserRequestURI = String
uri
         , browserEventType :: BrowserEventType
browserEventType  = BrowserEventType
bt
         }

reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t ()
reportEvent :: BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
bt String
uri = do
  BrowserState t
st <- BrowserAction t (BrowserState t)
forall s (m :: * -> *). MonadState s m => m s
get
  case BrowserState t -> Maybe (BrowserEvent -> BrowserAction t ())
forall connection.
BrowserState connection
-> Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent BrowserState t
st of
    Maybe (BrowserEvent -> BrowserAction t ())
Nothing -> () -> BrowserAction t ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just BrowserEvent -> BrowserAction t ()
evH -> do
       BrowserEvent
evt <- IO BrowserEvent -> BrowserAction t BrowserEvent
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BrowserEvent -> BrowserAction t BrowserEvent)
-> IO BrowserEvent -> BrowserAction t BrowserEvent
forall a b. (a -> b) -> a -> b
$ BrowserEventType -> String -> Int -> IO BrowserEvent
buildBrowserEvent BrowserEventType
bt String
uri (BrowserState t -> Int
forall connection. BrowserState connection -> Int
bsRequestID BrowserState t
st)
       BrowserEvent -> BrowserAction t ()
evH BrowserEvent
evt -- if it fails, we fail.

-- | The default number of hops we are willing not to go beyond for 
-- request forwardings.
defaultMaxRetries :: Int
defaultMaxRetries :: Int
defaultMaxRetries = Int
4

-- | The default number of error retries we are willing to perform.
defaultMaxErrorRetries :: Int
defaultMaxErrorRetries :: Int
defaultMaxErrorRetries = Int
4

-- | The default maximum HTTP Authentication attempts we will make for
-- a single request.
defaultMaxAuthAttempts :: Int
defaultMaxAuthAttempts :: Int
defaultMaxAuthAttempts = Int
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 :: Bool
defaultAutoProxyDetect :: Bool
defaultAutoProxyDetect = Bool
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 :: Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ty
req = BrowserAction (HandleStream ty) (URI, Response ty)
-> BrowserAction (HandleStream ty) (URI, Response ty)
forall t a. BrowserAction t a -> BrowserAction t a
nextRequest (BrowserAction (HandleStream ty) (URI, Response ty)
 -> BrowserAction (HandleStream ty) (URI, Response ty))
-> BrowserAction (HandleStream ty) (URI, Response ty)
-> BrowserAction (HandleStream ty) (URI, Response ty)
forall a b. (a -> b) -> a -> b
$ do
  Result (URI, Response ty)
res <- ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal RequestState
initialState Request ty
req
  BrowserEventType -> String -> BrowserAction (HandleStream ty) ()
forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
ResponseFinish (URI -> String
forall a. Show a => a -> String
show (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
req))
  case Result (URI, Response ty)
res of
    Right (URI, Response ty)
r -> (URI, Response ty)
-> BrowserAction (HandleStream ty) (URI, Response ty)
forall (m :: * -> *) a. Monad m => a -> m a
return (URI, Response ty)
r
    Left ConnError
e  -> do
     let errStr :: String
errStr = (String
"Network.Browser.request: Error raised " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConnError -> String
forall a. Show a => a -> String
show ConnError
e)
     String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
err String
errStr
     String -> BrowserAction (HandleStream ty) (URI, Response ty)
forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail String
errStr
 where
  initialState :: RequestState
initialState = RequestState
nullRequestState
  nullVal :: ty
nullVal      = BufferOp ty -> ty
forall a. BufferOp a -> a
buf_empty BufferOp ty
forall bufType. BufferType bufType => BufferOp bufType
bufferOps

-- | Internal helper function, explicitly carrying along per-request 
-- counts.
request' :: HStream ty
         => ty
         -> RequestState
         -> Request ty
         -> BrowserAction (HandleStream ty) (Result (URI,Response ty))
request' :: ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal RequestState
rqState Request ty
rq = do
   let uri :: URI
uri = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rq
   URI -> BrowserAction (HandleStream ty) ()
forall (m :: * -> *). MonadFail m => URI -> m ()
failHTTPS URI
uri
   let uria :: URIAuth
uria = Request ty -> URIAuth
forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq 
     -- add cookies to request
   [Cookie]
cookies <- String -> String -> BrowserAction (HandleStream ty) [Cookie]
forall t. String -> String -> BrowserAction t [Cookie]
getCookiesFor (URIAuth -> String
uriAuthToString URIAuth
uria) (URI -> String
uriPath URI
uri)
{- 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
-}
   Bool
-> BrowserAction (HandleStream ty) ()
-> BrowserAction (HandleStream ty) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Cookie] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cookie]
cookies) 
        (String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String -> BrowserAction (HandleStream ty) ())
-> String -> BrowserAction (HandleStream ty) ()
forall a b. (a -> b) -> a -> b
$ String
"Adding cookies to request.  Cookie names: "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Cookie -> String) -> [Cookie] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cookie -> String
ckName [Cookie]
cookies))
    -- add credentials to request
   Request ty
rq' <- 
    if Bool -> Bool
not (RequestState -> Bool
reqStopOnDeny RequestState
rqState) 
     then Request ty -> BrowserAction (HandleStream ty) (Request ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Request ty
rq 
     else do 
       Maybe Authority
auth <- Request ty -> BrowserAction (HandleStream ty) (Maybe Authority)
forall ty t. Request ty -> BrowserAction t (Maybe Authority)
anticipateChallenge Request ty
rq
       case Maybe Authority
auth of
         Maybe Authority
Nothing -> Request ty -> BrowserAction (HandleStream ty) (Request ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Request ty
rq
         Just Authority
x  -> Request ty -> BrowserAction (HandleStream ty) (Request ty)
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeader HeaderName
HdrAuthorization (Authority -> Request ty -> String
forall ty. Authority -> Request ty -> String
withAuthority Authority
x Request ty
rq) Request ty
rq)
   let rq'' :: Request ty
rq'' = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Cookie] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cookie]
cookies then [Header] -> Request ty -> Request ty
forall a. HasHeaders a => [Header] -> a -> a
insertHeaders [[Cookie] -> Header
cookiesToHeader [Cookie]
cookies] Request ty
rq' else Request ty
rq'
   Proxy
p <- BrowserAction (HandleStream ty) Proxy
forall t. BrowserAction t Proxy
getProxy
   Maybe String
def_ua <- (BrowserState (HandleStream ty) -> Maybe String)
-> BrowserAction (HandleStream ty) (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState (HandleStream ty) -> Maybe String
forall connection. BrowserState connection -> Maybe String
bsUserAgent
   let defaultOpts :: NormalizeRequestOptions ty
defaultOpts =
         case Proxy
p of 
           Proxy
NoProxy     -> NormalizeRequestOptions ty
forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions{normUserAgent :: Maybe String
normUserAgent=Maybe String
def_ua}
           Proxy String
_ Maybe Authority
ath ->
              NormalizeRequestOptions Any
forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions
                { normForProxy :: Bool
normForProxy  = Bool
True
                , normUserAgent :: Maybe String
normUserAgent = Maybe String
def_ua
                , normCustoms :: [RequestNormalizer ty]
normCustoms   =
                    [RequestNormalizer ty]
-> (Authority -> [RequestNormalizer ty])
-> Maybe Authority
-> [RequestNormalizer ty]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
                          (\ Authority
authS -> [\ NormalizeRequestOptions ty
_ Request ty
r -> HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeader HeaderName
HdrProxyAuthorization (Authority -> Request ty -> String
forall ty. Authority -> Request ty -> String
withAuthority Authority
authS Request ty
r) Request ty
r])
                          Maybe Authority
ath
                }
   let final_req :: Request ty
final_req = NormalizeRequestOptions ty -> Request ty -> Request ty
forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeRequest NormalizeRequestOptions ty
forall ty. NormalizeRequestOptions ty
defaultOpts Request ty
rq''
   String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String
"Sending:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Request ty -> String
forall a. Show a => a -> String
show Request ty
final_req)
   Result (Response ty)
e_rsp <- 
     case Proxy
p of
       Proxy
NoProxy        -> URIAuth
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
forall ty.
HStream ty =>
URIAuth
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
dorequest (Request ty -> URIAuth
forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq'') Request ty
final_req
       Proxy String
str Maybe Authority
_ath -> do
          let notURI :: URIAuth
notURI 
               | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pt Bool -> Bool -> Bool
|| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hst =
                 URIAuth :: String -> String -> String -> URIAuth
URIAuth{ uriUserInfo :: String
uriUserInfo = String
""
                        , uriRegName :: String
uriRegName  = String
str
                        , uriPort :: String
uriPort     = String
""
                        }
               | Bool
otherwise =
                 URIAuth :: String -> String -> String -> URIAuth
URIAuth{ uriUserInfo :: String
uriUserInfo = String
""
                        , uriRegName :: String
uriRegName  = String
hst
                        , uriPort :: String
uriPort     = String
pt
                        }
                  -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it!
                 where (String
hst, String
pt) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char
':'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
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 :: URIAuth
proxyURIAuth =
                URIAuth -> (URI -> URIAuth) -> Maybe URI -> URIAuth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe URIAuth
notURI
                      (\URI
parsed -> URIAuth -> (URIAuth -> URIAuth) -> Maybe URIAuth -> URIAuth
forall b a. b -> (a -> b) -> Maybe a -> b
maybe URIAuth
notURI URIAuth -> URIAuth
forall a. a -> a
id (URI -> Maybe URIAuth
uriAuthority URI
parsed))
                      (String -> Maybe URI
parseURI String
str)

          String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String -> BrowserAction (HandleStream ty) ())
-> String -> BrowserAction (HandleStream ty) ()
forall a b. (a -> b) -> a -> b
$ String
"proxy uri host: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriRegName URIAuth
proxyURIAuth String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", port: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriPort URIAuth
proxyURIAuth
          URIAuth
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
forall ty.
HStream ty =>
URIAuth
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
dorequest URIAuth
proxyURIAuth Request ty
final_req
   Maybe Int
mbMx <- BrowserAction (HandleStream ty) (Maybe Int)
forall t. BrowserAction t (Maybe Int)
getMaxErrorRetries
   case Result (Response ty)
e_rsp of
    Left ConnError
v 
     | (RequestState -> Int
reqRetries RequestState
rqState Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxErrorRetries Maybe Int
mbMx) Bool -> Bool -> Bool
&& 
       (ConnError
v ConnError -> ConnError -> Bool
forall a. Eq a => a -> a -> Bool
== ConnError
ErrorReset Bool -> Bool -> Bool
|| ConnError
v ConnError -> ConnError -> Bool
forall a. Eq a => a -> a -> Bool
== ConnError
ErrorClosed) -> do
       --empty connnection pool in case connection has become invalid
       (BrowserState (HandleStream ty) -> BrowserState (HandleStream ty))
-> BrowserAction (HandleStream ty) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState (HandleStream ty)
b -> BrowserState (HandleStream ty)
b { bsConnectionPool :: [HandleStream ty]
bsConnectionPool=[] })       
       ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal RequestState
rqState{reqRetries :: Int
reqRetries=Int -> Int
forall a. Enum a => a -> a
succ (RequestState -> Int
reqRetries RequestState
rqState)} Request ty
rq
     | Bool
otherwise -> 
       Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result (URI, Response ty)
forall a b. a -> Either a b
Left ConnError
v)
    Right Response ty
rsp -> do 
     String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String
"Received:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Response ty -> String
forall a. Show a => a -> String
show Response ty
rsp)
      -- add new cookies to browser state
     URI -> String -> [Header] -> BrowserAction (HandleStream ty) ()
forall t. URI -> String -> [Header] -> BrowserAction t ()
handleCookies URI
uri (URIAuth -> String
uriAuthToString (URIAuth -> String) -> URIAuth -> String
forall a b. (a -> b) -> a -> b
$ Request ty -> URIAuth
forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq) 
                       (HeaderName -> Response ty -> [Header]
forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrSetCookie Response ty
rsp)
     -- Deal with "Connection: close" in response.
     URIAuth -> [Header] -> BrowserAction (HandleStream ty) ()
forall hTy.
HStream hTy =>
URIAuth -> [Header] -> BrowserAction (HandleStream hTy) ()
handleConnectionClose (Request ty -> URIAuth
forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq) (HeaderName -> Response ty -> [Header]
forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrConnection Response ty
rsp)
     Maybe Int
mbMxAuths <- BrowserAction (HandleStream ty) (Maybe Int)
forall t. BrowserAction t (Maybe Int)
getMaxAuthAttempts
     case Response ty -> ResponseCode
forall a. Response a -> ResponseCode
rspCode Response ty
rsp of
      (Int
4,Int
0,Int
1) -- Credentials not sent or refused.
        | RequestState -> Int
reqDenies RequestState
rqState Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxAuthAttempts Maybe Int
mbMxAuths -> do
          String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out String
"401 - credentials again refused; exceeded retry count (2)"
          Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
        | Bool
otherwise -> do
          String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out String
"401 - credentials not supplied or refused; retrying.."
          let hdrs :: [Header]
hdrs = HeaderName -> Response ty -> [Header]
forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrWWWAuthenticate Response ty
rsp
          Bool
flg <- BrowserAction (HandleStream ty) Bool
forall t. BrowserAction t Bool
getAllowBasicAuth
          case Bool -> [Challenge] -> Maybe Challenge
pickChallenge Bool
flg ([Maybe Challenge] -> [Challenge]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Challenge] -> [Challenge])
-> [Maybe Challenge] -> [Challenge]
forall a b. (a -> b) -> a -> b
$ (Header -> Maybe Challenge) -> [Header] -> [Maybe Challenge]
forall a b. (a -> b) -> [a] -> [b]
map (URI -> Header -> Maybe Challenge
headerToChallenge URI
uri) [Header]
hdrs) of
            Maybe Challenge
Nothing -> do
              String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out String
"no challenge"
              Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))   {- do nothing -}
            Just Challenge
x  -> do
              Maybe Authority
au <- URI
-> Challenge -> BrowserAction (HandleStream ty) (Maybe Authority)
forall t. URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority URI
uri Challenge
x
              case Maybe Authority
au of
                Maybe Authority
Nothing  -> do
                  String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out String
"no auth"
                  Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp)) {- do nothing -}
                Just Authority
au' -> do
                  String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out String
"Retrying request with new credentials"
                  ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal
                           RequestState
rqState{ reqDenies :: Int
reqDenies     = Int -> Int
forall a. Enum a => a -> a
succ(RequestState -> Int
reqDenies RequestState
rqState)
                                  , reqStopOnDeny :: Bool
reqStopOnDeny = Bool
False
                                  }
                           (HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
insertHeader HeaderName
HdrAuthorization (Authority -> Request ty -> String
forall ty. Authority -> Request ty -> String
withAuthority Authority
au' Request ty
rq) Request ty
rq)

      (Int
4,Int
0,Int
7)  -- Proxy Authentication required
        | RequestState -> Int
reqDenies RequestState
rqState Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxAuthAttempts Maybe Int
mbMxAuths -> do
          String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out String
"407 - proxy authentication required; max deny count exceeeded (2)"
          Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
        | Bool
otherwise -> do
          String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out String
"407 - proxy authentication required"
          let hdrs :: [Header]
hdrs = HeaderName -> Response ty -> [Header]
forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrProxyAuthenticate Response ty
rsp
          Bool
flg <- BrowserAction (HandleStream ty) Bool
forall t. BrowserAction t Bool
getAllowBasicAuth
          case Bool -> [Challenge] -> Maybe Challenge
pickChallenge Bool
flg ([Maybe Challenge] -> [Challenge]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Challenge] -> [Challenge])
-> [Maybe Challenge] -> [Challenge]
forall a b. (a -> b) -> a -> b
$ (Header -> Maybe Challenge) -> [Header] -> [Maybe Challenge]
forall a b. (a -> b) -> [a] -> [b]
map (URI -> Header -> Maybe Challenge
headerToChallenge URI
uri) [Header]
hdrs) of
            Maybe Challenge
Nothing -> Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))   {- do nothing -}
            Just Challenge
x  -> do
              Maybe Authority
au <- URI
-> Challenge -> BrowserAction (HandleStream ty) (Maybe Authority)
forall t. URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority URI
uri Challenge
x
              case Maybe Authority
au of
               Maybe Authority
Nothing  -> Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))  {- do nothing -}
               Just Authority
au' -> do
                 Proxy
pxy <- (BrowserState (HandleStream ty) -> Proxy)
-> BrowserAction (HandleStream ty) Proxy
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState (HandleStream ty) -> Proxy
forall connection. BrowserState connection -> Proxy
bsProxy
                 case Proxy
pxy of
                   Proxy
NoProxy -> do
                     String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
err String
"Proxy authentication required without proxy!"
                     Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
                   Proxy String
px Maybe Authority
_ -> do
                     String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out String
"Retrying with proxy authentication"
                     Proxy -> BrowserAction (HandleStream ty) ()
forall t. Proxy -> BrowserAction t ()
setProxy (String -> Maybe Authority -> Proxy
Proxy String
px (Authority -> Maybe Authority
forall a. a -> Maybe a
Just Authority
au'))
                     ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal
                              RequestState
rqState{ reqDenies :: Int
reqDenies     = Int -> Int
forall a. Enum a => a -> a
succ(RequestState -> Int
reqDenies RequestState
rqState)
                                     , reqStopOnDeny :: Bool
reqStopOnDeny = Bool
False
                                     }
                              Request ty
rq

      (Int
3,Int
0,Int
x) | Int
x Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
2,Int
3,Int
1,Int
7]  ->  do
        String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String
"30" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
" - redirect")
        Bool
allow_redirs <- RequestState -> BrowserAction (HandleStream ty) Bool
forall t. RequestState -> BrowserAction t Bool
allowRedirect RequestState
rqState
        case Bool
allow_redirs of
          Bool
False -> Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
          Bool
_ -> do
           case HeaderName -> Response ty -> [Header]
forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrLocation Response ty
rsp of
            [] -> do 
              String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
err String
"No Location: header in redirect response"
              Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
            (Header HeaderName
_ String
u:[Header]
_) -> 
              case String -> Maybe URI
parseURIReference String
u of
                Maybe URI
Nothing -> do
                  String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
err (String
"Parse of Location: header in a redirect response failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u)
                  Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
                Just URI
newURI
                 | {-uriScheme newURI_abs /= uriScheme uri && -}(Bool -> Bool
not (URI -> Bool
supportedScheme URI
newURI_abs)) -> do
                    String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
err (String
"Unable to handle redirect, unsupported scheme: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
newURI_abs)
                    Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri, Response ty
rsp))
                 | Bool
otherwise -> do
                    String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String
"Redirecting to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
newURI_abs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ...")
                    
                    -- Redirect using GET request method, depending on
                    -- response code.
                    let toGet :: Bool
toGet = Int
x Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
2,Int
3]
                        method :: RequestMethod
method = if Bool
toGet then RequestMethod
GET else Request ty -> RequestMethod
forall a. Request a -> RequestMethod
rqMethod Request ty
rq
                        rq1 :: Request ty
rq1 = Request ty
rq { rqMethod :: RequestMethod
rqMethod=RequestMethod
method, rqURI :: URI
rqURI=URI
newURI_abs }
                        rq2 :: Request ty
rq2 = if Bool
toGet then (HeaderSetter (Request ty)
forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrContentLength String
"0") (Request ty
rq1 {rqBody :: ty
rqBody = ty
nullVal}) else Request ty
rq1
                    
                    ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal
                            RequestState
rqState{ reqDenies :: Int
reqDenies     = Int
0
                                   , reqRedirects :: Int
reqRedirects  = Int -> Int
forall a. Enum a => a -> a
succ(RequestState -> Int
reqRedirects RequestState
rqState)
                                   , reqStopOnDeny :: Bool
reqStopOnDeny = Bool
True
                                   }
                             Request ty
rq2
                 where
                   newURI_abs :: URI
newURI_abs = URI -> URI -> URI
uriDefaultTo URI
newURI URI
uri

      (Int
3,Int
0,Int
5) ->
        case HeaderName -> Response ty -> [Header]
forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrLocation Response ty
rsp of
         [] -> do 
           String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
err String
"No Location header in proxy redirect response."
           Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
         (Header HeaderName
_ String
u:[Header]
_) -> 
           case String -> Maybe URI
parseURIReference String
u of
            Maybe URI
Nothing -> do
             String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
err (String
"Parse of Location header in a proxy redirect response failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u)
             Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
            Just URI
newuri -> do
             String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String
"Retrying with proxy " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
newuri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"...")
             Proxy -> BrowserAction (HandleStream ty) ()
forall t. Proxy -> BrowserAction t ()
setProxy (String -> Maybe Authority -> Proxy
Proxy (URI -> String
uriToAuthorityString URI
newuri) Maybe Authority
forall a. Maybe a
Nothing)
             ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal RequestState
rqState{ reqDenies :: Int
reqDenies     = Int
0
                                     , reqRedirects :: Int
reqRedirects  = Int
0
                                     , reqRetries :: Int
reqRetries    = Int -> Int
forall a. Enum a => a -> a
succ (RequestState -> Int
reqRetries RequestState
rqState)
                                     , reqStopOnDeny :: Bool
reqStopOnDeny = Bool
True
                                     }
                                     Request ty
rq
      ResponseCode
_       -> Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return ((URI, Response ty) -> Result (URI, Response ty)
forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))

-- | The internal request handling state machine.
dorequest :: (HStream ty)
          => URIAuth
          -> Request ty
          -> BrowserAction (HandleStream ty)
                           (Result (Response ty))
dorequest :: URIAuth
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
dorequest URIAuth
hst Request ty
rqst = do
  [HandleStream ty]
pool <- (BrowserState (HandleStream ty) -> [HandleStream ty])
-> BrowserAction (HandleStream ty) [HandleStream ty]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState (HandleStream ty) -> [HandleStream ty]
forall connection. BrowserState connection -> [connection]
bsConnectionPool
  let uPort :: Int
uPort = Maybe URI -> URIAuth -> Int
uriAuthPort Maybe URI
forall a. Maybe a
Nothing{-ToDo: feed in complete URL-} URIAuth
hst
  [HandleStream ty]
conn <- IO [HandleStream ty]
-> BrowserAction (HandleStream ty) [HandleStream ty]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [HandleStream ty]
 -> BrowserAction (HandleStream ty) [HandleStream ty])
-> IO [HandleStream ty]
-> BrowserAction (HandleStream ty) [HandleStream ty]
forall a b. (a -> b) -> a -> b
$ (HandleStream ty -> IO Bool)
-> [HandleStream ty] -> IO [HandleStream ty]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\HandleStream ty
c -> HandleStream ty
c HandleStream ty -> EndPoint -> IO Bool
forall ty. HandleStream ty -> EndPoint -> IO Bool
`isTCPConnectedTo` String -> Int -> EndPoint
EndPoint (URIAuth -> String
uriRegName URIAuth
hst) Int
uPort) [HandleStream ty]
pool
  Result (Response ty)
rsp <- 
    case [HandleStream ty]
conn of
      [] -> do 
        String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String
"Creating new connection to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriAuthToString URIAuth
hst)
        BrowserEventType -> String -> BrowserAction (HandleStream ty) ()
forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
OpenConnection (URI -> String
forall a. Show a => a -> String
show (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rqst))
        HandleStream ty
c <- IO (HandleStream ty)
-> BrowserAction (HandleStream ty) (HandleStream ty)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HandleStream ty)
 -> BrowserAction (HandleStream ty) (HandleStream ty))
-> IO (HandleStream ty)
-> BrowserAction (HandleStream ty) (HandleStream ty)
forall a b. (a -> b) -> a -> b
$ String -> Int -> IO (HandleStream ty)
forall bufType.
HStream bufType =>
String -> Int -> IO (HandleStream bufType)
openStream (URIAuth -> String
uriRegName URIAuth
hst) Int
uPort
        HandleStream ty -> BrowserAction (HandleStream ty) ()
forall hTy.
HStream hTy =>
HandleStream hTy -> BrowserAction (HandleStream hTy) ()
updateConnectionPool HandleStream ty
c
        HandleStream ty
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
forall conn (m :: * -> *) a.
(MonadState (BrowserState conn) m, MonadIO m, HStream a) =>
HandleStream a -> Request a -> m (Result (Response a))
dorequest2 HandleStream ty
c Request ty
rqst
      (HandleStream ty
c:[HandleStream ty]
_) -> do
        String -> BrowserAction (HandleStream ty) ()
forall t. String -> BrowserAction t ()
out (String
"Recovering connection to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriAuthToString URIAuth
hst)
        BrowserEventType -> String -> BrowserAction (HandleStream ty) ()
forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
ReuseConnection (URI -> String
forall a. Show a => a -> String
show (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rqst))
        HandleStream ty
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
forall conn (m :: * -> *) a.
(MonadState (BrowserState conn) m, MonadIO m, HStream a) =>
HandleStream a -> Request a -> m (Result (Response a))
dorequest2 HandleStream ty
c Request ty
rqst
  case Result (Response ty)
rsp of 
     Right (Response ResponseCode
a String
b [Header]
c ty
_) -> 
         BrowserEventType -> String -> BrowserAction (HandleStream ty) ()
forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent (ResponseData -> BrowserEventType
ResponseEnd (ResponseCode
a,String
b,[Header]
c)) (URI -> String
forall a. Show a => a -> String
show (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rqst)) ; Result (Response ty)
_ -> () -> BrowserAction (HandleStream ty) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Result (Response ty)
-> BrowserAction (HandleStream ty) (Result (Response ty))
forall (m :: * -> *) a. Monad m => a -> m a
return Result (Response ty)
rsp
 where
  dorequest2 :: HandleStream a -> Request a -> m (Result (Response a))
dorequest2 HandleStream a
c Request a
r = do
    Maybe String
dbg <- (BrowserState conn -> Maybe String) -> m (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState conn -> Maybe String
forall connection. BrowserState connection -> Maybe String
bsDebug
    BrowserState conn
st  <- m (BrowserState conn)
forall s (m :: * -> *). MonadState s m => m s
get
    let 
     onSendComplete :: IO ()
onSendComplete =
       IO ()
-> ((BrowserEvent -> BrowserAction conn ()) -> IO ())
-> Maybe (BrowserEvent -> BrowserAction conn ())
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
             (\BrowserEvent -> BrowserAction conn ()
evh -> do
                BrowserEvent
x <- BrowserEventType -> String -> Int -> IO BrowserEvent
buildBrowserEvent BrowserEventType
RequestSent (URI -> String
forall a. Show a => a -> String
show (Request a -> URI
forall a. Request a -> URI
rqURI Request a
r)) (BrowserState conn -> Int
forall connection. BrowserState connection -> Int
bsRequestID BrowserState conn
st)
                BrowserState conn -> BrowserAction conn () -> IO ()
forall conn a. BrowserState conn -> BrowserAction conn a -> IO a
runBA BrowserState conn
st (BrowserEvent -> BrowserAction conn ()
evh BrowserEvent
x)
                () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
             (BrowserState conn -> Maybe (BrowserEvent -> BrowserAction conn ())
forall connection.
BrowserState connection
-> Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent BrowserState conn
st)
    IO (Result (Response a)) -> m (Result (Response a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result (Response a)) -> m (Result (Response a)))
-> IO (Result (Response a)) -> m (Result (Response a))
forall a b. (a -> b) -> a -> b
$ 
      IO (Result (Response a))
-> (String -> IO (Result (Response a)))
-> Maybe String
-> IO (Result (Response a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HandleStream a -> Request a -> IO () -> IO (Result (Response a))
forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
sendHTTP_notify HandleStream a
c Request a
r IO ()
onSendComplete)
            (\ String
f -> do
               HandleStream a
c' <- String -> HandleStream a -> IO (HandleStream a)
forall ty.
HStream ty =>
String -> HandleStream ty -> IO (HandleStream ty)
debugByteStream (String
fString -> String -> String
forall a. [a] -> [a] -> [a]
++Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
: URIAuth -> String
uriAuthToString URIAuth
hst) HandleStream a
c
               HandleStream a -> Request a -> IO () -> IO (Result (Response a))
forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
sendHTTP_notify HandleStream a
c' Request a
r IO ()
onSendComplete)
            Maybe String
dbg

updateConnectionPool :: HStream hTy
                     => HandleStream hTy
                     -> BrowserAction (HandleStream hTy) ()
updateConnectionPool :: HandleStream hTy -> BrowserAction (HandleStream hTy) ()
updateConnectionPool HandleStream hTy
c = do
   [HandleStream hTy]
pool <- (BrowserState (HandleStream hTy) -> [HandleStream hTy])
-> BrowserAction (HandleStream hTy) [HandleStream hTy]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState (HandleStream hTy) -> [HandleStream hTy]
forall connection. BrowserState connection -> [connection]
bsConnectionPool
   let len_pool :: Int
len_pool = [HandleStream hTy] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HandleStream hTy]
pool
   Int
maxPoolSize <- Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxPoolSize (Maybe Int -> Int)
-> BrowserAction (HandleStream hTy) (Maybe Int)
-> BrowserAction (HandleStream hTy) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BrowserState (HandleStream hTy) -> Maybe Int)
-> BrowserAction (HandleStream hTy) (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState (HandleStream hTy) -> Maybe Int
forall connection. BrowserState connection -> Maybe Int
bsMaxPoolSize
   Bool
-> BrowserAction (HandleStream hTy) ()
-> BrowserAction (HandleStream hTy) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len_pool Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxPoolSize)
        (IO () -> BrowserAction (HandleStream hTy) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BrowserAction (HandleStream hTy) ())
-> IO () -> BrowserAction (HandleStream hTy) ()
forall a b. (a -> b) -> a -> b
$ HandleStream hTy -> IO ()
forall bufType. HStream bufType => HandleStream bufType -> IO ()
close ([HandleStream hTy] -> HandleStream hTy
forall a. [a] -> a
last [HandleStream hTy]
pool))
   let pool' :: [HandleStream hTy]
pool' 
        | Int
len_pool Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxPoolSize = [HandleStream hTy] -> [HandleStream hTy]
forall a. [a] -> [a]
init [HandleStream hTy]
pool
        | Bool
otherwise              = [HandleStream hTy]
pool
   Bool
-> BrowserAction (HandleStream hTy) ()
-> BrowserAction (HandleStream hTy) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
maxPoolSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (BrowserAction (HandleStream hTy) ()
 -> BrowserAction (HandleStream hTy) ())
-> BrowserAction (HandleStream hTy) ()
-> BrowserAction (HandleStream hTy) ()
forall a b. (a -> b) -> a -> b
$ (BrowserState (HandleStream hTy)
 -> BrowserState (HandleStream hTy))
-> BrowserAction (HandleStream hTy) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState (HandleStream hTy)
b -> BrowserState (HandleStream hTy)
b { bsConnectionPool :: [HandleStream hTy]
bsConnectionPool=HandleStream hTy
cHandleStream hTy -> [HandleStream hTy] -> [HandleStream hTy]
forall a. a -> [a] -> [a]
:[HandleStream hTy]
pool' })
   () -> BrowserAction (HandleStream hTy) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             
-- | Default maximum number of open connections we are willing to have active.
defaultMaxPoolSize :: Int
defaultMaxPoolSize :: Int
defaultMaxPoolSize = Int
5

cleanConnectionPool :: HStream hTy
                    => URIAuth -> BrowserAction (HandleStream hTy) ()
cleanConnectionPool :: URIAuth -> BrowserAction (HandleStream hTy) ()
cleanConnectionPool URIAuth
uri = do
  let ep :: EndPoint
ep = String -> Int -> EndPoint
EndPoint (URIAuth -> String
uriRegName URIAuth
uri) (Maybe URI -> URIAuth -> Int
uriAuthPort Maybe URI
forall a. Maybe a
Nothing URIAuth
uri)
  [HandleStream hTy]
pool <- (BrowserState (HandleStream hTy) -> [HandleStream hTy])
-> BrowserAction (HandleStream hTy) [HandleStream hTy]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState (HandleStream hTy) -> [HandleStream hTy]
forall connection. BrowserState connection -> [connection]
bsConnectionPool
  [Bool]
bad <- IO [Bool] -> BrowserAction (HandleStream hTy) [Bool]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Bool] -> BrowserAction (HandleStream hTy) [Bool])
-> IO [Bool] -> BrowserAction (HandleStream hTy) [Bool]
forall a b. (a -> b) -> a -> b
$ (HandleStream hTy -> IO Bool) -> [HandleStream hTy] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\HandleStream hTy
c -> HandleStream hTy
c HandleStream hTy -> EndPoint -> IO Bool
forall ty. HandleStream ty -> EndPoint -> IO Bool
`isTCPConnectedTo` EndPoint
ep) [HandleStream hTy]
pool
  let tmp :: [(Bool, HandleStream hTy)]
tmp = [Bool] -> [HandleStream hTy] -> [(Bool, HandleStream hTy)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
bad [HandleStream hTy]
pool
      newpool :: [HandleStream hTy]
newpool = ((Bool, HandleStream hTy) -> HandleStream hTy)
-> [(Bool, HandleStream hTy)] -> [HandleStream hTy]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, HandleStream hTy) -> HandleStream hTy
forall a b. (a, b) -> b
snd ([(Bool, HandleStream hTy)] -> [HandleStream hTy])
-> [(Bool, HandleStream hTy)] -> [HandleStream hTy]
forall a b. (a -> b) -> a -> b
$ ((Bool, HandleStream hTy) -> Bool)
-> [(Bool, HandleStream hTy)] -> [(Bool, HandleStream hTy)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Bool, HandleStream hTy) -> Bool)
-> (Bool, HandleStream hTy)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, HandleStream hTy) -> Bool
forall a b. (a, b) -> a
fst) [(Bool, HandleStream hTy)]
tmp
      toclose :: [HandleStream hTy]
toclose = ((Bool, HandleStream hTy) -> HandleStream hTy)
-> [(Bool, HandleStream hTy)] -> [HandleStream hTy]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, HandleStream hTy) -> HandleStream hTy
forall a b. (a, b) -> b
snd ([(Bool, HandleStream hTy)] -> [HandleStream hTy])
-> [(Bool, HandleStream hTy)] -> [HandleStream hTy]
forall a b. (a -> b) -> a -> b
$ ((Bool, HandleStream hTy) -> Bool)
-> [(Bool, HandleStream hTy)] -> [(Bool, HandleStream hTy)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, HandleStream hTy) -> Bool
forall a b. (a, b) -> a
fst [(Bool, HandleStream hTy)]
tmp
  IO () -> BrowserAction (HandleStream hTy) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> BrowserAction (HandleStream hTy) ())
-> IO () -> BrowserAction (HandleStream hTy) ()
forall a b. (a -> b) -> a -> b
$ [HandleStream hTy] -> (HandleStream hTy -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [HandleStream hTy]
toclose HandleStream hTy -> IO ()
forall bufType. HStream bufType => HandleStream bufType -> IO ()
close
  (BrowserState (HandleStream hTy)
 -> BrowserState (HandleStream hTy))
-> BrowserAction (HandleStream hTy) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState (HandleStream hTy)
b -> BrowserState (HandleStream hTy)
b { bsConnectionPool :: [HandleStream hTy]
bsConnectionPool = [HandleStream hTy]
newpool })

handleCookies :: URI -> String -> [Header] -> BrowserAction t ()
handleCookies :: URI -> String -> [Header] -> BrowserAction t ()
handleCookies URI
_   String
_              [] = () -> BrowserAction t ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- cut short the silliness.
handleCookies URI
uri String
dom [Header]
cookieHeaders = do
  Bool -> BrowserAction t () -> BrowserAction t ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs)
       (String -> BrowserAction t ()
forall t. String -> BrowserAction t ()
err (String -> BrowserAction t ()) -> String -> BrowserAction t ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines (String
"Errors parsing these cookie values: "String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
errs))
  Bool -> BrowserAction t () -> BrowserAction t ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Cookie] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cookie]
newCookies)
       (String -> BrowserAction t ()
forall t. String -> BrowserAction t ()
out (String -> BrowserAction t ()) -> String -> BrowserAction t ()
forall a b. (a -> b) -> a -> b
$ (String -> Cookie -> String) -> String -> [Cookie] -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String
x Cookie
y -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cookie -> String
forall a. Show a => a -> String
show Cookie
y) String
"Cookies received:" [Cookie]
newCookies)
  URI -> Cookie -> IO Bool
filterfn    <- BrowserAction t (URI -> Cookie -> IO Bool)
forall t. BrowserAction t (URI -> Cookie -> IO Bool)
getCookieFilter
  [Cookie]
newCookies' <- IO [Cookie] -> BrowserAction t [Cookie]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Cookie -> IO Bool) -> [Cookie] -> IO [Cookie]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (URI -> Cookie -> IO Bool
filterfn URI
uri) [Cookie]
newCookies)
  Bool -> BrowserAction t () -> BrowserAction t ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Cookie] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cookie]
newCookies')
       (String -> BrowserAction t ()
forall t. String -> BrowserAction t ()
out (String -> BrowserAction t ()) -> String -> BrowserAction t ()
forall a b. (a -> b) -> a -> b
$ String
"Accepting cookies with names: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Cookie -> String) -> [Cookie] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cookie -> String
ckName [Cookie]
newCookies'))
  (Cookie -> BrowserAction t ()) -> [Cookie] -> BrowserAction t ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Cookie -> BrowserAction t ()
forall t. Cookie -> BrowserAction t ()
addCookie [Cookie]
newCookies'
 where
  ([String]
errs, [Cookie]
newCookies) = String -> [Header] -> ([String], [Cookie])
processCookieHeaders String
dom [Header]
cookieHeaders

handleConnectionClose :: HStream hTy
                      => URIAuth -> [Header]
                      -> BrowserAction (HandleStream hTy) ()
handleConnectionClose :: URIAuth -> [Header] -> BrowserAction (HandleStream hTy) ()
handleConnectionClose URIAuth
_ [] = () -> BrowserAction (HandleStream hTy) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleConnectionClose URIAuth
uri [Header]
headers = do
  let doClose :: Bool
doClose = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"close") ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ (Header -> String) -> [Header] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Header -> String
headerToConnType [Header]
headers
  Bool
-> BrowserAction (HandleStream hTy) ()
-> BrowserAction (HandleStream hTy) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doClose (BrowserAction (HandleStream hTy) ()
 -> BrowserAction (HandleStream hTy) ())
-> BrowserAction (HandleStream hTy) ()
-> BrowserAction (HandleStream hTy) ()
forall a b. (a -> b) -> a -> b
$ URIAuth -> BrowserAction (HandleStream hTy) ()
forall hTy.
HStream hTy =>
URIAuth -> BrowserAction (HandleStream hTy) ()
cleanConnectionPool URIAuth
uri
  where headerToConnType :: Header -> String
headerToConnType (Header HeaderName
_ String
t) = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
t

------------------------------------------------------------------
----------------------- Miscellaneous ----------------------------
------------------------------------------------------------------

allowRedirect :: RequestState -> BrowserAction t Bool
allowRedirect :: RequestState -> BrowserAction t Bool
allowRedirect RequestState
rqState = do
  Bool
rd <- BrowserAction t Bool
forall t. BrowserAction t Bool
getAllowRedirects
  Maybe Int
mbMxRetries <- BrowserAction t (Maybe Int)
forall t. BrowserAction t (Maybe Int)
getMaxRedirects
  Bool -> BrowserAction t Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
rd Bool -> Bool -> Bool
&& (RequestState -> Int
reqRedirects RequestState
rqState Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxRetries Maybe Int
mbMxRetries))

-- | Return @True@ iff the package is able to handle requests and responses
-- over it.
supportedScheme :: URI -> Bool
supportedScheme :: URI -> Bool
supportedScheme URI
u = URI -> String
uriScheme URI
u String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"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 :: URI -> URI -> URI
uriDefaultTo URI
a URI
b = URI
a URI -> URI -> URI
`relativeTo` URI
b
#else
uriDefaultTo a b = maybe a id (a `relativeTo` b)
#endif


-- This form junk is completely untested...

type FormVar = (String,String)

data Form = Form RequestMethod URI [FormVar]

formToRequest :: Form -> Request_String
formToRequest :: Form -> Request_String
formToRequest (Form RequestMethod
m URI
u [(String, String)]
vs) =
    let enc :: String
enc = [(String, String)] -> String
urlEncodeVars [(String, String)]
vs
    in case RequestMethod
m of
        RequestMethod
GET -> Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request { rqMethod :: RequestMethod
rqMethod=RequestMethod
GET
                       , rqHeaders :: [Header]
rqHeaders=[ HeaderName -> String -> Header
Header HeaderName
HdrContentLength String
"0" ]
                       , rqBody :: String
rqBody=String
""
                       , rqURI :: URI
rqURI=URI
u { uriQuery :: String
uriQuery= Char
'?' Char -> String -> String
forall a. a -> [a] -> [a]
: String
enc }  -- What about old query?
                       }
        RequestMethod
POST -> Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request { rqMethod :: RequestMethod
rqMethod=RequestMethod
POST
                        , rqHeaders :: [Header]
rqHeaders=[ HeaderName -> String -> Header
Header HeaderName
HdrContentType String
"application/x-www-form-urlencoded",
                                      HeaderName -> String -> Header
Header HeaderName
HdrContentLength (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
enc) ]
                        , rqBody :: String
rqBody=String
enc
                        , rqURI :: URI
rqURI=URI
u
                        }
        RequestMethod
_ -> String -> Request_String
forall a. HasCallStack => String -> a
error (String
"unexpected request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RequestMethod -> String
forall a. Show a => a -> String
show RequestMethod
m)