From 984867b7a2acdcdc46cd340ecb0e778582d1dc0f Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 18 Apr 2020 08:36:28 +1200 Subject: [PATCH] Define special psuedo-MIMEtypes for error responses. --- src/Network/URI/Charset.hs | 4 +++- src/Network/URI/Fetch.hs | 30 ++++++++++++++++++------------ src/Network/URI/Messages.hs | 3 ++- 3 files changed, 23 insertions(+), 14 deletions(-) diff --git a/src/Network/URI/Charset.hs b/src/Network/URI/Charset.hs index 5751eef..1f914ee 100644 --- a/src/Network/URI/Charset.hs +++ b/src/Network/URI/Charset.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) diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs index f5c1fab..3acadab 100644 --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -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) diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs index d146b25..0abdb03 100644 --- a/src/Network/URI/Messages.hs +++ b/src/Network/URI/Messages.hs @@ -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 -- 2.30.2