2 files changed, 38 insertions(+), 28 deletions(-)

M src/Network/URI/Charset.hs
M src/Network/URI/Fetch.hs

@@ 1,7 1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Handles server-specified text decoding.
-module Network.URI.Charset(resolveCharset, convertCharset, charsets) where
+module Network.URI.Charset(resolveCharset, resolveCharset', convertCharset, charsets) where
 import           Data.Text (Text)
 import           Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy as B


@@ 18,6 18,10 @@ resolveCharset (mime:_:params) response = resolveCharset (mime:params) response
 resolveCharset [mime] response = (mime, Right $ response)
 resolveCharset [] response = ("text/plain", Left "Filetype unspecified")
 
+-- | 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')
+
 -- | Decodes bytes according to a charset identified by it's IANA-assigned name(s).
 convertCharset "iso-8859-1" = decodeLatin1
 convertCharset "latin1" = decodeLatin1

@@ 94,16 94,22 @@ fetchURL :: Session -- ^ The session of which this request is a part.
     -> [String] -- ^ The expected MIMEtypes in priority order.
     -> URI -- ^ The URL to retrieve
     -> IO (String, Either Text ByteString) -- ^ The MIMEtype & possibly text-decoded response.
-fetchURL session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) =
-    fetchURL session mimes $ uri {uriPath = "version"}
-fetchURL Session {aboutPages = pages} _ URI {uriScheme = "about:", uriPath = path} =
-    return (
+fetchURL sess mimes uri = do
+    (_, mime, resp) <- fetchURL' sess mimes uri
+    return (mime, resp)
+
+-- | As per `fetchURL`, but also returns the redirected URI.
+fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString)
+fetchURL' session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) =
+    fetchURL' session mimes $ uri {uriPath = "version"}
+fetchURL' Session {aboutPages = pages} _ url@URI {uriScheme = "about:", uriPath = path} =
+    return (url,
         Txt.unpack $ convertCharset "utf-8" $ B.toStrict $
             llookup (path ++ ".mime") "text/html" pages,
         Right $ llookup path "" pages)
 
 #ifdef WITH_HTTP_URI
-fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do
+fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do
     request <- HTTP.requestFromURI uri
     response <- HTTP.httpLbs request {
             HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form.


@@ 116,18 122,18 @@ fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "ht
             HTTP.responseBody response,
             [val | ("content-type", val) <- HTTP.responseHeaders response]
       ) of
-        ("", _) -> ("text/plain", Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response)
+        ("", _) -> (uri, "text/plain", Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response)
         (response, (mimetype:_)) -> let mime = Txt.toLower $ convertCharset "utf-8" mimetype
-            in resolveCharset (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime) response
-        (response, []) -> (defaultMIME, Right response)
+            in resolveCharset' uri (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime) response
+        (response, []) -> (uri, defaultMIME, Right response)
   `catches` [
-    Handler $ \e -> do return ("text/plain", Left $ Txt.pack $ trans (locale session) $ Http e),
-    Handler $ \(ErrorCall msg) -> do return ("text/plain", Left $ Txt.pack msg)
+    Handler $ \e -> do return (uri, "text/plain", Left $ Txt.pack $ trans (locale session) $ Http e),
+    Handler $ \(ErrorCall msg) -> do return (uri, "text/plain", Left $ Txt.pack msg)
   ]
 #endif
 
 #ifdef WITH_GEMINI_URI
-fetchURL sess@Session {connCtxt = ctxt} mimes uri@URI {
+fetchURL' sess@Session {connCtxt = ctxt} mimes uri@URI {
         uriScheme = "gemini:", uriAuthority = Just (URIAuth _ host port)
     } = do
         conn <- connectTo ctxt $ ConnectionParams {


@@ 141,7 147,7 @@ fetchURL sess@Session {connCtxt = ctxt} mimes uri@URI {
         header <- connectionGetLine 1024 conn
         ret <- case parseHeader header of
             -- NOTE: This case won't actually do anything until the caller (Rhapsode) implements forms.
-            ('1', _, label) -> return ("application/xhtml+xml", Left $ Txt.concat [
+            ('1', _, label) -> return (uri, "application/xhtml+xml", Left $ Txt.concat [
                     "<form><label for='input'>",
                     Txt.replace "<" "&lt;" $ Txt.replace "&" "&amp;" label,
                     "</label><input id='input' /></form>"


@@ 149,12 155,12 @@ fetchURL sess@Session {connCtxt = ctxt} mimes uri@URI {
             ('2', _, mime) -> do
                 chunks <- mWhile (connectionWaitForInput conn 60000) $ connectionGetChunk conn
                 let mime' = map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime
-                return $ resolveCharset mime' $ B.fromChunks chunks
+                return $ resolveCharset' uri mime' $ B.fromChunks chunks
             ('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect ->
-                fetchURL sess mimes $ relativeTo redirect' uri
+                fetchURL' sess 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 ("text/plain", Left err)
+            (_, _, err) -> return (uri, "text/plain", Left err)
         connectionClose conn
         return ret
     where


@@ 165,34 171,34 @@ fetchURL sess@Session {connCtxt = ctxt} mimes uri@URI {
 #endif
 
 #ifdef WITH_FILE_URI
-fetchURL Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do
+fetchURL' Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do
     response <- B.readFile $ uriPath uri
-    return (defaultMIME, Right response)
+    return (uri, defaultMIME, Right response)
   `catch` \e -> do
-    return (
+    return (uri,
         "text/plain",
         Left $ Txt.pack $ trans l $ ReadFailed $ displayException (e :: IOException))
 #endif
 
 #ifdef WITH_DATA_URI
-fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
+fetchURL' _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
     let request = uriPath uri ++ uriQuery uri ++ uriFragment uri
     in case breakOn ',' $ unEscapeString request of
-        ("", response) -> return (defaultMIME, Left $ Txt.pack response)
+        ("", response) -> return (uri, defaultMIME, Left $ Txt.pack response)
         (mime', response) | '4':'6':'e':'s':'a':'b':';':mime <- reverse mime' ->
             return $ case B64.decode $ C8.pack response of
-                Left str -> ("text/plain", Left $ Txt.pack str)
-                Right bytes -> (reverse mime, Right $ B.fromStrict bytes)
-        (mime, response) -> return (mime, Left $ Txt.pack response)
+                Left str -> (uri, "text/plain", Left $ Txt.pack str)
+                Right bytes -> (uri, reverse mime, Right $ B.fromStrict bytes)
+        (mime, response) -> return (uri, mime, Left $ Txt.pack response)
 #endif
 
 #ifdef WITH_XDG
-fetchURL Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do
+fetchURL' Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do
         app <- dispatchURIByMIME a uri ("x-scheme-handler/" ++ init s)
-        return ("text/html", Left $ Txt.pack $ trans l $ app)
+        return (uri, "text/html", Left $ Txt.pack $ trans l $ app)
 #else
-fetchURL Session {locale = l} _ URI {uriScheme = scheme} =
-    return ("text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)
+fetchURL' Session {locale = l} _ URI {uriScheme = scheme} =
+    return (uri, "text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)
 #endif
 
 dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)