summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2020-04-18 08:36:28 +1200
committerAdrian Cochrane <adrian@openwork.nz>2020-04-18 08:36:28 +1200
commit984867b7a2acdcdc46cd340ecb0e778582d1dc0f (patch)
treea651f27c5d9f0d01b33d72b1d4bf6d26cad99767
parent861a5e49ddfffaec848bfeabd6c2a1a0ed8c7d31 (diff)
downloadhurl-984867b7a2acdcdc46cd340ecb0e778582d1dc0f.tar.gz
hurl-984867b7a2acdcdc46cd340ecb0e778582d1dc0f.tar.bz2
hurl-984867b7a2acdcdc46cd340ecb0e778582d1dc0f.zip
Define special psuedo-MIMEtypes for error responses.
-rw-r--r--src/Network/URI/Charset.hs4
-rw-r--r--src/Network/URI/Fetch.hs30
-rw-r--r--src/Network/URI/Messages.hs3
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