4 files changed, 26 insertions(+), 21 deletions(-)

M hurl.cabal
M src/Network/URI/Charset.hs
M src/Network/URI/Fetch.hs
M src/Network/URI/Messages.hs

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

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

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

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