module Network.Browser
( BrowserState
, BrowserAction
, Proxy(..)
, browse
, request
, getBrowserState
, withBrowserState
, setAllowRedirects
, getAllowRedirects
, setMaxRedirects
, getMaxRedirects
, Authority(..)
, getAuthorities
, setAuthorities
, addAuthority
, Challenge(..)
, Qop(..)
, Algorithm(..)
, getAuthorityGen
, setAuthorityGen
, setAllowBasicAuth
, setMaxErrorRetries
, getMaxErrorRetries
, setMaxAuthAttempts
, getMaxAuthAttempts
, setCookieFilter
, getCookieFilter
, defaultCookieFilter
, userCookieFilter
, Cookie(..)
, getCookies
, setCookies
, addCookie
, setErrHandler
, setOutHandler
, setEventHandler
, BrowserEvent(..)
, BrowserEventType(..)
, RequestID
, setProxy
, getProxy
, setDebugLog
, out
, err
, ioAction
, defaultGETRequest
, defaultGETRequest_
, formToRequest
, uriDefaultTo
, Form(..)
, FormVar
) where
import Network.URI
( URI(uriAuthority, uriPath, uriQuery)
, URIAuth(..)
, parseURI, parseURIReference, relativeTo
)
import Network.StreamDebugger (debugByteStream)
import Network.HTTP hiding ( sendHTTP_notify )
import Network.HTTP.HandleStream ( sendHTTP_notify )
import qualified Network.HTTP.MD5 as MD5 (hash)
import qualified Network.HTTP.Base64 as Base64 (encode)
import Network.Stream ( ConnError(..), Result )
import Network.BufferType
import Network.HTTP.Utils ( trim, splitBy )
import Data.Char (toLower,isAlphaNum,isSpace)
import Data.List (isPrefixOf,isSuffixOf)
import Data.Maybe (fromMaybe, listToMaybe, catMaybes, fromJust, isJust)
import Control.Monad (filterM, liftM, when)
import Text.ParserCombinators.Parsec
( Parser, char, many, many1, satisfy, parse, option, try
, (<|>), spaces, sepBy1
)
import qualified System.IO
( hSetBuffering, hPutStr, stdout, stdin, hGetChar
, BufferMode(NoBuffering, LineBuffering)
)
import System.Time ( ClockTime, getClockTime )
import Data.Word (Word8)
data Cookie
= MkCookie
{ ckDomain :: String
, ckName :: String
, ckValue :: String
, ckPath :: Maybe String
, ckComment :: Maybe String
, ckVersion :: Maybe String
}
deriving(Show,Read)
instance Eq Cookie where
a == b = ckDomain a == ckDomain b
&& ckName a == ckName b
&& ckPath a == ckPath b
defaultCookieFilter :: URI -> Cookie -> IO Bool
defaultCookieFilter _url _cky = return True
userCookieFilter :: URI -> Cookie -> IO Bool
userCookieFilter url cky = do
do putStrLn ("Set-Cookie received when requesting: " ++ show url)
case ckComment cky of
Nothing -> return ()
Just x -> putStrLn ("Cookie Comment:\n" ++ x)
let pth = maybe "" ('/':) (ckPath cky)
putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth)
putStrLn (ckName cky ++ '=' : ckValue cky)
System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering
System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering
System.IO.hPutStr System.IO.stdout "Accept [y/n]? "
x <- System.IO.hGetChar System.IO.stdin
System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering
System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering
return (toLower x == 'y')
cookieToHeader :: Cookie -> Header
cookieToHeader ck = Header HdrCookie text
where
path = maybe "" (";$Path="++) (ckPath ck)
text = "$Version=" ++ fromMaybe "0" (ckVersion ck)
++ ';' : ckName ck ++ "=" ++ ckValue ck ++ path
++ (case ckPath ck of
Nothing -> ""
Just x -> ";$Path=" ++ x)
++ ";$Domain=" ++ ckDomain ck
addCookie :: Cookie -> BrowserAction t ()
addCookie c = alterBS (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) })
setCookies :: [Cookie] -> BrowserAction t ()
setCookies cs = alterBS (\b -> b { bsCookies=cs })
getCookies :: BrowserAction t [Cookie]
getCookies = getBS bsCookies
getCookiesFor :: String -> String -> BrowserAction t [Cookie]
getCookiesFor dom path =
do cks <- getCookies
return (filter cookiematch cks)
where
cookiematch :: Cookie -> Bool
cookiematch ck = ckDomain ck `isSuffixOf` dom
&& case ckPath ck of
Nothing -> True
Just p -> p `isPrefixOf` path
setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()
setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f })
getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool)
getCookieFilter = getBS bsCookieFilter
data Algorithm = AlgMD5 | AlgMD5sess
deriving(Eq)
instance Show Algorithm where
show AlgMD5 = "md5"
show AlgMD5sess = "md5-sess"
data Qop = QopAuth | QopAuthInt
deriving(Eq,Show)
data Challenge
= ChalBasic { chRealm :: String }
| ChalDigest { chRealm :: String
, chDomain :: [URI]
, chNonce :: String
, chOpaque :: Maybe String
, chStale :: Bool
, chAlgorithm ::Maybe Algorithm
, chQop :: [Qop]
}
headerToChallenge :: URI -> Header -> Maybe Challenge
headerToChallenge baseURI (Header _ str) =
case parse challenge "" str of
Left{} -> Nothing
Right (name,props) -> case name of
"basic" -> mkBasic props
"digest" -> mkDigest props
_ -> Nothing
where
challenge :: Parser (String,[(String,String)])
challenge =
do { nme <- word
; spaces
; pps <- cprops
; return (map toLower nme,pps)
}
cprops = sepBy1 cprop comma
comma = do { spaces ; char ',' ; spaces }
cprop =
do { nm <- word
; char '='
; val <- quotedstring
; return (map toLower nm,val)
}
mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge
mkBasic params = fmap ChalBasic (lookup "realm" params)
mkDigest params =
do { r <- lookup "realm" params
; n <- lookup "nonce" params
; return $
ChalDigest { chRealm = r
, chDomain = (annotateURIs
$ map parseURI
$ words
$ fromMaybe []
$ lookup "domain" params)
, chNonce = n
, chOpaque = lookup "opaque" params
, chStale = "true" == (map toLower
$ fromMaybe "" (lookup "stale" params))
, chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params)
, chQop = readQop (fromMaybe "" $ lookup "qop" params)
}
}
annotateURIs :: [Maybe URI] -> [URI]
annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes
readQop :: String -> [Qop]
readQop = catMaybes . (map strToQop) . (splitBy ',')
strToQop qs = case map toLower (trim qs) of
"auth" -> Just QopAuth
"auth-int" -> Just QopAuthInt
_ -> Nothing
readAlgorithm astr = case map toLower (trim astr) of
"md5" -> Just AlgMD5
"md5-sess" -> Just AlgMD5sess
_ -> Nothing
data Authority
= AuthBasic { auRealm :: String
, auUsername :: String
, auPassword :: String
, auSite :: URI
}
| AuthDigest{ auRealm :: String
, auUsername :: String
, auPassword :: String
, auNonce :: String
, auAlgorithm :: Maybe Algorithm
, auDomain :: [URI]
, auOpaque :: Maybe String
, auQop :: [Qop]
}
getAuthFor :: String -> String -> BrowserAction t [Authority]
getAuthFor dom pth = getAuthorities >>= return . (filter match)
where
match :: Authority -> Bool
match au@AuthBasic{} = matchURI (auSite au)
match au@AuthDigest{} = or (map matchURI (auDomain au))
matchURI :: URI -> Bool
matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth)
getAuthorities :: BrowserAction t [Authority]
getAuthorities = getBS bsAuthorities
setAuthorities :: [Authority] -> BrowserAction t ()
setAuthorities as = alterBS (\b -> b { bsAuthorities=as })
addAuthority :: Authority -> BrowserAction t ()
addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b })
getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String)))
getAuthorityGen = getBS bsAuthorityGen
setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t ()
setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f })
setAllowBasicAuth :: Bool -> BrowserAction t ()
setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba })
setMaxAuthAttempts :: Maybe Int -> BrowserAction t ()
setMaxAuthAttempts mb
| fromMaybe 0 mb < 0 = return ()
| otherwise = alterBS (\ b -> b{bsMaxAuthAttempts=mb})
getMaxAuthAttempts :: BrowserAction t (Maybe Int)
getMaxAuthAttempts = getBS bsMaxAuthAttempts
setMaxErrorRetries :: Maybe Int -> BrowserAction t ()
setMaxErrorRetries mb
| fromMaybe 0 mb < 0 = return ()
| otherwise = alterBS (\ b -> b{bsMaxErrorRetries=mb})
getMaxErrorRetries :: BrowserAction t (Maybe Int)
getMaxErrorRetries = getBS bsMaxErrorRetries
pickChallenge :: [Challenge] -> Maybe Challenge
pickChallenge = listToMaybe
anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority)
anticipateChallenge rq =
let uri = rqURI rq in
do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri)
; return (listToMaybe authlist)
}
challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority)
challengeToAuthority uri ch =
if answerable ch then
do { prompt <- getAuthorityGen
; userdetails <- ioAction $ prompt uri (chRealm ch)
; case userdetails of
Nothing -> return Nothing
Just (u,p) -> return (Just $ buildAuth ch u p)
}
else return Nothing
where
answerable :: Challenge -> Bool
answerable (ChalBasic _) = True
answerable chall = (chAlgorithm chall) == Just AlgMD5
buildAuth :: Challenge -> String -> String -> Authority
buildAuth (ChalBasic r) u p =
AuthBasic { auSite=uri
, auRealm=r
, auUsername=u
, auPassword=p
}
buildAuth (ChalDigest r d n o _stale a q) u p =
AuthDigest { auRealm=r
, auUsername=u
, auPassword=p
, auDomain=d
, auNonce=n
, auOpaque=o
, auAlgorithm=a
, auQop=q
}
withAuthority :: Authority -> Request ty -> String
withAuthority a rq = case a of
AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a)
AuthDigest{} ->
"Digest username=\"" ++ auUsername a
++ "\",realm=\"" ++ auRealm a
++ "\",nonce=\"" ++ auNonce a
++ "\",uri=\"" ++ digesturi
++ ",response=\"" ++ rspdigest
++ "\""
++ ( if isJust (auAlgorithm a) then "" else ",algorithm=\"" ++ show (fromJust $ auAlgorithm a) ++ "\"" )
++ ( if isJust (auOpaque a) then "" else ",opaque=\"" ++ (fromJust $ auOpaque a) ++ "\"" )
++ ( if null (auQop a) then "" else ",qop=auth" )
where
rspdigest = "\""
++ map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2))
++ "\""
a1, a2 :: String
a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a
a2 = show (rqMethod rq) ++ ":" ++ digesturi
digesturi = show (rqURI rq)
noncevalue = auNonce a
type Octet = Word8
stringToOctets :: String -> [Octet]
stringToOctets = map (fromIntegral . fromEnum)
octetsToString :: [Octet] -> String
octetsToString = map (toEnum . fromIntegral)
base64encode :: String -> String
base64encode = Base64.encode . stringToOctets
md5 :: String -> String
md5 = octetsToString . MD5.hash . stringToOctets
kd :: String -> String -> String
kd a b = md5 (a ++ ":" ++ b)
data Proxy
= NoProxy
| Proxy String
(Maybe Authority)
data BrowserState connection
= BS { bsErr, bsOut :: String -> IO ()
, bsCookies :: [Cookie]
, bsCookieFilter :: URI -> Cookie -> IO Bool
, bsAuthorityGen :: URI -> String -> IO (Maybe (String,String))
, bsAuthorities :: [Authority]
, bsAllowRedirects :: Bool
, bsAllowBasicAuth :: Bool
, bsMaxRedirects :: Maybe Int
, bsMaxErrorRetries :: Maybe Int
, bsMaxAuthAttempts :: Maybe Int
, bsConnectionPool :: [connection]
, bsProxy :: Proxy
, bsDebug :: Maybe String
, bsEvent :: Maybe (BrowserEvent connection -> BrowserAction connection ())
, bsRequestID :: RequestID
}
instance Show (BrowserState t) where
show bs = "BrowserState { "
++ shows (bsCookies bs) ("\n"
++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ")
data BrowserAction conn a
= BA { lift :: BrowserState conn -> IO (BrowserState conn,a) }
instance Monad (BrowserAction conn) where
a >>= f = BA (\b -> do { (nb,v) <- lift a b ; lift (f v) nb})
return x = BA (\b -> return (b,x))
fail x = BA (\_ -> fail x)
instance Functor (BrowserAction conn) where
fmap f = liftM f
browse :: BrowserAction conn a -> IO a
browse act = do x <- lift act defaultBrowserState
return (snd x)
defaultBrowserState :: BrowserState t
defaultBrowserState = res
where
res = BS
{ bsErr = putStrLn
, bsOut = putStrLn
, bsCookies = []
, bsCookieFilter = defaultCookieFilter
, bsAuthorityGen = \ _uri _realm -> do
bsErr res "No action for prompting/generating user+password credentials \
\ provided (use: setAuthorityGen); returning Nothing"
return Nothing
, bsAuthorities = []
, bsAllowRedirects = True
, bsAllowBasicAuth = False
, bsMaxRedirects = Nothing
, bsMaxErrorRetries = Nothing
, bsMaxAuthAttempts = Nothing
, bsConnectionPool = []
, bsProxy = NoProxy
, bsDebug = Nothing
, bsEvent = Nothing
, bsRequestID = 0
}
alterBS :: (BrowserState t -> BrowserState t) -> BrowserAction t ()
alterBS f = BA (\b -> return (f b,()))
getBS :: (BrowserState t -> a) -> BrowserAction t a
getBS f = BA (\b -> return (b,f b))
getBrowserState :: BrowserAction t (BrowserState t)
getBrowserState = getBS id
withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a
withBrowserState bs act = BA $ \ _ -> lift act bs
nextRequest :: BrowserAction t a -> BrowserAction t a
nextRequest act = do
let updReqID st =
let
rid = succ (bsRequestID st)
in
rid `seq` st{bsRequestID=rid}
alterBS updReqID
act
ioAction :: IO a -> BrowserAction t a
ioAction a = BA (\b -> a >>= \v -> return (b,v))
setErrHandler :: (String -> IO ()) -> BrowserAction t ()
setErrHandler h = alterBS (\b -> b { bsErr=h })
setOutHandler :: (String -> IO ()) -> BrowserAction t ()
setOutHandler h = alterBS (\b -> b { bsOut=h })
out, err :: String -> BrowserAction t ()
out s = do { f <- getBS bsOut ; ioAction $ f s }
err s = do { f <- getBS bsErr ; ioAction $ f s }
setAllowRedirects :: Bool -> BrowserAction t ()
setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl})
getAllowRedirects :: BrowserAction t Bool
getAllowRedirects = getBS bsAllowRedirects
setMaxRedirects :: Maybe Int -> BrowserAction t ()
setMaxRedirects c
| fromMaybe 0 c < 0 = return ()
| otherwise = alterBS (\b -> b{bsMaxRedirects=c})
getMaxRedirects :: BrowserAction t (Maybe Int)
getMaxRedirects = getBS bsMaxRedirects
setProxy :: Proxy -> BrowserAction t ()
setProxy p = alterBS (\b -> b {bsProxy = p})
getProxy :: BrowserAction t Proxy
getProxy = getBS bsProxy
setDebugLog :: Maybe String -> BrowserAction t ()
setDebugLog v = alterBS (\b -> b {bsDebug=v})
data RequestState
= RequestState
{ reqDenies :: Int
, reqRedirects :: Int
, reqRetries :: Int
, reqStopOnDeny :: Bool
}
type RequestID = Int
nullRequestState :: RequestState
nullRequestState = RequestState
{ reqDenies = 0
, reqRedirects = 0
, reqRetries = 0
, reqStopOnDeny = True
}
data BrowserEvent ty
= BrowserEvent
{ browserTimestamp :: ClockTime
, browserRequestID :: RequestID
, browserRequestURI :: String
, browserEventType :: BrowserEventType ty
}
data BrowserEventType ty
= OpenConnection
| ReuseConnection
| RequestSent
| ResponseEnd ResponseData
| ResponseFinish
setEventHandler :: Maybe (BrowserEvent ty -> BrowserAction ty ()) -> BrowserAction ty ()
setEventHandler mbH = alterBS (\b -> b { bsEvent=mbH})
buildBrowserEvent :: BrowserEventType t -> String -> RequestID -> IO (BrowserEvent t)
buildBrowserEvent bt uri reqID = do
ct <- getClockTime
return BrowserEvent
{ browserTimestamp = ct
, browserRequestID = reqID
, browserRequestURI = uri
, browserEventType = bt
}
reportEvent :: BrowserEventType t -> String -> BrowserAction t ()
reportEvent bt uri = do
st <- getBrowserState
case bsEvent st of
Nothing -> return ()
Just evH -> do
evt <- ioAction $ buildBrowserEvent bt uri (bsRequestID st)
evH evt
defaultMaxRetries :: Int
defaultMaxRetries = 4
defaultMaxErrorRetries :: Int
defaultMaxErrorRetries = 4
defaultMaxAuthAttempts :: Int
defaultMaxAuthAttempts = 2
request :: HStream ty
=> Request ty
-> BrowserAction (HandleStream ty) (URI,Response ty)
request req = nextRequest $ do
res <- request' nullVal initialState req
reportEvent ResponseFinish (show (rqURI req))
case res of
Left e -> do
let errStr = ("Error raised during request handling: " ++ show e)
err errStr
fail errStr
Right r -> return r
where
initialState = nullRequestState
nullVal = buf_empty bufferOps
request' :: HStream ty
=> ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (Result (URI,Response ty))
request' nullVal rqState rq = do
let uri = rqURI rq
let uria = reqURIAuth rq
cookies <- getCookiesFor (uriAuthToString uria) (uriPath 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
Nothing -> return rq
Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)
let rq'' = insertHeaders (map cookieToHeader cookies) rq'
p <- getProxy
let defaultOpts =
case p of
NoProxy -> defaultNormalizeRequestOptions
Proxy _ ath ->
defaultNormalizeRequestOptions
{ normForProxy=True
, normCustoms =
maybe []
(\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])
ath
}
let final_req = normalizeRequest defaultOpts rq''
out ("Sending:\n" ++ show final_req)
e_rsp <-
case p of
NoProxy -> dorequest (reqURIAuth rq'') final_req
Proxy str _ath -> do
let notURI
| null pt || null hst =
URIAuth{ uriUserInfo = ""
, uriRegName = str
, uriPort = ""
}
| otherwise =
URIAuth{ uriUserInfo = ""
, uriRegName = hst
, uriPort = pt
}
where (hst, pt) = span (':'/=) str
let proxyURIAuth =
maybe notURI
(\parsed -> maybe notURI id (uriAuthority parsed))
(parseURI str)
out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth
dorequest proxyURIAuth final_req
mbMx <- getMaxErrorRetries
case e_rsp of
Left v
| (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) &&
(v == ErrorReset || v == ErrorClosed) ->
request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq
| otherwise ->
return (Left v)
Right rsp -> do
out ("Received:\n" ++ show rsp)
handleCookies uri (uriAuthToString $ reqURIAuth rq)
(retrieveHeaders HdrSetCookie rsp)
mbMxAuths <- getMaxAuthAttempts
case rspCode rsp of
(4,0,1)
| reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do
out "401 - credentials again refused; exceeded retry count (2)"
return (Right (uri,rsp))
| otherwise -> do
out "401 - credentials not supplied or refused; retrying.."
let hdrs = retrieveHeaders HdrWWWAuthenticate rsp
case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of
Nothing -> return (Right (uri,rsp))
Just x -> do
au <- challengeToAuthority uri x
case au of
Nothing -> return (Right (uri,rsp))
Just au' -> do
out "Retrying request with new credentials"
request' nullVal
rqState{ reqDenies = succ(reqDenies rqState)
, reqStopOnDeny = False
}
(insertHeader HdrAuthorization (withAuthority au' rq) rq)
(4,0,7)
| reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do
out "407 - proxy authentication required; max deny count exceeeded (2)"
return (Right (uri,rsp))
| otherwise -> do
out "407 - proxy authentication required"
let hdrs = retrieveHeaders HdrProxyAuthenticate rsp
case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of
Nothing -> return (Right (uri,rsp))
Just x -> do
au <- challengeToAuthority uri x
case au of
Nothing -> return (Right (uri,rsp))
Just au' -> do
pxy <- getBS bsProxy
case pxy of
NoProxy -> do
err "Proxy authentication required without proxy!"
return (Right (uri,rsp))
Proxy px _ -> do
out "Retrying with proxy authentication"
setProxy (Proxy px (Just au'))
request' nullVal
rqState{ reqDenies = succ(reqDenies rqState)
, reqStopOnDeny = False
}
rq
(3,0,x) | x == 3 || x == 2 -> do
out ("30" ++ show x ++ " - redirect using GET")
rd <- getAllowRedirects
mbMxRetries <- getMaxRedirects
if not rd || reqRedirects rqState > fromMaybe defaultMaxRetries mbMxRetries
then return (Right (uri,rsp))
else
case retrieveHeaders HdrLocation rsp of
[] -> do
err "No Location: header in redirect response"
return (Right (uri,rsp))
(Header _ u:_) ->
case parseURIReference u of
Nothing -> do
err ("Parse of Location: header in a redirect response failed: " ++ u)
return (Right (uri,rsp))
Just newuri -> do
out ("Redirecting to " ++ show newuri' ++ " ...")
let rq1 = rq { rqMethod=GET, rqURI=newuri', rqBody=nullVal }
request' nullVal
rqState{ reqDenies = 0
, reqRedirects = succ(reqRedirects rqState)
, reqStopOnDeny = True
}
(replaceHeader HdrContentLength "0" rq1)
where
newuri' = maybe newuri id (newuri `relativeTo` uri)
(3,0,5) ->
case retrieveHeaders HdrLocation rsp of
[] -> do
err "No Location header in proxy redirect response."
return (Right (uri,rsp))
(Header _ u:_) ->
case parseURIReference u of
Nothing -> do
err ("Parse of Location header in a proxy redirect response failed: " ++ u)
return (Right (uri,rsp))
Just newuri -> do
out ("Retrying with proxy " ++ show newuri ++ "...")
setProxy (Proxy (uriToAuthorityString newuri) Nothing)
request' nullVal rqState{ reqDenies = 0
, reqRedirects = 0
, reqRetries = succ (reqRetries rqState)
, reqStopOnDeny = True
}
rq
(3,_,_) -> redirect uri rsp
_ -> return (Right (uri,rsp))
where
redirect uri rsp = do
rd <- getAllowRedirects
mbMxRetries <- getMaxRedirects
if not rd || reqRedirects rqState > fromMaybe defaultMaxRetries mbMxRetries
then return (Right (uri,rsp))
else do
case retrieveHeaders HdrLocation rsp of
[] -> do
err "No Location header in redirect response."
return (Right (uri,rsp))
(Header _ u:_) ->
case parseURIReference u of
Just newuri -> do
let newuri' = maybe newuri id (newuri `relativeTo` uri)
out ("Redirecting to " ++ show newuri' ++ " ...")
request' nullVal
rqState{ reqDenies = 0
, reqRedirects = succ (reqRedirects rqState)
, reqStopOnDeny = True
}
rq{rqURI=newuri'}
Nothing -> do
err ("Parse of Location header in a redirect response failed: " ++ u)
return (Right (uri,rsp))
dorequest :: (HStream ty)
=> URIAuth
-> Request ty
-> BrowserAction (HandleStream ty)
(Result (Response ty))
dorequest hst rqst = do
pool <- getBS bsConnectionPool
conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool
rsp <-
case conn of
[] -> do
out ("Creating new connection to " ++ uriAuthToString hst)
let uPort = uriAuthPort Nothing hst
reportEvent OpenConnection (show (rqURI rqst))
c <- ioAction $ openStream (uriRegName hst) uPort
updateConnectionPool c
dorequest2 c rqst
(c:_) -> do
out ("Recovering connection to " ++ uriAuthToString hst)
reportEvent ReuseConnection (show (rqURI rqst))
dorequest2 c rqst
case rsp of
Right (Response a b c _) ->
reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return ()
return rsp
where
dorequest2 c r = do
dbg <- getBS bsDebug
st <- getBrowserState
let
onSendComplete =
maybe (return ())
(\evh -> do
x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)
(lift (evh x)) st
return ())
(bsEvent st)
ioAction $
maybe (sendHTTP_notify c r onSendComplete)
(\ f -> do
c' <- debugByteStream (f++'-': uriAuthToString hst) c
sendHTTP_notify c' r onSendComplete)
dbg
updateConnectionPool :: HStream hTy
=> HandleStream hTy
-> BrowserAction (HandleStream hTy) ()
updateConnectionPool c = do
pool <- getBS bsConnectionPool
let len_pool = length pool
when (len_pool > maxPoolSize)
(ioAction $ close (last pool))
let pool'
| len_pool > maxPoolSize = init pool
| otherwise = pool
alterBS (\b -> b { bsConnectionPool=c:pool' })
return ()
maxPoolSize :: Int
maxPoolSize = 5
type FormVar = (String,String)
data Form = Form RequestMethod URI [FormVar]
formToRequest :: Form -> Request_String
formToRequest (Form m u vs) =
let enc = urlEncodeVars vs
in case m of
GET -> Request { rqMethod=GET
, rqHeaders=[ Header HdrContentLength "0" ]
, rqBody=""
, rqURI=u { uriQuery= '?' : enc }
}
POST -> Request { rqMethod=POST
, rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded",
Header HdrContentLength (show $ length enc) ]
, rqBody=enc
, rqURI=u
}
_ -> error ("unexpected request: " ++ show m)
handleCookies :: URI -> String -> [Header] -> BrowserAction t ()
handleCookies _ _ [] = return ()
handleCookies uri dom cookieHeaders = do
when (not $ null errs)
(err $ unlines ("Errors parsing these cookie values: ":errs))
when (not $ null newCookies)
(out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies)
filterfn <- getCookieFilter
newCookies' <- ioAction (filterM (filterfn uri) newCookies)
when (not $ null newCookies')
(out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies'))
mapM_ addCookie newCookies'
where
(errs, newCookies) = foldr (headerToCookies dom) ([],[]) cookieHeaders
headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])
headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) =
case parse cookies "" val of
Left e -> (val:accErr, accCookie)
Right x -> (accErr, x ++ accCookie)
where
cookies :: Parser [Cookie]
cookies = sepBy1 cookie (char ',')
cookie :: Parser Cookie
cookie =
do { name <- word
; spaces_l
; char '='
; spaces_l
; val1 <- cvalue
; args <- cdetail
; return $ mkCookie name val1 args
}
cvalue :: Parser String
spaces_l = many (satisfy isSpace)
cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return ""
cdetail :: Parser [(String,String)]
cdetail = many $
try (do { spaces_l
; char ';'
; spaces_l
; s1 <- word
; spaces_l
; s2 <- option "" (do { char '=' ; spaces_l ; v <- cvalue ; return v })
; return (map toLower s1,s2)
})
mkCookie :: String -> String -> [(String,String)] -> Cookie
mkCookie nm cval more =
MkCookie { ckName = nm
, ckValue = cval
, ckDomain = map toLower (fromMaybe dom (lookup "domain" more))
, ckPath = lookup "path" more
, ckVersion = lookup "version" more
, ckComment = lookup "comment" more
}
headerToCookies _ _ acc = acc
uriDefaultTo :: URI -> URI -> URI
uriDefaultTo a b = maybe a id (a `relativeTo` b)
word, quotedstring :: Parser String
quotedstring =
do { char '"'
; str <- many (satisfy $ not . (=='"'))
; char '"'
; return str
}
word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))