{-# 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 )
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative (..), (<$>))
#endif
import Control.Monad (filterM, forM_, when)
import Control.Monad.IO.Class
   ( MonadIO (..) )
import Control.Monad.State
   ( MonadState(..), gets, modify, StateT (..), evalStateT, withStateT )

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 = 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: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
url)
       case Cookie -> Maybe String
ckComment Cookie
cky of
          Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just String
x  -> String -> IO ()
putStrLn (String
"Cookie Comment:\n" forall a. [a] -> [a] -> [a]
++ String
x)
       let pth :: String
pth = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Char
'/'forall a. a -> [a] -> [a]
:) (Cookie -> Maybe String
ckPath Cookie
cky)
       String -> IO ()
putStrLn (String
"Domain/Path: " forall a. [a] -> [a] -> [a]
++ Cookie -> String
ckDomain Cookie
cky forall a. [a] -> [a] -> [a]
++ String
pth)
       String -> IO ()
putStrLn (Cookie -> String
ckName Cookie
cky forall a. [a] -> [a] -> [a]
++ Char
'=' 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
       forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Char
toLower Char
x 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 :: forall t. Cookie -> BrowserAction t ()
addCookie Cookie
c = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b{bsCookies :: [Cookie]
bsCookies = Cookie
c forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Cookie
c) (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 :: forall t. [Cookie] -> BrowserAction t ()
setCookies [Cookie]
cs = 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 :: forall t. BrowserAction t [Cookie]
getCookies = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 :: forall t. String -> String -> BrowserAction t [Cookie]
getCookiesFor String
dom String
path =
    do [Cookie]
cks <- forall t. BrowserAction t [Cookie]
getCookies
       forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall t. (URI -> Cookie -> IO Bool) -> BrowserAction t ()
setCookieFilter URI -> Cookie -> IO Bool
f = 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 :: forall t. BrowserAction t (URI -> Cookie -> IO Bool)
getCookieFilter = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 :: forall t. String -> String -> BrowserAction t [Authority]
getAuthFor String
dom String
pth = forall t. BrowserAction t [Authority]
getAuthorities forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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{} = forall (t :: * -> *). Foldable t => t Bool -> Bool
or (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 forall a. Eq a => a -> a -> Bool
== String
dom) Bool -> Bool -> Bool
&& (URI -> String
uriPath URI
s 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 :: forall t. BrowserAction t [Authority]
getAuthorities = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> [Authority]
bsAuthorities

-- @setAuthorities as@ replaces the Browser's known set
-- of 'Authority's to @as@.
setAuthorities :: [Authority] -> BrowserAction t ()
setAuthorities :: forall t. [Authority] -> BrowserAction t ()
setAuthorities [Authority]
as = 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 :: forall t. Authority -> BrowserAction t ()
addAuthority Authority
a = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsAuthorities :: [Authority]
bsAuthorities=Authority
aforall a. a -> [a] -> [a]
: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 :: forall t.
BrowserAction t (URI -> String -> IO (Maybe (String, String)))
getAuthorityGen = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 :: forall t.
(URI -> String -> IO (Maybe (String, String)))
-> BrowserAction t ()
setAuthorityGen URI -> String -> IO (Maybe (String, String))
f = 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 :: forall t. Bool -> BrowserAction t ()
setAllowBasicAuth Bool
ba = 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 :: forall t. BrowserAction t Bool
getAllowBasicAuth = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> Bool
bsAllowBasicAuth

-- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts
-- to do. If @Nothing@, revert to default max.
setMaxAuthAttempts :: Maybe Int -> BrowserAction t ()
setMaxAuthAttempts :: forall t. Maybe Int -> BrowserAction t ()
setMaxAuthAttempts Maybe Int
mb
 | forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
mb forall a. Ord a => a -> a -> Bool
< Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
 | Bool
otherwise          = 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 :: forall t. BrowserAction t (Maybe Int)
getMaxAuthAttempts = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 :: forall t. Maybe Int -> BrowserAction t ()
setMaxErrorRetries Maybe Int
mb
 | forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
mb forall a. Ord a => a -> a -> Bool
< Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
 | Bool
otherwise          = 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 :: forall t. BrowserAction t (Maybe Int)
getMaxErrorRetries = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 = forall a. a -> Maybe a
Just (String -> Challenge
ChalBasic String
"/") -- manufacture a challenge if one missing; more robust.
pickChallenge Bool
_ [Challenge]
ls = forall a. [a] -> Maybe a
listToMaybe [Challenge]
ls

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

-- | Asking the user to respond to a challenge
challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority :: forall t. URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority URI
uri Challenge
ch
 | Bool -> Bool
not (Challenge -> Bool
answerable Challenge
ch) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
 | Bool
otherwise = do
      -- prompt user for authority
    URI -> String -> IO (Maybe (String, String))
prompt <- forall t.
BrowserAction t (URI -> String -> IO (Maybe (String, String)))
getAuthorityGen
    Maybe (String, String)
userdetails <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
     Just (String
u,String
p) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just 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) forall a. Eq a => a -> a -> Bool
== 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 { 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 { 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 { forall connection. BrowserState connection -> String -> IO ()
bsErr, forall connection. BrowserState connection -> String -> IO ()
bsOut      :: String -> IO ()
      , forall connection. BrowserState connection -> [Cookie]
bsCookies         :: [Cookie]
      , forall connection.
BrowserState connection -> URI -> Cookie -> IO Bool
bsCookieFilter    :: URI -> Cookie -> IO Bool
      , forall connection.
BrowserState connection
-> URI -> String -> IO (Maybe (String, String))
bsAuthorityGen    :: URI -> String -> IO (Maybe (String,String))
      , forall connection. BrowserState connection -> [Authority]
bsAuthorities     :: [Authority]
      , forall connection. BrowserState connection -> Bool
bsAllowRedirects  :: Bool
      , forall connection. BrowserState connection -> Bool
bsAllowBasicAuth  :: Bool
      , forall connection. BrowserState connection -> Maybe Int
bsMaxRedirects    :: Maybe Int
      , forall connection. BrowserState connection -> Maybe Int
bsMaxErrorRetries :: Maybe Int
      , forall connection. BrowserState connection -> Maybe Int
bsMaxAuthAttempts :: Maybe Int
      , forall connection. BrowserState connection -> Maybe Int
bsMaxPoolSize     :: Maybe Int
      , forall connection. BrowserState connection -> [connection]
bsConnectionPool  :: [connection]
      , forall connection. BrowserState connection -> Bool
bsCheckProxy      :: Bool
      , forall connection. BrowserState connection -> Proxy
bsProxy           :: Proxy
      , forall connection. BrowserState connection -> Maybe String
bsDebug           :: Maybe String
      , forall connection.
BrowserState connection
-> Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent           :: Maybe (BrowserEvent -> BrowserAction connection ())
      , forall connection. BrowserState connection -> Int
bsRequestID       :: RequestID
      , forall connection. BrowserState connection -> Maybe String
bsUserAgent       :: Maybe String
      }

instance Show (BrowserState t) where
    show :: BrowserState t -> String
show BrowserState t
bs =  String
"BrowserState { "
            forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String -> String
shows (forall connection. BrowserState connection -> [Cookie]
bsCookies BrowserState t
bs) (String
"\n"
           {- ++ show (bsAuthorities bs) ++ "\n"-}
            forall a. [a] -> [a] -> [a]
++ String
"AllowRedirects: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String -> String
shows (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 { forall conn a.
BrowserAction conn a -> StateT (BrowserState conn) IO a
unBA :: StateT (BrowserState conn) IO a }
 deriving
 ( 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
<$ :: forall a b. a -> BrowserAction conn b -> BrowserAction conn a
$c<$ :: forall conn a b. a -> BrowserAction conn b -> BrowserAction conn a
fmap :: forall a b.
(a -> b) -> BrowserAction conn a -> BrowserAction conn b
$cfmap :: forall conn a b.
(a -> b) -> BrowserAction conn a -> BrowserAction conn b
Functor, 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
<* :: forall a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn a
$c<* :: forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn a
*> :: forall a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
$c*> :: forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
liftA2 :: forall a b c.
(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
<*> :: forall a b.
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 :: forall a. a -> BrowserAction conn a
$cpure :: forall conn a. a -> BrowserAction conn a
Applicative, 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 :: forall a. a -> BrowserAction conn a
$creturn :: forall conn a. a -> BrowserAction conn a
>> :: forall a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
$c>> :: forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
>>= :: forall a 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
Monad, 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 :: forall a. IO a -> BrowserAction conn a
$cliftIO :: forall conn a. IO a -> BrowserAction conn a
MonadIO, MonadState (BrowserState conn)
#if MIN_VERSION_base(4,9,0)
 , 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 :: forall a. String -> BrowserAction conn a
$cfail :: forall conn a. String -> BrowserAction conn a
MonadFail
#endif
 )

runBA :: BrowserState conn -> BrowserAction conn a -> IO a
runBA :: forall conn a. BrowserState conn -> BrowserAction conn a -> IO a
runBA BrowserState conn
bs = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT BrowserState conn
bs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall conn a. BrowserAction conn a -> IO a
browse = forall conn a. BrowserState conn -> BrowserAction conn a -> IO a
runBA forall t. BrowserState t
defaultBrowserState

-- | The default browser state has the settings
defaultBrowserState :: BrowserState t
defaultBrowserState :: forall t. BrowserState t
defaultBrowserState = forall t. BrowserState t
res
 where
   res :: BrowserState connection
res = 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
          forall connection. BrowserState connection -> String -> IO ()
bsErr BrowserState connection
res String
"No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing"
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
     , bsAuthorities :: [Authority]
bsAuthorities      = []
     , bsAllowRedirects :: Bool
bsAllowRedirects   = Bool
True
     , bsAllowBasicAuth :: Bool
bsAllowBasicAuth   = Bool
False
     , bsMaxRedirects :: Maybe Int
bsMaxRedirects     = forall a. Maybe a
Nothing
     , bsMaxErrorRetries :: Maybe Int
bsMaxErrorRetries  = forall a. Maybe a
Nothing
     , bsMaxAuthAttempts :: Maybe Int
bsMaxAuthAttempts  = forall a. Maybe a
Nothing
     , bsMaxPoolSize :: Maybe Int
bsMaxPoolSize      = forall a. Maybe a
Nothing
     , bsConnectionPool :: [connection]
bsConnectionPool   = []
     , bsCheckProxy :: Bool
bsCheckProxy       = Bool
defaultAutoProxyDetect
     , bsProxy :: Proxy
bsProxy            = Proxy
noProxy
     , bsDebug :: Maybe String
bsDebug            = forall a. Maybe a
Nothing
     , bsEvent :: Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent            = forall a. Maybe a
Nothing
     , bsRequestID :: Int
bsRequestID        = Int
0
     , bsUserAgent :: Maybe String
bsUserAgent        = 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 :: forall conn. BrowserAction conn (BrowserState conn)
getBrowserState = 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 :: forall t a.
BrowserState t -> BrowserAction t a -> BrowserAction t a
withBrowserState BrowserState t
bs = forall conn a.
StateT (BrowserState conn) IO a -> BrowserAction conn a
BA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. (s -> s) -> StateT s m a -> StateT s m a
withStateT (forall a b. a -> b -> a
const BrowserState t
bs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall t a. 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 = forall a. Enum a => a -> a
succ (forall connection. BrowserState connection -> Int
bsRequestID BrowserState connection
st)
       in
       Int
rid seq :: forall a b. a -> b -> b
`seq` BrowserState connection
st{bsRequestID :: Int
bsRequestID=Int
rid}
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify 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 :: forall a t. IO a -> BrowserAction t a
ioAction = 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 :: forall t. (String -> IO ()) -> BrowserAction t ()
setErrHandler String -> IO ()
h = 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 :: forall t. (String -> IO ()) -> BrowserAction t ()
setOutHandler String -> IO ()
h = 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 :: forall t. String -> BrowserAction t ()
out String
s = do { String -> IO ()
f <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> String -> IO ()
bsOut ; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
f String
s }
err :: forall t. String -> BrowserAction t ()
err String
s = do { String -> IO ()
f <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> String -> IO ()
bsErr ; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 :: forall t. Bool -> BrowserAction t ()
setAllowRedirects Bool
bl = 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 :: forall t. BrowserAction t Bool
getAllowRedirects = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> Bool
bsAllowRedirects

-- | @setMaxRedirects maxCount@ sets the maximum 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 :: forall t. Maybe Int -> BrowserAction t ()
setMaxRedirects Maybe Int
c
 | forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
c forall a. Ord a => a -> a -> Bool
< Int
0  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
 | Bool
otherwise          = 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 :: forall t. BrowserAction t (Maybe Int)
getMaxRedirects = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 :: forall t. Maybe Int -> BrowserAction t ()
setMaxPoolSize Maybe Int
c = 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 :: forall t. BrowserAction t (Maybe Int)
getMaxPoolSize = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 :: forall t. Proxy -> BrowserAction t ()
setProxy Proxy
p =
   -- Note: if user _explicitly_ sets the proxy, we turn
   -- off any auto-detection of proxies.
  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 :: forall t. BrowserAction t Proxy
getProxy = do
  Proxy
p <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
p
    NoProxy{} -> do
     Bool
flg <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> Bool
bsCheckProxy
     if Bool -> Bool
not Bool
flg
      then forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
p
      else do
       Proxy
np <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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.
       forall t. Proxy -> BrowserAction t ()
setProxy Proxy
np
       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 :: forall t. Bool -> BrowserAction t ()
setCheckForProxy Bool
flg = 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 :: forall t. BrowserAction t Bool
getCheckForProxy = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 :: forall t. Maybe String -> BrowserAction t ()
setDebugLog Maybe String
v = 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
-- compatibility quirks. This version is available via 'httpPackageVersion'.
-- For more info see <http://en.wikipedia.org/wiki/User_agent>.
--
setUserAgent :: String -> BrowserAction t ()
setUserAgent :: forall t. String -> BrowserAction t ()
setUserAgent String
ua = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b{bsUserAgent :: Maybe String
bsUserAgent=forall a. a -> Maybe a
Just String
ua})

-- | @getUserAgent@ returns the current @User-Agent:@ default string.
getUserAgent :: BrowserAction t String
getUserAgent :: forall t. BrowserAction t String
getUserAgent  = do
  Maybe String
n <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> Maybe String
bsUserAgent
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
defaultUserAgent 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
      { 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 :: forall ty.
Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty ()
setEventHandler Maybe (BrowserEvent -> BrowserAction ty ())
mbH = 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
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
bt String
uri = do
  BrowserState t
st <- forall s (m :: * -> *). MonadState s m => m s
get
  case forall connection.
BrowserState connection
-> Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent BrowserState t
st of
    Maybe (BrowserEvent -> BrowserAction t ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just BrowserEvent -> BrowserAction t ()
evH -> do
       BrowserEvent
evt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ BrowserEventType -> String -> Int -> IO BrowserEvent
buildBrowserEvent BrowserEventType
bt String
uri (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 :: forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request ty
req = forall t a. BrowserAction t a -> BrowserAction t a
nextRequest forall a b. (a -> b) -> a -> b
$ do
  Result (URI, Response ty)
res <- forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal RequestState
initialState Request ty
req
  forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
ResponseFinish (forall a. Show a => a -> String
show (forall a. Request a -> URI
rqURI Request ty
req))
  case Result (URI, Response ty)
res of
    Right (URI, Response ty)
r -> 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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ConnError
e)
     forall t. String -> BrowserAction t ()
err String
errStr
     forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail String
errStr
 where
  initialState :: RequestState
initialState = RequestState
nullRequestState
  nullVal :: ty
nullVal      = forall a. BufferOp a -> a
buf_empty 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' :: forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal RequestState
rqState Request ty
rq = do
   let uri :: URI
uri = forall a. Request a -> URI
rqURI Request ty
rq
   forall (m :: * -> *). MonadFail m => URI -> m ()
failHTTPS URI
uri
   let uria :: URIAuth
uria = forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq
     -- add cookies to request
   [Cookie]
cookies <- 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
-}
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cookie]
cookies)
        (forall t. String -> BrowserAction t ()
out forall a b. (a -> b) -> a -> b
$ String
"Adding cookies to request.  Cookie names: "  forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (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 forall (m :: * -> *) a. Monad m => a -> m a
return Request ty
rq
     else do
       Maybe Authority
auth <- forall ty t. Request ty -> BrowserAction t (Maybe Authority)
anticipateChallenge Request ty
rq
       case Maybe Authority
auth of
         Maybe Authority
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Request ty
rq
         Just Authority
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. HasHeaders a => HeaderSetter a
insertHeader HeaderName
HdrAuthorization (forall ty. Authority -> Request ty -> String
withAuthority Authority
x Request ty
rq) Request ty
rq)
   let rq'' :: Request ty
rq'' = if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cookie]
cookies then forall a. HasHeaders a => [Header] -> a -> a
insertHeaders [[Cookie] -> Header
cookiesToHeader [Cookie]
cookies] Request ty
rq' else Request ty
rq'
   Proxy
p <- forall t. BrowserAction t Proxy
getProxy
   Maybe String
def_ua <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> Maybe String
bsUserAgent
   let defaultOpts :: NormalizeRequestOptions ty
defaultOpts =
         case Proxy
p of
           Proxy
NoProxy     -> forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions{normUserAgent :: Maybe String
normUserAgent=Maybe String
def_ua}
           Proxy String
_ Maybe Authority
ath ->
              forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions
                { normForProxy :: Bool
normForProxy  = Bool
True
                , normUserAgent :: Maybe String
normUserAgent = Maybe String
def_ua
                , normCustoms :: [RequestNormalizer ty]
normCustoms   =
                    forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
                          (\ Authority
authS -> [\ NormalizeRequestOptions ty
_ Request ty
r -> forall a. HasHeaders a => HeaderSetter a
insertHeader HeaderName
HdrProxyAuthorization (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 = forall ty. NormalizeRequestOptions ty -> Request ty -> Request ty
normalizeRequest forall ty. NormalizeRequestOptions ty
defaultOpts Request ty
rq''
   forall t. String -> BrowserAction t ()
out (String
"Sending:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Request ty
final_req)
   Result (Response ty)
e_rsp <-
     case Proxy
p of
       Proxy
NoProxy        -> forall ty.
HStream ty =>
URIAuth
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
dorequest (forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq'') Request ty
final_req
       Proxy String
str Maybe Authority
_ath -> do
          let notURI :: URIAuth
notURI
               | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pt Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hst =
                 URIAuth{ uriUserInfo :: String
uriUserInfo = String
""
                        , uriRegName :: String
uriRegName  = String
str
                        , uriPort :: String
uriPort     = String
""
                        }
               | Bool
otherwise =
                 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char
':'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 =
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe URIAuth
notURI
                      (\URI
parsed -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe URIAuth
notURI forall a. a -> a
id (URI -> Maybe URIAuth
uriAuthority URI
parsed))
                      (String -> Maybe URI
parseURI String
str)

          forall t. String -> BrowserAction t ()
out forall a b. (a -> b) -> a -> b
$ String
"proxy uri host: " forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriRegName URIAuth
proxyURIAuth forall a. [a] -> [a] -> [a]
++ String
", port: " forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriPort URIAuth
proxyURIAuth
          forall ty.
HStream ty =>
URIAuth
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
dorequest URIAuth
proxyURIAuth Request ty
final_req
   Maybe Int
mbMx <- forall t. BrowserAction t (Maybe Int)
getMaxErrorRetries
   case Result (Response ty)
e_rsp of
    Left ConnError
v
     | (RequestState -> Int
reqRetries RequestState
rqState forall a. Ord a => a -> a -> Bool
< forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxErrorRetries Maybe Int
mbMx) Bool -> Bool -> Bool
&&
       (ConnError
v forall a. Eq a => a -> a -> Bool
== ConnError
ErrorReset Bool -> Bool -> Bool
|| ConnError
v forall a. Eq a => a -> a -> Bool
== ConnError
ErrorClosed) -> do
       --empty connnection pool in case connection has become invalid
       forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState (HandleStream ty)
b -> BrowserState (HandleStream ty)
b { bsConnectionPool :: [HandleStream ty]
bsConnectionPool=[] })
       forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal RequestState
rqState{reqRetries :: Int
reqRetries=forall a. Enum a => a -> a
succ (RequestState -> Int
reqRetries RequestState
rqState)} Request ty
rq
     | Bool
otherwise ->
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left ConnError
v)
    Right Response ty
rsp -> do
     forall t. String -> BrowserAction t ()
out (String
"Received:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Response ty
rsp)
      -- add new cookies to browser state
     forall t. URI -> String -> [Header] -> BrowserAction t ()
handleCookies URI
uri (URIAuth -> String
uriAuthToString forall a b. (a -> b) -> a -> b
$ forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq)
                       (forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrSetCookie Response ty
rsp)
     -- Deal with "Connection: close" in response.
     forall hTy.
HStream hTy =>
URIAuth -> [Header] -> BrowserAction (HandleStream hTy) ()
handleConnectionClose (forall ty. Request ty -> URIAuth
reqURIAuth Request ty
rq) (forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrConnection Response ty
rsp)
     Maybe Int
mbMxAuths <- forall t. BrowserAction t (Maybe Int)
getMaxAuthAttempts
     case 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 forall a. Ord a => a -> a -> Bool
> forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxAuthAttempts Maybe Int
mbMxAuths -> do
          forall t. String -> BrowserAction t ()
out String
"401 - credentials again refused; exceeded retry count (2)"
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
        | Bool
otherwise -> do
          forall t. String -> BrowserAction t ()
out String
"401 - credentials not supplied or refused; retrying.."
          let hdrs :: [Header]
hdrs = forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrWWWAuthenticate Response ty
rsp
          Bool
flg <- forall t. BrowserAction t Bool
getAllowBasicAuth
          case Bool -> [Challenge] -> Maybe Challenge
pickChallenge Bool
flg (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (URI -> Header -> Maybe Challenge
headerToChallenge URI
uri) [Header]
hdrs) of
            Maybe Challenge
Nothing -> do
              forall t. String -> BrowserAction t ()
out String
"no challenge"
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))   {- do nothing -}
            Just Challenge
x  -> do
              Maybe Authority
au <- forall t. URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority URI
uri Challenge
x
              case Maybe Authority
au of
                Maybe Authority
Nothing  -> do
                  forall t. String -> BrowserAction t ()
out String
"no auth"
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp)) {- do nothing -}
                Just Authority
au' -> do
                  forall t. String -> BrowserAction t ()
out String
"Retrying request with new credentials"
                  forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal
                           RequestState
rqState{ reqDenies :: Int
reqDenies     = forall a. Enum a => a -> a
succ(RequestState -> Int
reqDenies RequestState
rqState)
                                  , reqStopOnDeny :: Bool
reqStopOnDeny = Bool
False
                                  }
                           (forall a. HasHeaders a => HeaderSetter a
insertHeader HeaderName
HdrAuthorization (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 forall a. Ord a => a -> a -> Bool
> forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxAuthAttempts Maybe Int
mbMxAuths -> do
          forall t. String -> BrowserAction t ()
out String
"407 - proxy authentication required; max deny count exceeeded (2)"
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
        | Bool
otherwise -> do
          forall t. String -> BrowserAction t ()
out String
"407 - proxy authentication required"
          let hdrs :: [Header]
hdrs = forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrProxyAuthenticate Response ty
rsp
          Bool
flg <- forall t. BrowserAction t Bool
getAllowBasicAuth
          case Bool -> [Challenge] -> Maybe Challenge
pickChallenge Bool
flg (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (URI -> Header -> Maybe Challenge
headerToChallenge URI
uri) [Header]
hdrs) of
            Maybe Challenge
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))   {- do nothing -}
            Just Challenge
x  -> do
              Maybe Authority
au <- forall t. URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority URI
uri Challenge
x
              case Maybe Authority
au of
               Maybe Authority
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))  {- do nothing -}
               Just Authority
au' -> do
                 Proxy
pxy <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> Proxy
bsProxy
                 case Proxy
pxy of
                   Proxy
NoProxy -> do
                     forall t. String -> BrowserAction t ()
err String
"Proxy authentication required without proxy!"
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
                   Proxy String
px Maybe Authority
_ -> do
                     forall t. String -> BrowserAction t ()
out String
"Retrying with proxy authentication"
                     forall t. Proxy -> BrowserAction t ()
setProxy (String -> Maybe Authority -> Proxy
Proxy String
px (forall a. a -> Maybe a
Just Authority
au'))
                     forall ty.
HStream ty =>
ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
request' ty
nullVal
                              RequestState
rqState{ reqDenies :: Int
reqDenies     = 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
2,Int
3,Int
1,Int
7]  ->  do
        forall t. String -> BrowserAction t ()
out (String
"30" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
x forall a. [a] -> [a] -> [a]
++  String
" - redirect")
        Bool
allow_redirs <- forall t. RequestState -> BrowserAction t Bool
allowRedirect RequestState
rqState
        case Bool
allow_redirs of
          Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
          Bool
_ -> do
           case forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrLocation Response ty
rsp of
            [] -> do
              forall t. String -> BrowserAction t ()
err String
"No Location: header in redirect response"
              forall (m :: * -> *) a. Monad m => a -> m a
return (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
                  forall t. String -> BrowserAction t ()
err (String
"Parse of Location: header in a redirect response failed: " forall a. [a] -> [a] -> [a]
++ String
u)
                  forall (m :: * -> *) a. Monad m => a -> m a
return (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
                    forall t. String -> BrowserAction t ()
err (String
"Unable to handle redirect, unsupported scheme: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
newURI_abs)
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri, Response ty
rsp))
                 | Bool
otherwise -> do
                    forall t. String -> BrowserAction t ()
out (String
"Redirecting to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
newURI_abs forall a. [a] -> [a] -> [a]
++ String
" ...")

                    -- Redirect using GET request method, depending on
                    -- response code.
                    let toGet :: Bool
toGet = Int
x 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 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 (forall a. HasHeaders a => HeaderSetter a
replaceHeader HeaderName
HdrContentLength String
"0") (Request ty
rq1 {rqBody :: ty
rqBody = ty
nullVal}) else Request ty
rq1

                    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  = 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 forall a. HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders HeaderName
HdrLocation Response ty
rsp of
         [] -> do
           forall t. String -> BrowserAction t ()
err String
"No Location header in proxy redirect response."
           forall (m :: * -> *) a. Monad m => a -> m a
return (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
             forall t. String -> BrowserAction t ()
err (String
"Parse of Location header in a proxy redirect response failed: " forall a. [a] -> [a] -> [a]
++ String
u)
             forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (URI
uri,Response ty
rsp))
            Just URI
newuri -> do
             forall t. String -> BrowserAction t ()
out (String
"Retrying with proxy " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
newuri forall a. [a] -> [a] -> [a]
++ String
"...")
             forall t. Proxy -> BrowserAction t ()
setProxy (String -> Maybe Authority -> Proxy
Proxy (URI -> String
uriToAuthorityString URI
newuri) forall a. Maybe a
Nothing)
             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    = forall a. Enum a => a -> a
succ (RequestState -> Int
reqRetries RequestState
rqState)
                                     , reqStopOnDeny :: Bool
reqStopOnDeny = Bool
True
                                     }
                                     Request ty
rq
      ResponseCode
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall ty.
HStream ty =>
URIAuth
-> Request ty
-> BrowserAction (HandleStream ty) (Result (Response ty))
dorequest URIAuth
hst Request ty
rqst = do
  [HandleStream ty]
pool <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> [connection]
bsConnectionPool
  let uPort :: Int
uPort = Maybe URI -> URIAuth -> Int
uriAuthPort forall a. Maybe a
Nothing{-ToDo: feed in complete URL-} URIAuth
hst
  [HandleStream ty]
conn <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\HandleStream ty
c -> HandleStream ty
c 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
        forall t. String -> BrowserAction t ()
out (String
"Creating new connection to " forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriAuthToString URIAuth
hst)
        forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
OpenConnection (forall a. Show a => a -> String
show (forall a. Request a -> URI
rqURI Request ty
rqst))
        HandleStream ty
c <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall bufType.
HStream bufType =>
String -> Int -> IO (HandleStream bufType)
openStream (URIAuth -> String
uriRegName URIAuth
hst) Int
uPort
        forall hTy.
HStream hTy =>
HandleStream hTy -> BrowserAction (HandleStream hTy) ()
updateConnectionPool HandleStream ty
c
        forall {connection} {m :: * -> *} {ty}.
(MonadState (BrowserState connection) m, MonadIO m, HStream ty) =>
HandleStream ty -> Request ty -> m (Result (Response ty))
dorequest2 HandleStream ty
c Request ty
rqst
      (HandleStream ty
c:[HandleStream ty]
_) -> do
        forall t. String -> BrowserAction t ()
out (String
"Recovering connection to " forall a. [a] -> [a] -> [a]
++ URIAuth -> String
uriAuthToString URIAuth
hst)
        forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
ReuseConnection (forall a. Show a => a -> String
show (forall a. Request a -> URI
rqURI Request ty
rqst))
        forall {connection} {m :: * -> *} {ty}.
(MonadState (BrowserState connection) m, MonadIO m, HStream ty) =>
HandleStream ty -> Request ty -> m (Result (Response ty))
dorequest2 HandleStream ty
c Request ty
rqst
  case Result (Response ty)
rsp of
     Right (Response ResponseCode
a String
b [Header]
c ty
_) ->
         forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent (ResponseData -> BrowserEventType
ResponseEnd (ResponseCode
a,String
b,[Header]
c)) (forall a. Show a => a -> String
show (forall a. Request a -> URI
rqURI Request ty
rqst)) ; Result (Response ty)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall (m :: * -> *) a. Monad m => a -> m a
return Result (Response ty)
rsp
 where
  dorequest2 :: HandleStream ty -> Request ty -> m (Result (Response ty))
dorequest2 HandleStream ty
c Request ty
r = do
    Maybe String
dbg <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> Maybe String
bsDebug
    BrowserState connection
st  <- forall s (m :: * -> *). MonadState s m => m s
get
    let
     onSendComplete :: IO ()
onSendComplete =
       forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
             (\BrowserEvent -> BrowserAction connection ()
evh -> do
                BrowserEvent
x <- BrowserEventType -> String -> Int -> IO BrowserEvent
buildBrowserEvent BrowserEventType
RequestSent (forall a. Show a => a -> String
show (forall a. Request a -> URI
rqURI Request ty
r)) (forall connection. BrowserState connection -> Int
bsRequestID BrowserState connection
st)
                forall conn a. BrowserState conn -> BrowserAction conn a -> IO a
runBA BrowserState connection
st (BrowserEvent -> BrowserAction connection ()
evh BrowserEvent
x)
                forall (m :: * -> *) a. Monad m => a -> m a
return ())
             (forall connection.
BrowserState connection
-> Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent BrowserState connection
st)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
sendHTTP_notify HandleStream ty
c Request ty
r IO ()
onSendComplete)
            (\ String
f -> do
               HandleStream ty
c' <- forall ty.
HStream ty =>
String -> HandleStream ty -> IO (HandleStream ty)
debugByteStream (String
fforall a. [a] -> [a] -> [a]
++Char
'-'forall a. a -> [a] -> [a]
: URIAuth -> String
uriAuthToString URIAuth
hst) HandleStream ty
c
               forall ty.
HStream ty =>
HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
sendHTTP_notify HandleStream ty
c' Request ty
r IO ()
onSendComplete)
            Maybe String
dbg

updateConnectionPool :: HStream hTy
                     => HandleStream hTy
                     -> BrowserAction (HandleStream hTy) ()
updateConnectionPool :: forall hTy.
HStream hTy =>
HandleStream hTy -> BrowserAction (HandleStream hTy) ()
updateConnectionPool HandleStream hTy
c = do
   [HandleStream hTy]
pool <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> [connection]
bsConnectionPool
   let len_pool :: Int
len_pool = forall (t :: * -> *) a. Foldable t => t a -> Int
length [HandleStream hTy]
pool
   Int
maxPoolSize <- forall a. a -> Maybe a -> a
fromMaybe Int
defaultMaxPoolSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> Maybe Int
bsMaxPoolSize
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len_pool forall a. Ord a => a -> a -> Bool
> Int
maxPoolSize)
        (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall bufType. HStream bufType => HandleStream bufType -> IO ()
close (forall a. [a] -> a
last [HandleStream hTy]
pool))
   let pool' :: [HandleStream hTy]
pool'
        | Int
len_pool forall a. Ord a => a -> a -> Bool
> Int
maxPoolSize = forall a. [a] -> [a]
init [HandleStream hTy]
pool
        | Bool
otherwise              = [HandleStream hTy]
pool
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
maxPoolSize forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState (HandleStream hTy)
b -> BrowserState (HandleStream hTy)
b { bsConnectionPool :: [HandleStream hTy]
bsConnectionPool=HandleStream hTy
cforall a. a -> [a] -> [a]
:[HandleStream hTy]
pool' })
   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 :: forall hTy.
HStream hTy =>
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 forall a. Maybe a
Nothing URIAuth
uri)
  [HandleStream hTy]
pool <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall connection. BrowserState connection -> [connection]
bsConnectionPool
  [Bool]
bad <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\HandleStream hTy
c -> HandleStream hTy
c forall ty. HandleStream ty -> EndPoint -> IO Bool
`isTCPConnectedTo` EndPoint
ep) [HandleStream hTy]
pool
  let tmp :: [(Bool, HandleStream hTy)]
tmp = forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
bad [HandleStream hTy]
pool
      newpool :: [HandleStream hTy]
newpool = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Bool, HandleStream hTy)]
tmp
      toclose :: [HandleStream hTy]
toclose = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> a
fst [(Bool, HandleStream hTy)]
tmp
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [HandleStream hTy]
toclose forall bufType. HStream bufType => HandleStream bufType -> IO ()
close
  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 :: forall t. URI -> String -> [Header] -> BrowserAction t ()
handleCookies URI
_   String
_              [] = forall (m :: * -> *) a. Monad m => a -> m a
return () -- cut short the silliness.
handleCookies URI
uri String
dom [Header]
cookieHeaders = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs)
       (forall t. String -> BrowserAction t ()
err forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines (String
"Errors parsing these cookie values: "forall a. a -> [a] -> [a]
:[String]
errs))
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cookie]
newCookies)
       (forall t. String -> BrowserAction t ()
out forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\String
x Cookie
y -> String
x forall a. [a] -> [a] -> [a]
++ String
"\n  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Cookie
y) String
"Cookies received:" [Cookie]
newCookies)
  URI -> Cookie -> IO Bool
filterfn    <- forall t. BrowserAction t (URI -> Cookie -> IO Bool)
getCookieFilter
  [Cookie]
newCookies' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (URI -> Cookie -> IO Bool
filterfn URI
uri) [Cookie]
newCookies)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cookie]
newCookies')
       (forall t. String -> BrowserAction t ()
out forall a b. (a -> b) -> a -> b
$ String
"Accepting cookies with names: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map Cookie -> String
ckName [Cookie]
newCookies'))
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 :: forall hTy.
HStream hTy =>
URIAuth -> [Header] -> BrowserAction (HandleStream hTy) ()
handleConnectionClose URIAuth
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleConnectionClose URIAuth
uri [Header]
headers = do
  let doClose :: Bool
doClose = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== String
"close") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Header -> String
headerToConnType [Header]
headers
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doClose forall a b. (a -> b) -> a -> b
$ forall hTy.
HStream hTy =>
URIAuth -> BrowserAction (HandleStream hTy) ()
cleanConnectionPool URIAuth
uri
  where headerToConnType :: Header -> String
headerToConnType (Header HeaderName
_ String
t) = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
t

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

allowRedirect :: RequestState -> BrowserAction t Bool
allowRedirect :: forall t. RequestState -> BrowserAction t Bool
allowRedirect RequestState
rqState = do
  Bool
rd <- forall t. BrowserAction t Bool
getAllowRedirects
  Maybe Int
mbMxRetries <- forall t. BrowserAction t (Maybe Int)
getMaxRedirects
  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
rd Bool -> Bool -> Bool
&& (RequestState -> Int
reqRedirects RequestState
rqState forall a. Ord a => a -> a -> Bool
<= 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 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 { 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
'?' forall a. a -> [a] -> [a]
: String
enc }  -- What about old query?
                       }
        RequestMethod
POST -> 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 (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
enc) ]
                        , rqBody :: String
rqBody=String
enc
                        , rqURI :: URI
rqURI=URI
u
                        }
        RequestMethod
_ -> forall a. HasCallStack => String -> a
error (String
"unexpected request: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RequestMethod
m)