module Network.Browser (
BrowserState,
BrowserAction,
Cookie,
Form(..),
Proxy(..),
browse,
request,
setAllowRedirects,
getAllowRedirects,
Authority(..),
getAuthorities,
setAuthorities,
addAuthority,
getAuthorityGen,
setAuthorityGen,
setAllowBasicAuth,
setCookieFilter,
defaultCookieFilter,
userCookieFilter,
getCookies,
setCookies,
addCookie,
setErrHandler,
setOutHandler,
setProxy,
setDebugLog,
out,
err,
ioAction,
defaultGETRequest,
formToRequest,
uriDefaultTo,
uriTrimHost
) where
import Network.HTTP
import Data.Char (toLower,isAlphaNum,isSpace)
import Data.List (isPrefixOf,isSuffixOf,elemIndex,elemIndices)
import Data.Maybe
import Control.Monad (foldM,filterM,liftM,when)
import Text.ParserCombinators.Parsec
import Network.URI
import qualified System.IO
import Data.Word (Word8)
import qualified Network.HTTP.MD5 as MD5
import qualified Network.HTTP.Base64 as Base64
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==':'))
trim :: String -> String
trim = let dropspace = dropWhile isSpace in
reverse . dropspace . reverse . dropspace
split :: Eq a => a -> [a] -> Maybe ([a],[a])
split delim list = case delim `elemIndex` list of
Nothing -> Nothing
Just x -> Just $ splitAt x list
splitMany :: Eq a => a -> [a] -> [[a]]
splitMany delim str = fn str ixs
where
ixs = elemIndices delim str
fn _ [] = []
fn ls (h:t) = let (a,b) = splitAt h ls in a : fn b t
uriDefaultTo :: URI -> URI -> URI
uriDefaultTo a b =
case a `relativeTo` b of
Nothing -> a
Just x -> x
uriTrimHost :: URI -> URI
uriTrimHost uri = uri { uriScheme="", uriAuthority=Nothing }
data Cookie = MkCookie { ckDomain
, ckName
, ckValue :: String
, ckPath
, ckComment
, 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)
putStrLn ("Domain/Path: " ++ ckDomain cky ++
case ckPath cky of
Nothing -> ""
Just x -> "/" ++ x)
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
text = "$Version=" ++ fromMaybe "0" (ckVersion ck)
++ ';' : ckName ck ++ "=" ++ ckValue ck
++ (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
; char '='
; spaces
; val <- cvalue
; args <- cdetail
; return $ mkCookie name val args
}
cvalue :: Parser String
spaces = many (satisfy isSpace)
cvalue = quotedstring <|> many1 (satisfy $ not . (==';'))
cdetail :: Parser [(String,String)]
cdetail = many $
try (do { spaces
; char ';'
; spaces
; s1 <- word
; spaces
; s2 <- option "" (do { char '=' ; spaces ; v <- cvalue ; return v })
; return (map toLower s1,s2)
})
mkCookie :: String -> String -> [(String,String)] -> Cookie
mkCookie nm val more = MkCookie { ckName=nm
, ckValue=val
, ckDomain=map toLower (fromMaybe dom (lookup "domain" more))
, ckPath=lookup "path" more
, ckVersion=lookup "version" more
, ckComment=lookup "comment" more
}
addCookie :: Cookie -> BrowserAction ()
addCookie c = alterBS (\b -> b { bsCookies=c : fn (bsCookies b) })
where
fn = filter (not . (==c))
setCookies :: [Cookie] -> BrowserAction ()
setCookies cs = alterBS (\b -> b { bsCookies=cs })
getCookies :: BrowserAction [Cookie]
getCookies = getBS bsCookies
getCookiesFor :: String -> String -> BrowserAction [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 ()
setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f })
getCookieFilter :: BrowserAction (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 e -> 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)
}
quotedstring =
do { char '"'
; str <- many (satisfy (not.(=='"')))
; char '"'
; return str
}
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) . (splitMany ',')
strToQop str = case map toLower (trim str) of
"auth" -> Just QopAuth
"auth-int" -> Just QopAuthInt
_ -> Nothing
readAlgorithm str = case map toLower (trim str) 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 [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 [Authority]
getAuthorities = getBS bsAuthorities
setAuthorities :: [Authority] -> BrowserAction ()
setAuthorities as = alterBS (\b -> b { bsAuthorities=as })
addAuthority :: Authority -> BrowserAction ()
addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b })
getAuthorityGen :: BrowserAction (URI -> String -> IO (Maybe (String,String)))
getAuthorityGen = getBS bsAuthorityGen
setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction ()
setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f })
setAllowBasicAuth :: Bool -> BrowserAction ()
setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba })
pickChallenge :: [Challenge] -> Maybe Challenge
pickChallenge = listToMaybe
anticipateChallenge :: Request -> BrowserAction (Maybe Authority)
anticipateChallenge rq =
let uri = rqURI rq in
do { authlist <- getAuthFor (uriToAuthorityString uri) (uriPath uri)
; return (listToMaybe authlist)
}
challengeToAuthority :: URI -> Challenge -> BrowserAction (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 ch = (chAlgorithm ch) == 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 s a q) u p =
AuthDigest { auRealm=r
, auUsername=u
, auPassword=p
, auDomain=d
, auNonce=n
, auOpaque=o
, auAlgorithm=a
, auQop=q
}
withAuthority :: Authority -> Request -> String
withAuthority a rq = case a of
AuthBasic _ _ user pass ->
"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))
++ "\""
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)
a1, a2 :: String
a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a
a2 = show (rqMethod rq) ++ ":" ++ digesturi
digesturi = show (rqURI rq)
noncevalue = auNonce a
data Proxy = NoProxy
| Proxy String (Maybe Authority)
data BrowserState = 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 where
show bs = "BrowserState { "
++ show (bsCookies bs) ++ "\n"
++ "AllowRedirects: " ++ show (bsAllowRedirects bs)
++ "} "
data BrowserAction a = BA { lift :: (BrowserState -> IO (BrowserState,a)) }
instance Monad BrowserAction 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 where
fmap f = liftM f
browse :: BrowserAction a -> IO a
browse act = do x <- lift act defaultBrowserState
return (snd x)
where
defaultBrowserState :: BrowserState
defaultBrowserState =
BS { bsErr = putStrLn
, bsOut = putStrLn
, bsCookies = []
, bsCookieFilter = defaultCookieFilter
, bsAuthorityGen = (error "bsAuthGen wanted")
, bsAuthorities = []
, bsAllowRedirects = True
, bsAllowBasicAuth = False
, bsConnectionPool = []
, bsProxy = NoProxy
, bsDebug = Nothing
}
alterBS :: (BrowserState -> BrowserState) -> BrowserAction ()
alterBS f = BA (\b -> return (f b,()))
getBS :: (BrowserState -> a) -> BrowserAction a
getBS f = BA (\b -> return (b,f b))
ioAction :: IO a -> BrowserAction a
ioAction a = BA (\b -> a >>= \v -> return (b,v))
setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction ()
setErrHandler h = alterBS (\b -> b { bsErr=h })
setOutHandler h = alterBS (\b -> b { bsOut=h })
out, err :: String -> BrowserAction ()
out s = do { f <- getBS bsOut ; ioAction $ f s }
err s = do { f <- getBS bsErr ; ioAction $ f s }
setAllowRedirects :: Bool -> BrowserAction ()
setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl})
getAllowRedirects :: BrowserAction Bool
getAllowRedirects = getBS bsAllowRedirects
setProxy :: Proxy -> BrowserAction ()
setProxy p = alterBS (\b -> b {bsProxy = p})
getProxy :: BrowserAction Proxy
getProxy = getBS bsProxy
setDebugLog :: Maybe String -> BrowserAction ()
setDebugLog v = alterBS (\b -> b {bsDebug=v})
type RequestState = ( Int
, Int
, Int
, Bool
)
request :: Request -> BrowserAction (URI,Response)
request = request' initialState
where
initialState = (0,0,0,True)
request' :: RequestState -> Request -> BrowserAction (URI,Response)
request' (denycount,redirectcount,retrycount,preempt) rq =
do
let uri = rqURI rq
cookies <- getCookiesFor (uriToAuthorityString uri) (uriPath uri)
when (not $ null cookies)
(out $ "Adding cookies to request. Cookie names: "
++ foldl spaceappend "" (map ckName cookies))
rq' <- if not preempt then return rq else
do { auth <- anticipateChallenge rq
; case auth of
Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)
Nothing -> return rq
}
let rq'' = insertHeaders (map cookieToHeader cookies) rq'
p <- getProxy
out ("Sending:\n" ++ show rq'')
e_rsp <- case p of
NoProxy -> dorequest (uriAuth $ rqURI rq'') rq''
Proxy str ath ->
let rq''' = case ath of
Nothing -> rq''
Just x -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq''
proxyURIAuth =
maybe notURI
(\parsed -> maybe notURI
id (uriAuthority parsed))
(parseURI str)
notURI =
let (host, port) = span (':'/=) str
in
if null port || null host
then URIAuth "" str ""
else URIAuth "" host port
in
do
out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth
dorequest proxyURIAuth rq'''
case e_rsp of
Left v -> if (retrycount < 4) && (v == ErrorReset || v == ErrorClosed)
then request' (denycount,redirectcount,retrycount+1,preempt) rq
else 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 $ uriToAuthorityString uri) 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) ->
out "401 - credentials not sent or refused" >>
if denycount > 2 then return (uri,rsp) else
do { let hdrs = retrieveHeaders HdrWWWAuthenticate rsp
; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of
Just x ->
do { au <- challengeToAuthority uri x
; case au of
Just au' ->
out "Retrying request with new credentials" >>
request' (denycount+1,redirectcount,retrycount,False)
(insertHeader HdrAuthorization (withAuthority au' rq) rq)
Nothing -> return (uri,rsp)
}
Nothing -> return (uri,rsp)
}
(4,0,7) ->
out "407 - proxy authentication required" >>
if denycount > 2 then return (uri,rsp) else
do { let hdrs = retrieveHeaders HdrProxyAuthenticate rsp
; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of
Just x ->
do { au <- challengeToAuthority uri x
; case au of
Just au' ->
do { pxy <- getBS bsProxy
; case pxy of
NoProxy ->
do { err "Proxy authentication required without proxy!"
; return (uri,rsp)
}
Proxy x y ->
do { out "Retrying with proxy authentication"
; setProxy (Proxy x $ Just au')
; request' (denycount+1,redirectcount,retrycount,False) rq
}
}
Nothing -> return (uri,rsp)
}
Nothing -> return (uri,rsp)
}
(3,0,3) ->
do { out "303 - redirect using GET"
; rd <- getAllowRedirects
; if not rd || redirectcount > 4 then return (uri,rsp) else
case retrieveHeaders HdrLocation rsp of
(Header _ u:_) -> case parseURIReference u of
Just newuri ->
let newuri' = case newuri `relativeTo` uri of
Nothing -> newuri
Just x -> x
in do { out ("Redirecting to " ++ show newuri' ++ " ...")
; let rq = rq { rqMethod=GET, rqURI=newuri', rqBody="" }
; request' (0,redirectcount+1,retrycount,True)
(replaceHeader HdrContentLength "0" rq)
}
Nothing ->
do { err ("Parse of Location header in a redirect response failed: " ++ u)
; return (uri,rsp)
}
[] -> do { err "No Location header in redirect response"
; return (uri,rsp)
}
}
(3,0,5) ->
case retrieveHeaders HdrLocation rsp of
(Header _ u:_) -> case parseURIReference u of
Just newuri ->
do { out ("Retrying with proxy " ++ show newuri ++ "...")
; setProxy (Proxy (uriToAuthorityString newuri) Nothing)
; request' (0,0,retrycount+1,True) rq
}
Nothing ->
do { err ("Parse of Location header in a proxy redirect response failed: " ++ u)
; return (uri,rsp)
}
[] -> do { err "No Location header in proxy redirect response."
; return (uri,rsp)
}
(3,_,_) -> redirect uri rsp
_ -> return (uri,rsp)
where
spaceappend :: String -> String -> String
spaceappend x y = x ++ ' ' : y
redirect uri rsp = do
rd <- getAllowRedirects
if not rd || redirectcount > 4 then return (uri,rsp) else do
case retrieveHeaders HdrLocation rsp of
(Header _ u:_) -> case parseURIReference u of
Just newuri -> do
let newuri' = case newuri `relativeTo` uri of
Nothing -> newuri
Just x -> x
out ("Redirecting to " ++ show newuri' ++ " ...")
request' (0,redirectcount+1,retrycount,True) (rq { rqURI=newuri' })
Nothing -> do
err ("Parse of Location header in a redirect response failed: " ++ u)
return (uri,rsp)
[] -> do err "No Location header in redirect response."
return (uri,rsp)
dorequest :: URIAuth -> Request -> BrowserAction (Either ConnError Response)
dorequest hst rqst =
do { pool <- getBS bsConnectionPool
; conn <- ioAction $ filterM (\c -> c `isConnectedTo` uriAuthToString hst) pool
; rsp <- case conn of
[] -> do { out ("Creating new connection to " ++ uriAuthToString hst)
; let port = case uriPort hst of
(':':s) -> read s
_ -> 80
; c <- ioAction $ openTCPPort (uriRegName hst) port
; let pool' = if length pool > 5
then init pool
else pool
; when (length pool > 5)
(ioAction $ close (last pool))
; alterBS (\b -> b { bsConnectionPool=c:pool' })
; dorequest2 hst c rqst
}
(c:_) ->
do { out ("Recovering connection to " ++ uriAuthToString hst)
; dorequest2 hst c rqst
}
;
; return rsp
}
dorequest2 hst c r =
do { dbg <- getBS bsDebug
; ioAction $ case dbg of
Nothing -> sendHTTP c r
Just f ->
debugStream (f++'-': uriAuthToString hst) c
>>= \c' -> sendHTTP c' r
}
uriAuth x = case uriAuthority x of
Just ua -> ua
_ -> error ("No uri authority for: "++show x)
uriAuthToString :: URIAuth -> String
uriAuthToString URIAuth { uriUserInfo = uinfo
, uriRegName = regname
, uriPort = port
} =
((if null uinfo then id else (uinfo++))
. (regname++)
. (port++)) ""
uriToAuthorityString :: URI -> String
uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u)
libUA = "haskell-libwww/0.1"
defaultGETRequest :: URI -> Request
defaultGETRequest uri =
Request { rqURI=uri
, rqBody=""
, rqHeaders=[ Header HdrContentLength "0"
, Header HdrUserAgent libUA
]
, rqMethod=GET
}
type FormVar = (String,String)
data Form = Form RequestMethod URI [FormVar]
formToRequest :: Form -> Request
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
}