{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-}
module Network.Browser
( BrowserState
, BrowserAction
, Proxy(..)
, browse
, request
, getBrowserState
, withBrowserState
, setAllowRedirects
, getAllowRedirects
, setMaxRedirects
, getMaxRedirects
, Authority(..)
, getAuthorities
, setAuthorities
, addAuthority
, Challenge(..)
, Qop(..)
, Algorithm(..)
, getAuthorityGen
, setAuthorityGen
, setAllowBasicAuth
, getAllowBasicAuth
, setMaxErrorRetries
, getMaxErrorRetries
, setMaxPoolSize
, getMaxPoolSize
, setMaxAuthAttempts
, getMaxAuthAttempts
, setCookieFilter
, getCookieFilter
, defaultCookieFilter
, userCookieFilter
, Cookie(..)
, getCookies
, setCookies
, addCookie
, setErrHandler
, setOutHandler
, setEventHandler
, BrowserEvent(..)
, BrowserEventType(..)
, RequestID
, setProxy
, getProxy
, setCheckForProxy
, getCheckForProxy
, setDebugLog
, getUserAgent
, setUserAgent
, out
, err
, ioAction
, defaultGETRequest
, defaultGETRequest_
, formToRequest
, uriDefaultTo
, 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 )
defaultCookieFilter :: URI -> Cookie -> IO Bool
defaultCookieFilter :: URI -> Cookie -> IO Bool
defaultCookieFilter URI
_url Cookie
_cky = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
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 a. a -> IO a
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]? "
x <- Handle -> IO Char
System.IO.hGetChar Handle
System.IO.stdin
System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering
System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering
return (toLower x == 'y')
addCookie :: Cookie -> BrowserAction t ()
addCookie :: forall t. 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 = c : filter (/=c) (bsCookies b) })
setCookies :: [Cookie] -> BrowserAction t ()
setCookies :: forall t. [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=cs })
getCookies :: BrowserAction t [Cookie]
getCookies :: forall t. 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
getCookiesFor :: String -> String -> BrowserAction t [Cookie]
getCookiesFor :: forall t. String -> String -> BrowserAction t [Cookie]
getCookiesFor String
dom String
path =
do cks <- BrowserAction t [Cookie]
forall t. BrowserAction t [Cookie]
getCookies
return (filter cookiematch cks)
where
cookiematch :: Cookie -> Bool
cookiematch :: Cookie -> Bool
cookiematch = (String, String) -> Cookie -> Bool
cookieMatch (String
dom,String
path)
setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()
setCookieFilter :: forall t. (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=f })
getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool)
getCookieFilter :: forall t. 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
getAuthFor :: String -> String -> BrowserAction t [Authority]
getAuthFor :: forall t. 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 a b.
BrowserAction t a -> (a -> BrowserAction t b) -> BrowserAction t b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Authority] -> BrowserAction t [Authority]
forall a. a -> BrowserAction t a
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 :: BrowserAction t [Authority]
getAuthorities :: forall t. 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 :: [Authority] -> BrowserAction t ()
setAuthorities :: forall t. [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=as })
addAuthority :: Authority -> BrowserAction t ()
addAuthority :: forall t. 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=a:bsAuthorities b })
getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String)))
getAuthorityGen :: forall t.
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 :: (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 = (BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b { bsAuthorityGen=f })
setAllowBasicAuth :: Bool -> BrowserAction t ()
setAllowBasicAuth :: forall t. 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=ba })
getAllowBasicAuth :: BrowserAction t Bool
getAllowBasicAuth :: forall t. 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 :: Maybe Int -> BrowserAction t ()
setMaxAuthAttempts :: forall t. 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 a. a -> BrowserAction t a
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=mb})
getMaxAuthAttempts :: BrowserAction t (Maybe Int)
getMaxAuthAttempts :: forall t. 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 :: Maybe Int -> BrowserAction t ()
setMaxErrorRetries :: forall t. 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 a. a -> BrowserAction t a
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=mb})
getMaxErrorRetries :: BrowserAction t (Maybe Int)
getMaxErrorRetries :: forall t. 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
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
"/")
pickChallenge Bool
_ [Challenge]
ls = [Challenge] -> Maybe Challenge
forall a. [a] -> Maybe a
listToMaybe [Challenge]
ls
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 = Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
rq in
do { 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)
; return (listToMaybe authlist)
}
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) = Maybe Authority -> BrowserAction t (Maybe Authority)
forall a. a -> BrowserAction t a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Authority
forall a. Maybe a
Nothing
| Bool
otherwise = do
prompt <- BrowserAction t (URI -> String -> IO (Maybe (String, String)))
forall t.
BrowserAction t (URI -> String -> IO (Maybe (String, String)))
getAuthorityGen
userdetails <- liftIO $ prompt uri (chRealm ch)
case userdetails of
Maybe (String, String)
Nothing -> Maybe Authority -> BrowserAction t (Maybe Authority)
forall a. a -> BrowserAction t a
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 a. a -> BrowserAction t a
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 { auSite :: URI
auSite=URI
uri
, auRealm :: String
auRealm=String
r
, auUsername :: String
auUsername=String
u
, auPassword :: String
auPassword=String
p
}
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
}
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 { "
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"
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
"} ")
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 -> 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
$cfmap :: forall conn a b.
(a -> b) -> BrowserAction conn a -> BrowserAction conn b
fmap :: forall a b.
(a -> b) -> BrowserAction conn a -> BrowserAction conn b
$c<$ :: forall conn a b. a -> BrowserAction conn b -> BrowserAction conn a
<$ :: forall a b. a -> BrowserAction conn b -> BrowserAction conn a
Functor, Functor (BrowserAction conn)
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)
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
$cpure :: forall conn a. a -> BrowserAction conn a
pure :: forall a. a -> BrowserAction conn a
$c<*> :: forall conn a b.
BrowserAction conn (a -> b)
-> BrowserAction conn a -> BrowserAction conn b
<*> :: forall a b.
BrowserAction conn (a -> b)
-> BrowserAction conn a -> BrowserAction conn b
$cliftA2 :: forall conn a b c.
(a -> b -> c)
-> BrowserAction conn a
-> BrowserAction conn b
-> BrowserAction conn c
liftA2 :: forall a b c.
(a -> b -> c)
-> BrowserAction conn a
-> BrowserAction conn b
-> BrowserAction conn c
$c*> :: forall conn a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
*> :: 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 a
<* :: forall a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn a
Applicative, Applicative (BrowserAction conn)
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)
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
$c>>= :: forall conn a b.
BrowserAction conn a
-> (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
-> BrowserAction conn b -> BrowserAction conn b
>> :: forall a b.
BrowserAction conn a
-> BrowserAction conn b -> BrowserAction conn b
$creturn :: forall conn a. a -> BrowserAction conn a
return :: forall a. a -> BrowserAction conn a
Monad, Monad (BrowserAction conn)
Monad (BrowserAction conn) =>
(forall a. IO a -> BrowserAction conn a)
-> MonadIO (BrowserAction conn)
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
$cliftIO :: forall conn a. IO a -> BrowserAction conn a
liftIO :: forall a. IO a -> BrowserAction conn a
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)
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
$cfail :: forall conn a. String -> BrowserAction conn a
fail :: forall 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 = (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 :: BrowserAction conn a -> IO a
browse :: forall conn a. 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
defaultBrowserState :: BrowserState t
defaultBrowserState :: forall t. BrowserState t
defaultBrowserState = BrowserState t
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
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 a. a -> IO a
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 :: BrowserAction t (BrowserState t)
getBrowserState :: forall conn. BrowserAction conn (BrowserState conn)
getBrowserState = BrowserAction t (BrowserState t)
forall s (m :: * -> *). MonadState s m => m s
get
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 = 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 :: 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 = 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
forall a b. a -> b -> b
`seq` BrowserState connection
st{bsRequestID=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
{-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-}
ioAction :: IO a -> BrowserAction t a
ioAction :: forall a t. IO a -> BrowserAction t a
ioAction = IO a -> BrowserAction t a
forall a. IO a -> BrowserAction t a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
setErrHandler :: (String -> IO ()) -> BrowserAction t ()
setErrHandler :: forall t. (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=h })
setOutHandler :: (String -> IO ()) -> BrowserAction t ()
setOutHandler :: forall t. (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=h })
out, err :: String -> BrowserAction t ()
out :: forall t. String -> BrowserAction t ()
out String
s = do { 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 ; liftIO $ f s }
err :: forall t. String -> BrowserAction t ()
err String
s = do { 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 ; liftIO $ f s }
setAllowRedirects :: Bool -> BrowserAction t ()
setAllowRedirects :: forall t. 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=bl})
getAllowRedirects :: BrowserAction t Bool
getAllowRedirects :: forall t. 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 :: Maybe Int -> BrowserAction t ()
setMaxRedirects :: forall t. 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 a. a -> BrowserAction t a
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=c})
getMaxRedirects :: BrowserAction t (Maybe Int)
getMaxRedirects :: forall t. 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 :: Maybe Int -> BrowserAction t ()
setMaxPoolSize :: forall t. 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=c})
getMaxPoolSize :: BrowserAction t (Maybe Int)
getMaxPoolSize :: forall t. 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 :: Proxy -> BrowserAction t ()
setProxy :: forall t. Proxy -> BrowserAction t ()
setProxy Proxy
p =
(BrowserState t -> BrowserState t) -> BrowserAction t ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\BrowserState t
b -> BrowserState t
b {bsProxy = p, bsCheckProxy=False})
getProxy :: BrowserAction t Proxy
getProxy :: forall t. BrowserAction t Proxy
getProxy = do
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 p of
Proxy{} -> Proxy -> BrowserAction t Proxy
forall a. a -> BrowserAction t a
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
p
NoProxy{} -> do
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 not flg
then return p
else do
np <- liftIO $ fetchProxy True
setProxy np
return np
setCheckForProxy :: Bool -> BrowserAction t ()
setCheckForProxy :: forall t. 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=flg})
getCheckForProxy :: BrowserAction t Bool
getCheckForProxy :: forall t. 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 :: Maybe String -> BrowserAction t ()
setDebugLog :: forall t. 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=v})
setUserAgent :: String -> BrowserAction t ()
setUserAgent :: forall t. 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=Just ua})
getUserAgent :: BrowserAction t String
getUserAgent :: forall t. BrowserAction t String
getUserAgent = do
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
return (maybe defaultUserAgent id n)
data RequestState
= RequestState
{ RequestState -> Int
reqDenies :: Int
, RequestState -> Int
reqRedirects :: Int
, RequestState -> Int
reqRetries :: Int
, RequestState -> Bool
reqStopOnDeny :: Bool
}
type RequestID = Int
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
}
data BrowserEvent
= BrowserEvent
{ BrowserEvent -> UTCTime
browserTimestamp :: UTCTime
, BrowserEvent -> Int
browserRequestID :: RequestID
, BrowserEvent -> String
browserRequestURI :: String
, BrowserEvent -> BrowserEventType
browserEventType :: BrowserEventType
}
data BrowserEventType
= OpenConnection
| ReuseConnection
| RequestSent
| ResponseEnd ResponseData
| ResponseFinish
setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty ()
setEventHandler :: forall ty.
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=mbH})
buildBrowserEvent :: BrowserEventType -> String -> RequestID -> IO BrowserEvent
buildBrowserEvent :: BrowserEventType -> String -> Int -> IO BrowserEvent
buildBrowserEvent BrowserEventType
bt String
uri Int
reqID = do
ct <- IO UTCTime
getCurrentTime
return BrowserEvent
{ browserTimestamp = ct
, browserRequestID = reqID
, browserRequestURI = uri
, browserEventType = bt
}
reportEvent :: BrowserEventType -> String -> BrowserAction t ()
reportEvent :: forall t. BrowserEventType -> String -> BrowserAction t ()
reportEvent BrowserEventType
bt String
uri = do
st <- BrowserAction t (BrowserState t)
forall s (m :: * -> *). MonadState s m => m s
get
case bsEvent st of
Maybe (BrowserEvent -> BrowserAction t ())
Nothing -> () -> BrowserAction t ()
forall a. a -> BrowserAction t a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just BrowserEvent -> BrowserAction t ()
evH -> do
evt <- IO BrowserEvent -> BrowserAction t BrowserEvent
forall a. IO a -> BrowserAction t a
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)
evH evt
defaultMaxRetries :: Int
defaultMaxRetries :: Int
defaultMaxRetries = Int
4
defaultMaxErrorRetries :: Int
defaultMaxErrorRetries :: Int
defaultMaxErrorRetries = Int
4
defaultMaxAuthAttempts :: Int
defaultMaxAuthAttempts :: Int
defaultMaxAuthAttempts = Int
2
defaultAutoProxyDetect :: Bool
defaultAutoProxyDetect :: Bool
defaultAutoProxyDetect = Bool
False
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 = 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
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
reportEvent ResponseFinish (show (rqURI req))
case res of
Right (URI, Response ty)
r -> (URI, Response ty)
-> BrowserAction (HandleStream ty) (URI, Response ty)
forall a. a -> BrowserAction (HandleStream ty) a
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 a. String -> BrowserAction (HandleStream ty) a
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
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 = 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
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)
when (not $ null cookies)
(out $ "Adding cookies to request. Cookie names: " ++ unwords (map ckName cookies))
rq' <-
if not (reqStopOnDeny rqState)
then return rq
else do
auth <- anticipateChallenge rq
case auth of
Maybe Authority
Nothing -> Request ty -> BrowserAction (HandleStream ty) (Request ty)
forall a. a -> BrowserAction (HandleStream ty) a
forall (m :: * -> *) a. Monad m => a -> m a
return Request ty
rq
Just Authority
x -> Request ty -> BrowserAction (HandleStream ty) (Request ty)
forall a. a -> BrowserAction (HandleStream ty) a
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'' = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Cookie] -> Bool
forall a. [a] -> 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'
p <- getProxy
def_ua <- gets bsUserAgent
let defaultOpts =
case Proxy
p of
Proxy
NoProxy -> NormalizeRequestOptions ty
forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions{normUserAgent=def_ua}
Proxy String
_ Maybe Authority
ath ->
NormalizeRequestOptions Any
forall ty. NormalizeRequestOptions ty
defaultNormalizeRequestOptions
{ normForProxy = True
, normUserAgent = def_ua
, normCustoms =
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])
ath
}
let 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''
out ("Sending:\n" ++ show final_req)
e_rsp <-
case 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pt Bool -> Bool -> Bool
|| String -> Bool
forall a. [a] -> 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
}
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
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
mbMx <- getMaxErrorRetries
case 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
(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=[] })
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=succ (reqRetries rqState)} Request ty
rq
| Bool
otherwise ->
Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall a. a -> BrowserAction (HandleStream ty) a
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)
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)
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)
mbMxAuths <- BrowserAction (HandleStream ty) (Maybe Int)
forall t. BrowserAction t (Maybe Int)
getMaxAuthAttempts
case rspCode rsp of
(Int
4,Int
0,Int
1)
| 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 a. a -> BrowserAction (HandleStream ty) a
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
flg <- BrowserAction (HandleStream ty) Bool
forall t. BrowserAction t Bool
getAllowBasicAuth
case pickChallenge flg (catMaybes $ map (headerToChallenge uri) 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 a. a -> BrowserAction (HandleStream ty) a
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 Challenge
x -> do
au <- URI
-> Challenge -> BrowserAction (HandleStream ty) (Maybe Authority)
forall t. URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority URI
uri Challenge
x
case 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 a. a -> BrowserAction (HandleStream ty) a
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 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 = succ(reqDenies rqState)
, reqStopOnDeny = 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)
| 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 a. a -> BrowserAction (HandleStream ty) a
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
flg <- BrowserAction (HandleStream ty) Bool
forall t. BrowserAction t Bool
getAllowBasicAuth
case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of
Maybe Challenge
Nothing -> Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall a. a -> BrowserAction (HandleStream ty) a
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 Challenge
x -> do
au <- URI
-> Challenge -> BrowserAction (HandleStream ty) (Maybe Authority)
forall t. URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority URI
uri Challenge
x
case au of
Maybe Authority
Nothing -> Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall a. a -> BrowserAction (HandleStream ty) a
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 Authority
au' -> do
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 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 a. a -> BrowserAction (HandleStream ty) a
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 = succ(reqDenies rqState)
, reqStopOnDeny = False
}
Request ty
rq
(Int
3,Int
0,Int
x) | Int
x Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> 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")
allow_redirs <- RequestState -> BrowserAction (HandleStream ty) Bool
forall t. RequestState -> BrowserAction t Bool
allowRedirect RequestState
rqState
case allow_redirs of
Bool
False -> Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall a. a -> BrowserAction (HandleStream ty) a
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 a. a -> BrowserAction (HandleStream ty) a
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 a. a -> BrowserAction (HandleStream ty) a
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
| (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 a. a -> BrowserAction (HandleStream ty) a
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
" ...")
let toGet :: Bool
toGet = Int
x Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> 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=method, rqURI=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 = 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 = 0
, reqRedirects = succ(reqRedirects rqState)
, reqStopOnDeny = 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 a. a -> BrowserAction (HandleStream ty) a
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 a. a -> BrowserAction (HandleStream ty) a
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 = 0
, reqRedirects = 0
, reqRetries = succ (reqRetries rqState)
, reqStopOnDeny = True
}
Request ty
rq
ResponseCode
_ -> Result (URI, Response ty)
-> BrowserAction (HandleStream ty) (Result (URI, Response ty))
forall a. a -> BrowserAction (HandleStream ty) a
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))
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
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 = Maybe URI -> URIAuth -> Int
uriAuthPort Maybe URI
forall a. Maybe a
Nothing URIAuth
hst
conn <- liftIO $ 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) pool
rsp <-
case 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))
c <- IO (HandleStream ty)
-> BrowserAction (HandleStream ty) (HandleStream ty)
forall a. IO a -> BrowserAction (HandleStream ty) a
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
updateConnectionPool c
dorequest2 c 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 {m :: * -> *} {connection} {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 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 a. a -> BrowserAction (HandleStream ty) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
return rsp
where
dorequest2 :: HandleStream ty -> Request ty -> m (Result (Response ty))
dorequest2 HandleStream ty
c Request ty
r = do
dbg <- (BrowserState connection -> Maybe String) -> m (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets BrowserState connection -> Maybe String
forall connection. BrowserState connection -> Maybe String
bsDebug
st <- get
let
onSendComplete =
IO ()
-> ((BrowserEvent -> BrowserAction connection ()) -> IO ())
-> Maybe (BrowserEvent -> BrowserAction connection ())
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\BrowserEvent -> BrowserAction connection ()
evh -> do
x <- BrowserEventType -> String -> Int -> IO BrowserEvent
buildBrowserEvent BrowserEventType
RequestSent (URI -> String
forall a. Show a => a -> String
show (Request ty -> URI
forall a. Request a -> URI
rqURI Request ty
r)) (BrowserState connection -> Int
forall connection. BrowserState connection -> Int
bsRequestID BrowserState connection
st)
runBA st (evh x)
return ())
(BrowserState connection
-> Maybe (BrowserEvent -> BrowserAction connection ())
forall connection.
BrowserState connection
-> Maybe (BrowserEvent -> BrowserAction connection ())
bsEvent BrowserState connection
st)
liftIO $
maybe (sendHTTP_notify c r onSendComplete)
(\ String
f -> do
c' <- String -> HandleStream ty -> IO (HandleStream ty)
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 ty
c
sendHTTP_notify c' r onSendComplete)
dbg
updateConnectionPool :: HStream hTy
=> HandleStream hTy
-> BrowserAction (HandleStream hTy) ()
updateConnectionPool :: forall hTy.
HStream hTy =>
HandleStream hTy -> BrowserAction (HandleStream hTy) ()
updateConnectionPool HandleStream hTy
c = do
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 = [HandleStream hTy] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HandleStream hTy]
pool
maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize
when (len_pool > maxPoolSize)
(liftIO $ close (last pool))
let pool'
| Int
len_pool Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxPoolSize = [HandleStream hTy] -> [HandleStream hTy]
forall a. HasCallStack => [a] -> [a]
init [HandleStream hTy]
pool
| Bool
otherwise = [HandleStream hTy]
pool
when (maxPoolSize > 0) $ modify (\BrowserState (HandleStream hTy)
b -> BrowserState (HandleStream hTy)
b { bsConnectionPool=c:pool' })
return ()
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 Maybe URI
forall a. Maybe a
Nothing URIAuth
uri)
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
bad <- liftIO $ mapM (\HandleStream hTy
c -> HandleStream hTy
c HandleStream hTy -> EndPoint -> IO Bool
forall ty. HandleStream ty -> EndPoint -> IO Bool
`isTCPConnectedTo` EndPoint
ep) pool
let tmp = [Bool] -> [HandleStream hTy] -> [(Bool, HandleStream hTy)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
bad [HandleStream hTy]
pool
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 = ((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
liftIO $ forM_ toclose close
modify (\BrowserState (HandleStream hTy)
b -> BrowserState (HandleStream hTy)
b { bsConnectionPool = newpool })
handleCookies :: URI -> String -> [Header] -> BrowserAction t ()
handleCookies :: forall t. URI -> String -> [Header] -> BrowserAction t ()
handleCookies URI
_ String
_ [] = () -> BrowserAction t ()
forall a. a -> BrowserAction t a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 a. [a] -> 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 a. [a] -> 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 b a. (b -> a -> b) -> b -> [a] -> b
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)
filterfn <- BrowserAction t (URI -> Cookie -> IO Bool)
forall t. BrowserAction t (URI -> Cookie -> IO Bool)
getCookieFilter
newCookies' <- liftIO (filterM (filterfn uri) newCookies)
when (not $ null newCookies')
(out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies'))
mapM_ addCookie 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
_ [] = () -> BrowserAction (HandleStream hTy) ()
forall a. a -> BrowserAction (HandleStream hTy) a
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
allowRedirect :: RequestState -> BrowserAction t Bool
allowRedirect :: forall t. RequestState -> BrowserAction t Bool
allowRedirect RequestState
rqState = do
rd <- BrowserAction t Bool
forall t. BrowserAction t Bool
getAllowRedirects
mbMxRetries <- getMaxRedirects
return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries))
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 :: 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
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= '?' : enc }
}
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 (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> 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)