diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,25 @@ +Version 4004.0.8: release 2009-08-05 + + * Incorporated proxy setting lookup and parsing contribution + by Eric Kow; provided in Network.HTTP.Proxy + * Factor out HTTP Cookies and Auth handling into separate + modules Network.HTTP.Cookie, Network.HTTP.Auth + * new Network.Browser functionality for hooking up the + proxy detection code in Network.HTTP.Proxy: + + setCheckForProxy :: Bool -> BrowserAction t () + getCheckForProxy :: BrowserAction t Bool + + If you do 'setCheckForProxy True' within a browser + session, the proxy-checking code will be called upon. + Use 'getCheckForProxy' to get the current setting for + this flag. + + * Network.Browser: if HTTP Basic Auth is allowed and + server doesn't 401-challenge with an WWW-Authenticate: + header, simply assume / realm and proceed. Preferable + than failing, even if server is the wrong. + Version 4004.0.7: release 2009-05-22 * Minor release. diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.0.7 +Version: 4000.0.8 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3 @@ -58,6 +58,9 @@ Network.HTTP.Headers, Network.HTTP.Base, Network.HTTP.Stream, + Network.HTTP.Auth, + Network.HTTP.Cookie, + Network.HTTP.Proxy, Network.HTTP.HandleStream, Network.Browser Other-modules: @@ -66,8 +69,11 @@ Network.HTTP.MD5Aux, Network.HTTP.Utils GHC-options: -fwarn-missing-signatures -Wall - Build-depends: base >= 2, network, parsec, mtl + Build-depends: base >= 2 && < 4 , network, parsec, mtl if flag(old-base) Build-depends: base < 3 else Build-depends: base >= 3, array, old-time, bytestring + + if os(windows) + Build-depends: Win32 diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -61,6 +61,7 @@ , getAuthorityGen , setAuthorityGen , setAllowBasicAuth + , getAllowBasicAuth , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) @@ -89,7 +90,11 @@ , setProxy -- :: Proxy -> BrowserAction t () , getProxy -- :: BrowserAction t Proxy - , setDebugLog + + , setCheckForProxy -- :: Bool -> BrowserAction t () + , getCheckForProxy -- :: BrowserAction t Bool + + , setDebugLog -- :: Maybe String -> BrowserAction t () , out -- :: String -> BrowserAction t () , err -- :: String -> BrowserAction t () @@ -114,52 +119,29 @@ 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.HTTP.Auth +import Network.HTTP.Cookie +import Network.HTTP.Proxy + 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 Data.Char (toLower) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe, listToMaybe, catMaybes ) 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) ------------------------------------------------------------------ ----------------------- Cookie Stuff ----------------------------- ------------------------------------------------------------------ --- | @Cookie@ is the Haskell representation of HTTP cookie values. --- See its relevant specs for authoritative details. -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@ is the initial cookie acceptance filter. -- It welcomes them all into the store @:-)@ defaultCookieFilter :: URI -> Cookie -> IO Bool @@ -184,21 +166,7 @@ System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering return (toLower x == 'y') - --- | Serialise a Cookie for inclusion in a request. -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 c@ adds a cookie to the browser state, removing duplicates. addCookie :: Cookie -> BrowserAction t () addCookie c = alterBS (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) }) @@ -223,10 +191,7 @@ 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 + cookiematch = cookieMatch (dom,path) -- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. @@ -280,119 +245,6 @@ -} --- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. -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] - } - --- | @headerChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header --- @www_auth@ into a 'Challenge' value. -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 = - -- with Maybe monad - 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 - - -- Change These: - 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 - --- | @Authority@ specifies the HTTP Authentication method to use for --- a given domain/realm; @Basic@ or @Digest@. -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] - } - -- | Return authorities for a given domain and path. -- Assumes "dom" is lower case getAuthFor :: String -> String -> BrowserAction t [Authority] @@ -433,6 +285,9 @@ setAllowBasicAuth :: Bool -> BrowserAction t () setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba }) +getAllowBasicAuth :: BrowserAction t Bool +getAllowBasicAuth = getBS bsAllowBasicAuth + -- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts -- to do. If @Nothing@, rever to default max. setMaxAuthAttempts :: Maybe Int -> BrowserAction t () @@ -457,8 +312,10 @@ getMaxErrorRetries = getBS bsMaxErrorRetries -- TO BE CHANGED!!! -pickChallenge :: [Challenge] -> Maybe Challenge -pickChallenge = listToMaybe +pickChallenge :: Bool -> [Challenge] -> Maybe Challenge +pickChallenge allowBasic [] + | allowBasic = Just (ChalBasic "/") -- manufacture a challenge if one missing; more robust. +pickChallenge _ ls = listToMaybe ls -- | Retrieve a likely looking authority for a Request. anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority) @@ -470,33 +327,32 @@ -- | Asking the user to respond to a challenge challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) -challengeToAuthority uri ch = - -- prompt user for authority - 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 +challengeToAuthority uri ch + | not (answerable ch) = return Nothing + | otherwise = do + -- prompt user for authority + prompt <- getAuthorityGen + userdetails <- ioAction $ prompt uri (chRealm ch) + case userdetails of + Nothing -> return Nothing + Just (u,p) -> return (Just $ buildAuth ch u p) + 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 :: Challenge -> String -> String -> Authority + buildAuth (ChalBasic r) u p = + AuthBasic { auSite=uri + , auRealm=r + , auUsername=u + , auPassword=p + } - -- note to self: this is a pretty stupid operation - -- to perform isn't it? ChalX and AuthX are so very - -- similar. - buildAuth (ChalDigest r d n o _stale a q) u p = + -- note to self: this is a pretty stupid operation + -- to perform isn't it? ChalX and AuthX are so very + -- similar. + buildAuth (ChalDigest r d n o _stale a q) u p = AuthDigest { auRealm=r , auUsername=u , auPassword=p @@ -508,74 +364,7 @@ } --- | Generating a credentials value from an Authority, in --- the context of a specific request. If a client nonce --- was to be used then this function might need to --- be of type ... -> BrowserAction String -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 - ++ "\"" - -- plus optional stuff: - ++ ( 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 - - {- - If the "qop" directive's value is "auth" or is unspecified, then A2 - is: - A2 = Method ":" digest-uri-value - If the "qop" value is "auth-int", then A2 is: - A2 = Method ":" digest-uri-value ":" H(entity-body) - -} - a2 = show (rqMethod rq) ++ ":" ++ digesturi - - digesturi = show (rqURI rq) - noncevalue = auNonce a - -type Octet = Word8 - --- FIXME: these probably only work right for latin-1 strings -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) - - ------------------------------------------------------------------ ------------------- Proxy Stuff ----------------------------------- ------------------------------------------------------------------- - --- | @Proxy@ specifies if a proxy should be used for the request. -data Proxy - = NoProxy -- ^ Don't use a proxy. - | Proxy String - (Maybe Authority) -- ^ Use the proxy given. Should be of the form "http:\/\/host:port", "host", "host:port", or "http:\/\/host". Optional 'Authority' to authenticate with the proxy as. - ------------------------------------------------------------------- ------------------ Browser State Actions ------------------------- ------------------------------------------------------------------ @@ -594,6 +383,7 @@ , bsMaxErrorRetries :: Maybe Int , bsMaxAuthAttempts :: Maybe Int , bsConnectionPool :: [connection] + , bsCheckProxy :: Bool , bsProxy :: Proxy , bsDebug :: Maybe String , bsEvent :: Maybe (BrowserEvent connection -> BrowserAction connection ()) @@ -644,7 +434,8 @@ , bsMaxErrorRetries = Nothing , bsMaxAuthAttempts = Nothing , bsConnectionPool = [] - , bsProxy = NoProxy + , bsCheckProxy = defaultAutoProxyDetect + , bsProxy = noProxy , bsDebug = Nothing , bsEvent = Nothing , bsRequestID = 0 @@ -728,12 +519,47 @@ -- as the URL of the proxy to use, possibly authenticating via -- 'Authority' information in @mbAuth@. setProxy :: Proxy -> BrowserAction t () -setProxy p = alterBS (\b -> b {bsProxy = p}) +setProxy p = + -- Note: if user _explicitly_ sets the proxy, we turn + -- off any auto-detection of proxies. + alterBS (\b -> b {bsProxy = p, bsCheckProxy=False}) --- | @getProxy@ returns the current proxy settings. +-- | @getProxy@ returns the current proxy settings. If +-- the auto-proxy flag is set to @True@, @getProxy@ will +-- perform the necessary getProxy :: BrowserAction t Proxy -getProxy = getBS bsProxy +getProxy = do + p <- getBS bsProxy + case p of + -- Note: if there is a proxy, no need to perform any auto-detect. + -- Presumably this is the user's explicit and preferred proxy server. + Proxy{} -> return p + NoProxy{} -> do + flg <- getBS bsCheckProxy + if not flg + then return p + else do + np <- ioAction $ fetchProxy True{-issue warning on stderr if ill-formed...-} + -- note: this resets the check-proxy flag; a one-off affair. + setProxy np + return np +-- | @setCheckForProxy flg@ sets the one-time check for proxy +-- flag to @flg@. If @True@, the session will try to determine +-- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy' +-- for details of how this done. +setCheckForProxy :: Bool -> BrowserAction t () +setCheckForProxy flg = alterBS (\ b -> b{bsCheckProxy=flg}) + +-- | @getCheckForProxy@ returns the current check-proxy setting. +-- Notice that this may not be equal to @True@ if the session has +-- set it to that via 'setCheckForProxy' and subsequently performed +-- some HTTP protocol interactions. i.e., the flag return represents +-- whether a proxy will be checked for again before any future protocol +-- interactions. +getCheckForProxy :: BrowserAction t Bool +getCheckForProxy = getBS bsCheckProxy + -- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@ -- is @Nothing@. If set to @Just fStem@, logs of browser activity -- is appended to files of the form @fStem-url-authority@, i.e., @@ -824,12 +650,17 @@ defaultMaxErrorRetries :: Int defaultMaxErrorRetries = 4 - -- | The default maximum HTTP Authentication attempts we will make for -- a single request. defaultMaxAuthAttempts :: Int defaultMaxAuthAttempts = 2 +-- | The default setting for auto-proxy detection. +-- You may change this within a session via 'setAutoProxyDetect'. +-- To avoid initial backwards compatibility issues, leave this as @False@. +defaultAutoProxyDetect :: Bool +defaultAutoProxyDetect = False + -- | @request httpRequest@ tries to submit the 'Request' @httpRequest@ -- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.) -- Upon successful delivery, the URL where the response was fetched from @@ -838,17 +669,17 @@ => 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 + res <- request' nullVal initialState req + reportEvent ResponseFinish (show (rqURI req)) + case res of + Right r -> return r + Left e -> do + let errStr = ("Network.Browser.request: Error raised " ++ show e) + err errStr + fail errStr + where + initialState = nullRequestState + nullVal = buf_empty bufferOps -- | Internal helper function, explicitly carrying along per-request -- counts. @@ -865,7 +696,15 @@ {- Not for now: (case uriUserInfo uria of "" -> id - xs -> case break (==':') xs of { (as,_:bs) -> withAuth AuthBasic{auUsername=as,auPassword=bs,auRealm="/",auSite=uri} ; _ -> id}) $ do + xs -> + case chopAtDelim ':' xs of + (_,[]) -> id + (usr,pwd) -> withAuth + AuthBasic{ auUserName = usr + , auPassword = pwd + , auRealm = "/" + , auSite = uri + }) $ do -} when (not $ null cookies) (out $ "Adding cookies to request. Cookie names: " ++ unwords (map ckName cookies)) @@ -941,12 +780,17 @@ | 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)) {- do nothing -} + flg <- getAllowBasicAuth + case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> do + out "no challenge" + return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x case au of - Nothing -> return (Right (uri,rsp)) {- do nothing -} + Nothing -> do + out "no auth" + return (Right (uri,rsp)) {- do nothing -} Just au' -> do out "Retrying request with new credentials" request' nullVal @@ -962,7 +806,8 @@ | otherwise -> do out "407 - proxy authentication required" let hdrs = retrieveHeaders HdrProxyAuthenticate rsp - case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of + flg <- getAllowBasicAuth + case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x @@ -1122,30 +967,6 @@ maxPoolSize :: Int maxPoolSize = 5 --- This form junk is completely untested... - -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 } -- What about old query? - } - 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 () -- cut short the silliness. handleCookies uri dom cookieHeaders = do @@ -1159,59 +980,7 @@ (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 "" - - -- all keys in the result list MUST be in lower case - 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 - - - + (errs, newCookies) = processCookieHeaders dom cookieHeaders ------------------------------------------------------------------ ----------------------- Miscellaneous ---------------------------- @@ -1225,12 +994,27 @@ uriDefaultTo a b = maybe a id (a `relativeTo` b) -word, quotedstring :: Parser String -quotedstring = - do { char '"' -- " - ; str <- many (satisfy $ not . (=='"')) - ; char '"' - ; return str - } +-- This form junk is completely untested... -word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) +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 } -- What about old query? + } + 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) + + diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Auth.hs @@ -0,0 +1,219 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Auth +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Representing HTTP Auth values in Haskell. +-- Right now, it contains mostly functionality needed by 'Network.Browser'. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Auth + ( Authority(..) + , Algorithm(..) + , Challenge(..) + , Qop(..) + + , headerToChallenge -- :: URI -> Header -> Maybe Challenge + , withAuthority -- :: Authority -> Request ty -> String + ) where + +import Network.URI +import Network.HTTP.Base +import Network.HTTP.Utils +import Network.HTTP.Headers ( Header(..) ) +import qualified Network.HTTP.MD5 as MD5 (hash) +import qualified Network.HTTP.Base64 as Base64 (encode) +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 ) + +import Data.Char +import Data.Maybe +import Data.Word ( Word8 ) + +-- | @Authority@ specifies the HTTP Authentication method to use for +-- a given domain/realm; @Basic@ or @Digest@. +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] + } + + +data Challenge + = ChalBasic { chRealm :: String } + | ChalDigest { chRealm :: String + , chDomain :: [URI] + , chNonce :: String + , chOpaque :: Maybe String + , chStale :: Bool + , chAlgorithm ::Maybe Algorithm + , chQop :: [Qop] + } + +-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. +data Algorithm = AlgMD5 | AlgMD5sess + deriving(Eq) + +instance Show Algorithm where + show AlgMD5 = "md5" + show AlgMD5sess = "md5-sess" + +-- | +data Qop = QopAuth | QopAuthInt + deriving(Eq,Show) + +-- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority', +-- in the context of the given request. +-- +-- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String +withAuthority :: Authority -> Request ty -> String +withAuthority a rq = case a of + AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) + AuthDigest{} -> + "Digest " ++ + concat [ "username=" ++ quo (auUsername a) + , ",realm=" ++ quo (auRealm a) + , ",nonce=" ++ quo (auNonce a) + , ",uri=" ++ quo digesturi + , ",response=" ++ quo rspdigest + -- plus optional stuff: + , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a)) + , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a)) + , if null (auQop a) then "" else ",qop=auth" + ] + where + quo s = '"':s ++ "\"" + + rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) + + a1, a2 :: String + a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a + + {- + If the "qop" directive's value is "auth" or is unspecified, then A2 + is: + A2 = Method ":" digest-uri-value + If the "qop" value is "auth-int", then A2 is: + A2 = Method ":" digest-uri-value ":" H(entity-body) + -} + a2 = show (rqMethod rq) ++ ":" ++ digesturi + + digesturi = show (rqURI rq) + noncevalue = auNonce a + +type Octet = Word8 + +-- FIXME: these probably only work right for latin-1 strings +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) + + + + +-- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header +-- @www_auth@ into a 'Challenge' value. +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 = + -- with Maybe monad + 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 + + -- Change These: + 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 + +word, quotedstring :: Parser String +quotedstring = + do { char '"' -- " + ; str <- many (satisfy $ not . (=='"')) + ; char '"' + ; return str + } + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff --git a/Network/HTTP/Cookie.hs b/Network/HTTP/Cookie.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Cookie.hs @@ -0,0 +1,145 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Cookie +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- This module provides the data types and functions for working with HTTP cookies. +-- Right now, it contains mostly functionality needed by 'Network.Browser'. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Cookie + ( Cookie(..) + , cookieMatch -- :: (String,String) -> Cookie -> Bool + + -- functions for translating cookies and headers. + , cookieToHeader -- :: Cookie -> Header + , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) + ) where + +import Network.HTTP.Headers + +import Data.Char +import Data.List +import Data.Maybe + +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, option, try + , (<|>), sepBy1 + ) + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- | @Cookie@ is the Haskell representation of HTTP cookie values. +-- See its relevant specs for authoritative details. +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 + +-- | @cookieToHeader ck@ serialises a @Cookie@ to an HTTP request header. +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 + + +-- | @cookieMatch (domain,path) ck@ performs the standard cookie +-- match wrt the given domain and path. +cookieMatch :: (String, String) -> Cookie -> Bool +cookieMatch (dom,path) ck = + ckDomain ck `isSuffixOf` dom && + case ckPath ck of + Nothing -> True + Just p -> p `isPrefixOf` path + + +-- | @processCookieHeaders dom hdrs@ +processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) +processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs + +-- | @headerToCookies dom hdr acc@ +headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = + case parse cookies "" val of + Left{} -> (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 "" + + -- all keys in the result list MUST be in lower case + 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 + + + + +word, quotedstring :: Parser String +quotedstring = + do { char '"' -- " + ; str <- many (satisfy $ not . (=='"')) + ; char '"' + ; return str + } + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Proxy.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Proxy +-- Copyright : (c) 2009 Eric Kow +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Author : Eric Kow +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Handling proxy server settings and their resolution. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Proxy + ( Proxy(..) + , noProxy -- :: Proxy + , fetchProxy -- :: Bool -> IO Proxy + , parseProxy -- :: String -> Maybe Proxy + ) where + +import Control.Monad ( when, mplus, join, liftM2) + +import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) +import Network.HTTP.Auth +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI ) +import System.IO ( hPutStrLn, stderr ) +import System.Environment + +{- +#if !defined(WIN32) && defined(mingw32_HOST_OS) +#define WIN32 1 +#endif +-} + +#if defined(WIN32) +import System.Win32.Types ( DWORD, HKEY ) +import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx ) +import Control.Exception ( bracket ) +import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#endif + +-- | HTTP proxies (or not) are represented via 'Proxy', specifying if a +-- proxy should be used for the request (see 'Network.Browser.setProxy') +data Proxy + = NoProxy -- ^ Don't use a proxy. + | Proxy String + (Maybe Authority) -- ^ Use the proxy given. Should be of the + -- form "http:\/\/host:port", "host", "host:port", or "http:\/\/host". + -- Additionally, an optional 'Authority' for authentication with the proxy. + + +noProxy :: Proxy +noProxy = NoProxy + +-- | @envProxyString@ locates proxy server settings by looking +-- up env variable @HTTP_PROXY@ (or its lower-case equivalent.) +-- If no mapping found, returns @Nothing@. +envProxyString :: IO (Maybe String) +envProxyString = do + env <- getEnvironment + return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) + +-- | @proxyString@ tries to locate the user's proxy server setting. +-- Consults environment variable, and in case of Windows, by querying +-- the Registry (cf. @registryProxyString@.) +proxyString :: IO (Maybe String) +proxyString = liftM2 mplus envProxyString registryProxyString + +registryProxyString :: IO (Maybe String) +#if !defined(WIN32) +registryProxyString = return Nothing +#else +registryProxyLoc :: (HKEY,String) +registryProxyLoc = (hive, path) + where + -- some sources say proxy settings should be at + -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows + -- \CurrentVersion\Internet Settings\ProxyServer + -- but if the user sets them with IE connection panel they seem to + -- end up in the following place: + hive = hKEY_CURRENT_USER + path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" + +-- read proxy settings from the windows registry; this is just a best +-- effort and may not work on all setups. +registryProxyString = Prelude.catch + (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do + enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" + if enable + then fmap Just $ regQueryValue hkey (Just "ProxyServer") + else return Nothing) + (\_ -> return Nothing) +#endif + +-- | @fetchProxy flg@ gets the local proxy settings and parse the string +-- into a @Proxy@ value. If you want to be informed of ill-formed proxy +-- configuration strings, supply @True@ for @flg@. +-- Proxy settings are sourced from the @HTTP_PROXY@ environment variable, +-- and in the case of Windows platforms, by consulting IE/WinInet's proxy +-- setting in the Registry. +fetchProxy :: Bool -> IO Proxy +fetchProxy warnIfIllformed = do + mstr <- proxyString + case mstr of + Nothing -> return NoProxy + Just str -> case parseProxy str of + Just p -> return p + Nothing -> do + when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines + [ "invalid http proxy uri: " ++ show str + , "proxy uri must be http with a hostname" + , "ignoring http proxy, trying a direct connection" + ] + return NoProxy + +-- | @parseProxy str@ translates a proxy server string into a @Proxy@ value; +-- returns @Nothing@ if not well-formed. +parseProxy :: String -> Maybe Proxy +parseProxy str = join + . fmap uri2proxy + $ parseHttpURI str + `mplus` parseHttpURI ("http://" ++ str) + where + parseHttpURI str' = + case parseAbsoluteURI str' of + Just uri@URI{uriAuthority = Just{}} -> Just (fixUserInfo uri) + _ -> Nothing + + -- Note: we need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ + -- which lack the @\"http://\"@ URI scheme. The problem is that + -- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme + -- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. + -- + -- So our strategy is to try parsing as normal uri first and if it lacks the + -- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. + -- + +-- | tidy up user portion, don't want the trailing "\@". +fixUserInfo :: URI -> URI +fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } + where + f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s} + +-- +uri2proxy :: URI -> Maybe Proxy +uri2proxy uri@URI{ uriScheme = "http:" + , uriAuthority = Just (URIAuth auth' hst prt) + } = + Just (Proxy (hst ++ prt) auth) + where + auth = + case auth' of + [] -> Nothing + as -> Just (AuthBasic "" usr pwd uri) + where + (usr,pwd) = chopAtDelim ':' as + +uri2proxy _ = Nothing + +-- utilities +#if defined(WIN32) +regQueryValueDWORD :: HKEY -> String -> IO DWORD +regQueryValueDWORD hkey name = alloca $ \ptr -> do + regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) + peek ptr + +#endif diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs --- a/Network/HTTP/Utils.hs +++ b/Network/HTTP/Utils.hs @@ -22,6 +22,9 @@ , splitBy -- :: Eq a => a -> [a] -> [[a]] , readsOne -- :: Read a => (a -> b) -> b -> String -> b + + , dropWhileTail -- :: (a -> Bool) -> [a] -> [a] + , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a]) ) where @@ -81,3 +84,23 @@ ((v,_):_) -> f v _ -> n + +-- | @dropWhileTail p ls@ chops off trailing elements from @ls@ +-- until @p@ returns @False@. +dropWhileTail :: (a -> Bool) -> [a] -> [a] +dropWhileTail f ls = + case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] } + where + chop x (Just xs) = Just (x:xs) + chop x _ + | f x = Nothing + | otherwise = Just [x] + +-- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence +-- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second +-- list is empty and the first is equal to @ls@. +chopAtDelim :: Eq a => a -> [a] -> ([a],[a]) +chopAtDelim elt xs = + case break (==elt) xs of + (_,[]) -> (xs,[]) + (as,_:bs) -> (as,bs)