diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -23,7 +23,7 @@ -- > main = do -- > request <- parseUrl "http://google.com/" -- > withManager $ \manager -> do --- > Response _ _ src <- http request manager +-- > Response _ _ _ src <- http request manager -- > src C.$$ sinkFile "google.html" -- -- The following headers are automatically set by this module, and should not diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs --- a/Network/HTTP/Conduit/Request.hs +++ b/Network/HTTP/Conduit/Request.hs @@ -7,6 +7,7 @@ , ContentType , Proxy (..) , parseUrl + , setUriRelative , browserDecompress , HttpException (..) , alwaysDecompress @@ -37,6 +38,7 @@ import qualified Network.HTTP.Types as W import Network.Socks5 (SocksConf) +import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI) import Control.Exception (Exception, SomeException, toException) import Control.Failure (Failure (failure)) @@ -124,31 +126,6 @@ , proxyPort :: Int -- ^ The port number of the HTTP proxy. } -encodeUrlCharPI :: Char -> String -encodeUrlCharPI '/' = "/" -encodeUrlCharPI '%' = "%" -encodeUrlCharPI c = encodeUrlChar c - -encodeUrlChar :: Char -> String -encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] -encodeUrlChar c@'-' = [c] -encodeUrlChar c@'_' = [c] -encodeUrlChar c@'.' = [c] -encodeUrlChar c@'~' = [c] -encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] - -- | Convert a URL into a 'Request'. -- -- This defaults some of the values in 'Request', such as setting 'method' to @@ -157,17 +134,77 @@ -- Since this function uses 'Failure', the return monad can be anything that is -- an instance of 'Failure', such as 'IO' or 'Maybe'. parseUrl :: Failure HttpException m => String -> m (Request m') -parseUrl s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False rest -parseUrl s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True rest -parseUrl x = failure $ InvalidUrlException x "Invalid scheme" +parseUrl s = + case parseURI (encode s) of + Just uri -> setUri def uri + Nothing -> failure $ InvalidUrlException s "Invalid URL" + where + encode = escapeURIString isAllowedInURI . encodeString -parseUrl1 :: Failure HttpException m - => String -> Bool -> String -> m (Request m') -parseUrl1 full sec s = - parseUrl2 full sec s' +-- | Add a 'URI' to the request. If it is absolute (includes a host name), add +-- it as per 'setUri'; if it is relative, merge it with the existing request. +setUriRelative :: Failure HttpException m => Request m' -> URI -> m (Request m') +setUriRelative req uri = + case uri `relativeTo` getUri req of + Just uri' -> setUri req uri' + Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL" + +-- | Extract a 'URI' from the request. +getUri :: Request m' -> URI +getUri req = URI + { uriScheme = if secure req + then "https:" + else "http:" + , uriAuthority = Just URIAuth + { uriUserInfo = "" + , uriRegName = S8.unpack $ host req + , uriPort = ':' : show (port req) + } + , uriPath = S8.unpack $ path req + , uriQuery = S8.unpack $ queryString req + , uriFragment = "" + } + +-- | Validate a 'URI', then add it to the request. +setUri :: Failure HttpException m => Request m' -> URI -> m (Request m') +setUri req uri = do + sec <- parseScheme uri + auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri + if not . null $ uriUserInfo auth + then failUri "URL auth not supported; use applyBasicAuth instead" + else return () + port' <- parsePort sec auth + return req + { host = S8.pack $ uriRegName auth + , port = port' + , secure = sec + , path = S8.pack $ + if null $ uriPath uri + then "/" + else uriPath uri + , queryString = S8.pack $ uriQuery uri + } where - s' = encodeString s + failUri = failure . InvalidUrlException (show uri) + parseScheme URI{uriScheme = scheme} = + case scheme of + "http:" -> return False + "https:" -> return True + _ -> failUri "Invalid scheme" + + parsePort sec URIAuth{uriPort = portStr} = + case portStr of + -- If the user specifies a port, then use it + ':':rest -> maybe + (failUri "Invalid port") + return + (readDec rest) + -- Otherwise, use the default port + _ -> case sec of + False {- HTTP -} -> return 80 + True {- HTTPS -} -> return 443 + instance Default (Request m) where def = Request { host = "localhost" @@ -188,39 +225,6 @@ then Nothing else Just $ toException $ StatusCodeException s hs } - -parseUrl2 :: Failure HttpException m - => String -> Bool -> String -> m (Request m') -parseUrl2 full sec s = do - port' <- mport - return def - { host = S8.pack hostname - , port = port' - , secure = sec - , path = S8.pack - $ if null path'' - then "/" - else concatMap encodeUrlCharPI path'' - , queryString = S8.pack qstring - } - where - (beforeSlash, afterSlash) = break (== '/') s - (hostname, portStr) = break (== ':') beforeSlash - (path', qstring') = break (== '?') afterSlash - path'' = path' - qstring'' = case qstring' of - '?':x -> x - _ -> qstring' - qstring = takeWhile (/= '#') qstring'' - mport = - case (portStr, sec) of - ("", False) -> return 80 - ("", True) -> return 443 - (':':rest, _) -> maybe - (failure $ InvalidUrlException full "Invalid port") - return - (readDec rest) - x -> error $ "parseUrl1: this should never happen: " ++ show x data HttpException = StatusCodeException W.Status W.ResponseHeaders | InvalidUrlException String String diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs --- a/Network/HTTP/Conduit/Response.hs +++ b/Network/HTTP/Conduit/Response.hs @@ -31,6 +31,7 @@ import qualified Data.Conduit.Internal import qualified Network.HTTP.Types as W +import Network.URI (parseURIReference) import Network.HTTP.Conduit.Manager import Network.HTTP.Conduit.Request @@ -73,31 +74,16 @@ getRedirectedRequest req hs code | 300 <= code && code < 400 = do l' <- lookup "location" hs - l <- parseUrl $ case S8.uncons l' of - Just ('/', _) -> concat - [ "http" - , if secure req then "s" else "" - , "://" - , S8.unpack $ host req - , ":" - , show $ port req - , S8.unpack l' - ] - _ -> S8.unpack l' - return req - { host = host l - , port = port l - , secure = secure l - , path = path l - , queryString = queryString l - , method = + req' <- setUriRelative req =<< parseURIReference (S8.unpack l') + return req' + { method = -- According to the spec, this should *only* be for -- status code 303. However, almost all clients -- mistakenly implement it for 302 as well. So we -- have to be wrong like everyone else... if code == 302 || code == 303 then "GET" - else method l + else method req' } | otherwise = Nothing diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 1.4.1.7 +version: 1.4.1.8 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -115,6 +115,7 @@ , resourcet , void , deepseq + , mtl source-repository head type: git