HTTP 4000.0.7 → 4000.0.8

raw patch · 7 files changed

+733/−364 lines, 7 filesdep +Win32dep ~basedep ~networkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Win32

Dependency ranges changed: base, network

API changes (from Hackage documentation)

Files

• CHANGES +22/−0
• HTTP.cabal +8/−2
• Network/Browser.hs +146/−362
• Network/HTTP/Auth.hs +219/−0
• Network/HTTP/Cookie.hs +145/−0
• Network/HTTP/Proxy.hs +170/−0
• Network/HTTP/Utils.hs +23/−0

@@ -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.

@@ -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

@@ -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)++

@@ -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 <sigbjorn.finne@gmail.com>+-- 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==':'))

@@ -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 <sigbjorn.finne@gmail.com>+-- 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==':'))

@@ -0,0 +1,170 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Proxy+-- Copyright   :  (c) 2009 Eric Kow+-- License     :  BSD+-- +-- Maintainer  :  Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Author      :  Eric Kow <E.Y.Kow@brighton.ac.uk>+-- 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

@@ -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)