module Network.Browser (
BrowserState,
BrowserAction,
Cookie,
Form(..),
Proxy(..),
browse,
request,
getBrowserState,
withBrowserState,
setAllowRedirects,
getAllowRedirects,
Authority(..),
getAuthorities,
setAuthorities,
addAuthority,
getAuthorityGen,
setAuthorityGen,
setAllowBasicAuth,
setCookieFilter,
defaultCookieFilter,
userCookieFilter,
getCookies,
setCookies,
addCookie,
setErrHandler,
setOutHandler,
setProxy,
setDebugLog,
out,
err,
ioAction,
defaultGETRequest,
defaultGETRequest_,
formToRequest,
uriDefaultTo,
uriTrimHost
) where
import Network.URI
( URI(uriAuthority, uriScheme, uriPath, uriQuery)
, URIAuth(..)
, parseURI, parseURIReference, relativeTo
)
import Network.StreamDebugger (debugByteStream)
import Network.HTTP
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 (foldM, 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 Data.Word (Word8)
type Octet = Word8
word, quotedstring :: Parser String
quotedstring =
do { char '"'
; str <- many (satisfy $ not . (=='"'))
; char '"'
; return str
}
word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))
uriDefaultTo :: URI -> URI -> URI
uriDefaultTo a b = maybe a id (a `relativeTo` b)
uriTrimHost :: URI -> URI
uriTrimHost uri = uri { uriScheme="", uriAuthority=Nothing }
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 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
headerToCookies :: String -> Header -> [Cookie]
headerToCookies dom (Header HdrSetCookie val) =
case parse cookies "" val of
Left e -> error ("Cookie parse failure on: " ++ val ++ " " ++ show e)
Right x -> x
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 _ _ = []
addCookie :: Cookie -> BrowserAction t ()
addCookie c = alterBS (\b -> b { bsCookies=c : fn (bsCookies b) })
where
fn = filter (not . (==c))
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 =
do { list <- getAuthorities
; return (filter match list)
}
where
match :: Authority -> Bool
match (AuthBasic _ _ _ s) = matchURI s
match (AuthDigest _ _ _ _ _ ds _ _) = or (map matchURI ds)
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 })
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
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
, bsConnectionPool :: [connection]
, bsProxy :: Proxy
, bsDebug :: Maybe String
}
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))
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 ->
(bsErr res) ("No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing") >> return Nothing
, bsAuthorities = []
, bsAllowRedirects = True
, bsAllowBasicAuth = False
, bsConnectionPool = []
, bsProxy = NoProxy
, bsDebug = Nothing
}
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
ioAction :: IO a -> BrowserAction t a
ioAction a = BA (\b -> a >>= \v -> return (b,v))
setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction t ()
setErrHandler h = alterBS (\b -> b { bsErr=h })
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
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
}
nullRequestState :: RequestState
nullRequestState = RequestState
{ reqDenies = 0
, reqRedirects = 0
, reqRetries = 0
, reqStopOnDeny = True
}
maxRetries :: Int
maxRetries = 4
maxDenies :: Int
maxDenies = 2
request :: HStream ty
=> Request ty
-> BrowserAction (HandleStream ty) (URI,Response ty)
request req = request' nullVal initialState req
where
initialState = nullRequestState
nullVal = buf_empty bufferOps
request' :: HStream ty
=> ty
-> RequestState
-> Request ty
-> BrowserAction (HandleStream ty) (URI,Response ty)
request' nullVal rqState rq = do
let uri = rqURI rq
cookies <- getCookiesFor (uriAuthToString $ reqURIAuth rq) (uriPath uri)
when (not $ null cookies)
(out $ "Adding cookies to request. Cookie names: " ++
foldl spaceappend "" (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 rq_to_go = normalizeRequestURI False
(uriToAuthorityString $ rqURI rq'')
rq''
out ("Sending:\n" ++ show rq_to_go)
e_rsp <-
case p of
NoProxy -> dorequest (reqURIAuth rq'') rq_to_go
Proxy str ath -> do
let rq_to_go' = maybe rq''
(\x -> insertHeader HdrProxyAuthorization
(withAuthority x rq'') rq'')
ath
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 rq_to_go'
case e_rsp of
Left v
| (reqRetries rqState < maxRetries) && (v == ErrorReset || v == ErrorClosed) ->
request' nullVal rqState{reqRetries=reqRetries rqState + 1} rq
| otherwise -> error ("Exception raised in request: " ++ show v)
Right rsp -> do
out ("Received:\n" ++ show rsp)
let cookieheaders = retrieveHeaders HdrSetCookie rsp
let newcookies = concat (map (headerToCookies $ uriAuthToString $ reqURIAuth rq) cookieheaders)
when (not $ null newcookies)
(out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newcookies)
filterfn <- getCookieFilter
newcookies' <- ioAction (filterM (filterfn uri) newcookies)
foldM (\_ -> addCookie) () newcookies'
when (not $ null newcookies)
(out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies'))
case rspCode rsp of
(4,0,1)
| reqDenies rqState > maxDenies -> do
out "401 - credentials again refused; exceeded retry count (2)"
return (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 (uri,rsp)
Just x -> do
au <- challengeToAuthority uri x
case au of
Nothing -> return (uri,rsp)
Just au' -> do
out "Retrying request with new credentials"
request' nullVal
rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False}
(insertHeader HdrAuthorization (withAuthority au' rq) rq)
(4,0,7)
| reqDenies rqState > maxDenies -> do
out "407 - proxy authentication required; max deny count exceeeded (2)"
return (uri,rsp)
| otherwise -> do
out "407 - proxy authentication required"
let hdrs = retrieveHeaders HdrProxyAuthenticate rsp
case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of
Nothing -> return (uri,rsp)
Just x -> do
au <- challengeToAuthority uri x
case au of
Nothing -> return (uri,rsp)
Just au' -> do
pxy <- getBS bsProxy
case pxy of
NoProxy -> do
err "Proxy authentication required without proxy!"
return (uri,rsp)
Proxy px _ -> do
out "Retrying with proxy authentication"
setProxy (Proxy px (Just au'))
request' nullVal
rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False}
rq
(3,0,x) | x == 3 || x == 2 -> do
out ("30" ++ show x ++ " - redirect using GET")
rd <- getAllowRedirects
if not rd || reqRedirects rqState > maxRetries
then return (uri,rsp)
else
case retrieveHeaders HdrLocation rsp of
[] -> do
err "No Location header in redirect response"
return (uri,rsp)
(Header _ u:_) ->
case parseURIReference u of
Nothing -> do
err ("Parse of Location header in a redirect response failed: " ++ u)
return (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=reqRedirects rqState + 1, 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 (uri,rsp)
(Header _ u:_) ->
case parseURIReference u of
Nothing -> do
err ("Parse of Location header in a proxy redirect response failed: " ++ u)
return (uri,rsp)
Just newuri -> do
out ("Retrying with proxy " ++ show newuri ++ "...")
setProxy (Proxy (uriToAuthorityString newuri) Nothing)
request' nullVal rqState{ reqDenies=0
, reqRedirects=0
, reqRetries=reqRetries rqState + 1
, reqStopOnDeny=True
}
rq
(3,_,_) -> redirect uri rsp
_ -> return (uri,rsp)
where
redirect uri rsp = do
rd <- getAllowRedirects
if not rd || reqRedirects rqState > maxRetries
then return (uri,rsp)
else do
case retrieveHeaders HdrLocation rsp of
[] -> do
err "No Location header in redirect response."
return (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=reqRedirects rqState + 1, reqStopOnDeny=True}
rq{rqURI=newuri'}
Nothing -> do
err ("Parse of Location header in a redirect response failed: " ++ u)
return (uri,rsp)
spaceappend :: String -> String -> String
spaceappend x y = x ++ ' ' : y
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 aport = case uriPort hst of
(':':s) ->
case reads s of { ((v,_):_) -> v ; _ -> 80}
_ -> 80
; c <- ioAction $ openStream (uriRegName hst) aport
; let len_pool = length pool
; when (len_pool > 5)
(ioAction $ close (last pool))
; let pool'
| len_pool > 5 = init pool
| otherwise = pool
; alterBS (\b -> b { bsConnectionPool=c:pool' })
; dorequest2 c rqst
}
(c:_) ->
do { out ("Recovering connection to " ++ uriAuthToString hst)
; dorequest2 c rqst
}
;
; return rsp
}
where
dorequest2 c r = do
dbg <- getBS bsDebug
ioAction $
case dbg of
Nothing -> sendHTTP c r
Just f -> do
c' <- debugByteStream (f++'-': uriAuthToString hst) c
sendHTTP c' r
reqURIAuth :: Request ty -> URIAuth
reqURIAuth req =
case uriAuthority (rqURI req) of
Just ua -> ua
_ -> case lookupHeader HdrHost (rqHeaders req) of
Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req)
Just h -> URIAuth { uriUserInfo = ""
, uriRegName = h
, uriPort = ""
}
libUA :: String
libUA = "hs-HTTP/4.0.3"
defaultGETRequest :: URI -> Request_String
defaultGETRequest uri = defaultGETRequest_ uri
defaultGETRequest_ :: BufferType a => URI -> Request a
defaultGETRequest_ uri = req
where
empty = buf_empty (toBufOps req)
req =
Request { rqURI=uri
, rqBody=empty
, rqHeaders=[ Header HdrContentLength "0"
, Header HdrUserAgent libUA
]
, rqMethod=GET
}
toBufOps :: BufferType a => Request a -> BufferOp a
toBufOps _ = bufferOps
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)