3 files changed, 23 insertions(+), 14 deletions(-)

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

@@ 16,7 16,9 @@ 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] response = (mime, Right $ response)
-resolveCharset [] response = ("text/plain", Left "Filetype unspecified")
+-- 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")
 
 -- | As per `resolveCharset`, but also returns given URI (or other type).
 resolveCharset' :: a -> [String] -> ByteString -> (a, String, Either Text ByteString)

@@ 2,7 2,9 @@
 {-# 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, newSession, fetchURL, dispatchByMIME, saveDownload, downloadToURI) where
+module Network.URI.Fetch(Session, locale, newSession,
+    fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,
+    dispatchByMIME, saveDownload, downloadToURI) where
 
 import qualified Data.Text as Txt
 import           Data.Text (Text)


@@ 108,6 110,11 @@ fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteStri
 fetchURLs sess mimes uris cb =
     forConcurrently uris (\u -> fetchURL' sess mimes u >>= cb) >>= return . zip uris
 
+-- | Internal MIMEtypes for error reporting
+mimeERR, htmlERR :: String
+mimeERR = "txt/x-error\t"
+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 mimes uri@(URI {uriScheme = "about:", uriPath = ""}) =


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


@@ 170,14 177,14 @@ fetchURL' sess@Session {connCtxt = ctxt} mimes uri@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 (uri, "text/plain", Left err)
+            (_, _, err) -> return (uri, mimeERR, Left err)
         connectionClose conn
         return ret
     where
         parseHeader header
             | Just (major, header') <- Txt.uncons $ convertCharset "utf-8" header,
                 Just (minor, meta) <- Txt.uncons header' = (major, minor, Txt.strip meta)
-            | otherwise = ('4', '1', "Invalid response!")
+            | otherwise = ('4', '1', Txt.pack $ trans l MalformedResponse)
 #endif
 
 #ifdef WITH_FILE_URI


@@ 185,8 192,7 @@ fetchURL' Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = d
     response <- B.readFile $ uriPath uri
     return (uri, defaultMIME, Right response)
   `catch` \e -> do
-    return (uri,
-        "text/plain",
+    return (uri, mimeERR,
         Left $ Txt.pack $ trans l $ ReadFailed $ displayException (e :: IOException))
 #endif
 


@@ 197,7 203,7 @@ fetchURL' _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
         ("", response) -> return (uri, defaultMIME, Left $ Txt.pack response)
         (mime', response) | '4':'6':'e':'s':'a':'b':';':mime <- reverse mime' ->
             return $ case B64.decode $ B.fromStrict $ C8.pack response of
-                Left str -> (uri, "text/plain", Left $ Txt.pack $ unEscapeString str)
+                Left str -> (uri, mimeERR, Left $ Txt.pack $ unEscapeString str)
                 Right bytes -> (uri, reverse mime, Right bytes)
         (mime, response) -> return (uri, mime, Left $ Txt.pack response)
 #endif


@@ 205,10 211,10 @@ fetchURL' _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
 #ifdef WITH_XDG
 fetchURL' Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do
         app <- dispatchURIByMIME a uri ("x-scheme-handler/" ++ init s)
-        return (uri, "text/html", Left $ Txt.pack $ trans l $ app)
+        return (uri, htmlERR, Left $ Txt.pack $ trans l $ app)
 #else
 fetchURL' Session {locale = l} _ URI {uriScheme = scheme} =
-    return (uri, "text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)
+    return (uri, mimeERR, Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)
 #endif
 
 dispatchByMIME :: Session -> String -> URI -> IO (Maybe String)

@@ 28,6 28,7 @@ trans ("en":_) (RequiresInstall mime appsMarkup) =
   where linkType = fromMaybe mime $ stripPrefix "x-scheme-handler/" mime
 trans ("en":_) (OpenedWith app) = "Opened in " ++ app
 trans ("en":_) (ReadFailed msg) = "Failed to read file: " ++ msg
+trans ("en":_) MalformedResponse = "Invalid response!"
 #if WITH_HTTP_URI
 trans ("en":_) (Http (InvalidUrlException url msg)) = "Invalid URL " ++ url ++ ": " ++ msg
 trans ("en":_) (Http (HttpExceptionRequest _ (TooManyRedirects _))) = "Too many redirects!"


@@ 42,7 43,7 @@ trans (_:locales) err = trans locales err
 trans [] err = trans ["en"] err
 
 data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String
-    | OpenedWith String | ReadFailed String | RawXML String
+    | OpenedWith String | ReadFailed String | RawXML String | MalformedResponse
 #if WITH_HTTP_URI
     | Http HttpException
 #endif