summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--hurl.cabal2
-rw-r--r--src/Network/URI/Charset.hs10
-rw-r--r--src/Network/URI/Fetch.hs33
-rw-r--r--src/Network/URI/Messages.hs2
4 files changed, 26 insertions, 21 deletions
diff --git a/hurl.cabal b/hurl.cabal
index 3740b32..0693af8 100644
--- a/hurl.cabal
+++ b/hurl.cabal
@@ -10,7 +10,7 @@ name: hurl
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 1.4.1.0
+version: 1.4.2.0
-- A short (one-line) description of the package.
synopsis: Haskell URL resolver
diff --git a/src/Network/URI/Charset.hs b/src/Network/URI/Charset.hs
index ac1df5d..2b200fb 100644
--- a/src/Network/URI/Charset.hs
+++ b/src/Network/URI/Charset.hs
@@ -7,19 +7,23 @@ import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B
import Data.Text.Encoding
import Debug.Trace (trace)
+import Data.List (intercalate)
-- | If the MIMEtype specifies a charset parameter, apply it.
resolveCharset :: [String] -- ^ The MIMEtype, split by ';'
-> ByteString -- ^ The bytes received from the server
-> (String, Either Text ByteString) -- ^ The MIMEtype (minus parameters) & possibly decoded text, to be returned from protocol handlers.
-resolveCharset (mime:('c':'h':'a':'r':'s':'e':'t':'=':charset):_) response =
- (mime, Left $ convertCharset charset $ B.toStrict response)
-resolveCharset (mime:_:params) response = resolveCharset (mime:params) response
+resolveCharset (mime:('c':'h':'a':'r':'s':'e':'t':'=':charset):params) response =
+ (parameterizedMIME mime params, Left $ convertCharset charset $ B.toStrict response)
+resolveCharset (mime:param:params) response =
+ resolveCharset (parameterizedMIME mime [param]:params) response
resolveCharset [mime] response = (mime, Right $ response)
-- NOTE I can't localize this error string because resolveCharset doesn't know the locale.
-- I don't think this is worth fixing, because hitting this indicates the server is badly misbehaving.
resolveCharset [] response = ("text/x-error\t", Left "Filetype unspecified")
+parameterizedMIME mime params = mime ++ ";" ++ intercalate ";" params
+
-- | As per `resolveCharset`, but also returns given URI (or other type).
resolveCharset' :: a -> [String] -> ByteString -> (a, String, Either Text ByteString)
resolveCharset' a mimes resp = let (mime, resp') = resolveCharset mimes resp in (a, mime, resp')
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 1767d95..58bd6ae 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Retrieves documents for a URL, supporting multiple URL schemes that can be
-- disabled at build-time for reduced dependencies.
-module Network.URI.Fetch(Session(locale, aboutPages), newSession,
+module Network.URI.Fetch(Session(locale, aboutPages, redirectCount), newSession,
fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,
dispatchByMIME, saveDownload, downloadToURI,
-- logging API
@@ -84,7 +84,9 @@ data Session = Session {
-- | Additional files to serve from about: URIs.
aboutPages :: [(FilePath, ByteString)],
-- | Log of timestamped/profiled URL requests
- requestLog :: MVar [LogRecord]
+ requestLog :: MVar [LogRecord],
+ -- | How many redirects to follow for Gemini or HTTP(S) requests
+ redirectCount :: Int
}
data LogRecord = LogRecord {
@@ -143,7 +145,8 @@ newSession' appname = do
#endif
locale = ietfLocale,
aboutPages = [],
- requestLog = log
+ requestLog = log,
+ redirectCount = 5
}
llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key]
@@ -181,6 +184,9 @@ htmlERR = "html/x-error\t"
-- | As per `fetchURL`, but also returns the redirected URI.
fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString)
+fetchURL' Session {redirectCount = 0, locale = locale'} _ uri =
+ return (uri, mimeERR, Left $ Txt.pack $ trans locale' ExcessiveRedirects)
+
#ifdef WITH_PLUGIN_REWRITES
fetchURL' session mimes uri
| Just uri' <- applyRewriter (rewriter session) uri = fetchURL' session mimes uri'
@@ -202,7 +208,8 @@ fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "h
HTTP.requestHeaders = [
("Accept", C8.pack $ intercalate ", " accept),
("Accept-Language", C8.pack $ intercalate ", " $ locale session)
- ]
+ ],
+ HTTP.redirectCount = redirectCount session
} $ managerHTTP session
return $ case (
HTTP.responseBody response,
@@ -233,11 +240,13 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI {
"<input /></label></form>"
])
('2', _, mime) -> do
- body <- B.hGetContents input'
+ body <- Strict.hGetContents input'
let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime
- return $ resolveCharset' uri mime' body
+ return $ resolveCharset' uri mime' $ B.fromStrict body
('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect ->
- fetchURL' sess mimes $ relativeTo redirect' uri
+ fetchURL' sess {
+ redirectCount = redirectCount sess - 1
+ } mimes $ relativeTo redirect' uri
-- TODO Implement client certificates, once I have a way for the user/caller to select one.
-- And once I figure out how to configure the TLS cryptography.
(_, _, err) -> return (uri, mimeERR, Left err)
@@ -358,13 +367,3 @@ breakOn c (a:as) | c == a = ([], as)
| otherwise = let (x, y) = breakOn c as in (a:x, y)
breakOn _ [] = ([], [])
#endif
-
-#ifdef WITH_GEMINI_URI
-mWhile test body = do
- cond <- test
- if cond then do
- x <- body
- xs <- mWhile test body
- return (x:xs)
- else return []
-#endif
diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs
index 0abdb03..15c27e8 100644
--- a/src/Network/URI/Messages.hs
+++ b/src/Network/URI/Messages.hs
@@ -29,6 +29,7 @@ trans ("en":_) (RequiresInstall mime appsMarkup) =
trans ("en":_) (OpenedWith app) = "Opened in " ++ app
trans ("en":_) (ReadFailed msg) = "Failed to read file: " ++ msg
trans ("en":_) MalformedResponse = "Invalid response!"
+trans ("en":_) ExcessiveRedirects = "Too many redirects!"
#if WITH_HTTP_URI
trans ("en":_) (Http (InvalidUrlException url msg)) = "Invalid URL " ++ url ++ ": " ++ msg
trans ("en":_) (Http (HttpExceptionRequest _ (TooManyRedirects _))) = "Too many redirects!"
@@ -44,6 +45,7 @@ trans [] err = trans ["en"] err
data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String
| OpenedWith String | ReadFailed String | RawXML String | MalformedResponse
+ | ExcessiveRedirects
#if WITH_HTTP_URI
| Http HttpException
#endif