summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2012-06-05 04:07:49 (GMT)
committerhdiff <hdiff@luite.com>2012-06-05 04:07:49 (GMT)
commita9ef2886259e8385497014f52118997900d7b814 (patch)
tree6f742f23e14cdcbf7515800caf6f5d88686bbb83
parent60d386694774fb373d6b1bc4dd24a9ce330d59d9 (diff)
version 1.4.1.81.4.1.8
-rw-r--r--Network/HTTP/Conduit.hs2
-rw-r--r--Network/HTTP/Conduit/Request.hs138
-rw-r--r--Network/HTTP/Conduit/Response.hs24
-rw-r--r--http-conduit.cabal3
4 files changed, 79 insertions, 88 deletions
diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs
index 54a892f..997fa1c 100644
--- 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
index 2286332..28dd97a 100644
--- a/Network/HTTP/Conduit/Request.hs
+++ b/Network/HTTP/Conduit/Request.hs
@@ -7,6 +7,7 @@ module Network.HTTP.Conduit.Request
, ContentType
, Proxy (..)
, parseUrl
+ , setUriRelative
, browserDecompress
, HttpException (..)
, alwaysDecompress
@@ -37,6 +38,7 @@ import qualified Data.ByteString.Lazy as L
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 @@ data Proxy = Proxy
, 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,16 +134,76 @@ encodeUrlChar y =
-- 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"
-
-parseUrl1 :: Failure HttpException m
- => String -> Bool -> String -> m (Request m')
-parseUrl1 full sec s =
- parseUrl2 full sec s'
+parseUrl s =
+ case parseURI (encode s) of
+ Just uri -> setUri def uri
+ Nothing -> failure $ InvalidUrlException s "Invalid URL"
where
- s' = encodeString s
+ encode = escapeURIString isAllowedInURI . encodeString
+
+-- | 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
+ 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
@@ -189,39 +226,6 @@ instance Default (Request m) where
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
| TooManyRedirects
diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs
index 13a15dd..8ee48b1 100644
--- a/Network/HTTP/Conduit/Response.hs
+++ b/Network/HTTP/Conduit/Response.hs
@@ -31,6 +31,7 @@ import qualified Data.Conduit.List as CL
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 :: Request m -> W.ResponseHeaders -> Int -> Maybe (Request
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
index 0b6016d..8907349 100644
--- 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 <michael@snoyman.com>
@@ -115,6 +115,7 @@ test-suite test
, resourcet
, void
, deepseq
+ , mtl
source-repository head
type: git