summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <alcinnz@lavabit.com>2022-08-04 21:44:19 +1200
committerAdrian Cochrane <alcinnz@lavabit.com>2022-08-04 21:44:19 +1200
commit5c4812d56d065967a78916152634edb78696237a (patch)
tree05f8451b231024e84dab16c62b10a30e82635019
parentbebe06d78263f5a749b5edba722dfc83342fcf47 (diff)
downloadhurl-5c4812d56d065967a78916152634edb78696237a.tar.gz
hurl-5c4812d56d065967a78916152634edb78696237a.tar.bz2
hurl-5c4812d56d065967a78916152634edb78696237a.zip
Add decoupling layer for localizing HTTP errors.
This removes logic from the messages module, reduces duplication, & prepares to allow callers to provide their own localized messages.
-rw-r--r--src/Network/URI/Fetch.hs4
-rw-r--r--src/Network/URI/Locale.hs96
-rw-r--r--src/Network/URI/Messages.hs126
3 files changed, 152 insertions, 74 deletions
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 8c3fa6b..9e9e43e 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -423,7 +423,7 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI {
where
parseHeader :: String -> (Char, Char, Text)
parseHeader (major:minor:meta) = (major, minor, Txt.strip $ Txt.pack meta)
- parseHeader _ = ('4', '1', Txt.pack $ trans l MalformedResponse)
+ parseHeader header = ('4', '1', Txt.pack $ trans l $ MalformedResponse header)
handleIOErr :: IOError -> IO Strict.ByteString
handleIOErr _ = return ""
connectionGetChunks conn = do
@@ -572,7 +572,7 @@ fetchHTTPCached session shouldCache accept@(defaultMIME:_) rawUri cbReq cbResp =
Right (mime, body) ->
let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime
in return $ resolveCharset' uri mime' body
- `catch` \e -> do return (rawUri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e)
+ `catch` \e -> do return (rawUri, mimeERR, Left $ Txt.pack $ transHttp (locale session) e)
fetchHTTPCached session _ [] uri _ _ =
return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ UnsupportedMIME "")
#endif
diff --git a/src/Network/URI/Locale.hs b/src/Network/URI/Locale.hs
index 17dc360..d537d1e 100644
--- a/src/Network/URI/Locale.hs
+++ b/src/Network/URI/Locale.hs
@@ -1,11 +1,30 @@
-- | Internal module for retrieving languages to localize to.
-module Network.URI.Locale(rfc2616Locale) where
+-- Also provides decoupling layers between Network.URI.Messages & optional dependencies.
+{-# LANGUAGE CPP #-}
+module Network.URI.Locale(rfc2616Locale
+#ifdef WITH_HTTP_URI
+, transHttp
+#endif
+) where
import System.Environment (lookupEnv)
import Control.Monad (forM)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, fromMaybe)
import Data.Char (toLower)
+#ifdef WITH_HTTP_URI
+import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))
+import Control.Exception (displayException)
+import Network.TLS (TLSException(..), TLSError(..), AlertDescription(..))
+import Control.Exception.Base (fromException)
+import Network.HTTP.Types (Status(..))
+
+import Network.URI.Messages
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.Text as Txt
+import Text.Read (readMaybe)
+#endif
+
--- This file is based on logic in GNOME's LibSoup & GLib.
-- | Returns the languages to which responses should be localized.
@@ -46,3 +65,76 @@ split b (a:as) | a `elem` b = [] : split b as
| (head':tail') <- split b as = (a:head') : tail'
| otherwise = [a:as]
split _ [] = [[]]
+
+--------
+---- Decoupling Layer
+--------
+#ifdef WITH_HTTP_URI
+transHttp locales (InvalidUrlException url msg) = trans locales $ InvalidUrl url msg
+transHttp locales (HttpExceptionRequest _ (TooManyRedirects _)) = trans locales $ ExcessiveRedirects
+transHttp locales (HttpExceptionRequest _ ResponseTimeout) = trans locales $ TimeoutResponse
+transHttp locales (HttpExceptionRequest _ ConnectionTimeout) = trans locales $ TimeoutConnection
+transHttp locales (HttpExceptionRequest _ (ConnectionFailure err)) =
+ trans locales $ FailedConnect $ displayException err
+transHttp locales (HttpExceptionRequest _ (StatusCodeException _ code)) =
+ trans locales $ HTTPStatus (fromMaybe 500 $ readMaybe $ C8.unpack code) ""
+transHttp locales (HttpExceptionRequest _ OverlongHeaders) =
+ trans locales $ HTTPStatus 431 "Overlong Headers"
+transHttp locales (HttpExceptionRequest _ (InvalidStatusLine why)) =
+ trans locales $ MalformedResponse $ C8.unpack why
+transHttp locales (HttpExceptionRequest _ (InvalidHeader why)) =
+ trans locales $ MalformedResponse $ C8.unpack why
+transHttp locales (HttpExceptionRequest _ (InvalidRequestHeader why)) =
+ trans locales $ InvalidRequest $ C8.unpack why
+transHttp locales (HttpExceptionRequest _ (ProxyConnectException a b (Status code msg))) =
+ trans locales $ ProxyError (C8.unpack a) b code $ C8.unpack msg
+-- NOTE: Minor details are unlocalized for now... Can always come back to this!
+transHttp locales (HttpExceptionRequest _ NoResponseDataReceived) =
+ trans locales $ MalformedResponse "Empty"
+transHttp locales (HttpExceptionRequest _ TlsNotSupported) =
+ trans locales $ HandshakeMisc "Unsupported"
+transHttp locales (HttpExceptionRequest _ (WrongRequestBodyStreamSize a b)) =
+ trans locales $ OtherException $ unlines ["Wrong request bodysize", show a, show b]
+transHttp locales (HttpExceptionRequest _ (ResponseBodyTooShort a b)) =
+ trans locales $ MalformedResponse ("Too short " ++ show a ++ '<' : show b)
+transHttp locales (HttpExceptionRequest _ InvalidChunkHeaders) =
+ trans locales $ MalformedResponse "Chunk headers"
+transHttp locales (HttpExceptionRequest _ IncompleteHeaders) =
+ trans locales $ MalformedResponse "Incomplete headers"
+transHttp locales (HttpExceptionRequest _ (InvalidDestinationHost why)) =
+ trans locales $ FailedConnect $ C8.unpack why
+transHttp locales (HttpExceptionRequest _ (HttpZlibException _)) =
+ trans locales $ MalformedResponse "ZLib compression"
+transHttp locales (HttpExceptionRequest _ ConnectionClosed) =
+ trans locales $ FailedConnect "already-closed"
+transHttp locales (HttpExceptionRequest _ (InvalidProxySettings why)) =
+ trans locales $ FailedConnect ("proxy (" ++ Txt.unpack why ++ ")")
+transHttp locales (HttpExceptionRequest _ (InvalidProxyEnvironmentVariable key value)) =
+ trans locales $ FailedConnect ("proxy (" ++ Txt.unpack key ++ '=' : Txt.unpack value ++ ")")
+transHttp locales (HttpExceptionRequest _ (InternalException e)) =
+ trans locales $ case fromException e of
+ Just (Terminated _ why _) -> InsecureTerminated why
+ Just (HandshakeFailed (Error_Misc msg)) -> HandshakeMisc msg
+ Just (HandshakeFailed (Error_Protocol (_, _, CloseNotify))) -> HandshakeClosed
+ Just (HandshakeFailed (Error_Protocol (_, _, HandshakeFailure))) -> HandshakeError
+ Just (HandshakeFailed (Error_Protocol (_, _, BadCertificate))) -> InsecureCertificate ""
+ Just (HandshakeFailed (Error_Protocol (_, _, UnsupportedCertificate))) ->
+ InsecureCertificate $ trans locales InsecureCertificateUnsupported
+ Just (HandshakeFailed (Error_Protocol (_, _, CertificateExpired))) ->
+ InsecureCertificate $ trans locales InsecureCertificateExpired
+ Just (HandshakeFailed (Error_Protocol (_, _, CertificateRevoked))) ->
+ InsecureCertificate $ trans locales InsecureCertificateRevoked
+ Just (HandshakeFailed (Error_Protocol (_, _, CertificateUnknown))) ->
+ InsecureCertificate $ trans locales InsecureCertificateUnknown
+ Just (HandshakeFailed (Error_Protocol (_, _, UnknownCa))) ->
+ InsecureCertificate $ trans locales InsecureCertificateUnknownCA
+ Just (HandshakeFailed (Error_Protocol (why, _, _))) -> HandshakeMisc why
+ Just (HandshakeFailed (Error_Certificate why)) -> InsecureCertificate why
+ Just (HandshakeFailed (Error_HandshakePolicy why)) -> HandshakePolicy why
+ Just (HandshakeFailed Error_EOF) -> HandshakeEOF
+ Just (HandshakeFailed (Error_Packet why)) -> HandshakePacketInvalid why
+ Just (HandshakeFailed (Error_Packet_unexpected a b)) -> HandshakePacketUnexpected a b
+ Just (HandshakeFailed (Error_Packet_Parsing why)) -> HandshakePacketUnparsed why
+ Just ConnectionNotEstablished -> InsecureUnestablished
+ Nothing -> OtherException $ displayException e
+#endif
diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs
index 6450dac..423f7ac 100644
--- a/src/Network/URI/Messages.hs
+++ b/src/Network/URI/Messages.hs
@@ -14,13 +14,6 @@ module Network.URI.Messages (trans, Errors(..)) where
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
-#if WITH_HTTP_URI
-import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..))
-import Control.Exception (displayException)
-import Network.TLS (TLSException(..), TLSError(..), AlertDescription(..))
-import Control.Exception.Base (fromException)
-#endif
-
trans _ (RawXML markup) = markup
--- BEGIN LOCALIZATION
trans ("en":_) (UnsupportedScheme scheme) = "Unsupported protocol " ++ scheme
@@ -30,65 +23,8 @@ 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!"
+trans ("en":_) (MalformedResponse why) = "Invalid response! " ++ why
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!"
-trans ("en":_) (Http (HttpExceptionRequest _ ResponseTimeout)) = "The site took too long to respond!"
-trans ("en":_) (Http (HttpExceptionRequest _ ConnectionTimeout)) = "The site took too long to connect!"
-trans ("en":_) (Http (HttpExceptionRequest _ (ConnectionFailure err))) = "Could not connect: " ++ displayException err
-trans ("en":_) (Http (HttpExceptionRequest _ (InternalException e))) = case fromException e of
- Just (Terminated _ why _) -> "Secure session disconnected! <em>" ++ why ++ "</em>"
- Just (HandshakeFailed (Error_Misc msg)) ->
- "Failed to establish secure connection! <em>" ++ msg ++ "</em>"
- Just (HandshakeFailed (Error_Protocol (_, _, CloseNotify))) ->
- "Secure session disconnected!"
- Just (HandshakeFailed (Error_Protocol (_, _, HandshakeFailure))) ->
- "Failed to negotiate security parameters!"
- Just (HandshakeFailed (Error_Protocol (_, _, BadCertificate))) ->
- "<h1>The site failed to prove it is who it says it is!</h1>"
- Just (HandshakeFailed (Error_Protocol (_, _, UnsupportedCertificate))) -> unlines [
- "<h1>The site failed to prove it is who it says it is!</h1>",
- "<p>It has sent us a cryptographic certificate I failed to make sense of.</p>"
- ]
- Just (HandshakeFailed (Error_Protocol (_, _, CertificateExpired))) -> unlines [
- "<h1>The site failed to prove it is who it says it is!</h1>",
- "<p>The cryptographic certificate it has sent to us has expired!</p>"
- ]
- Just (HandshakeFailed (Error_Protocol (_, _, CertificateRevoked))) -> unlines [
- "<h1>The site failed to prove it is who it says it is!</h1>",
- "<p>The cryptographic certificate it has sent us has been revoked!</p>"
- ]
- Just (HandshakeFailed (Error_Protocol (_, _, CertificateUnknown))) -> unlines [
- "<h1>The site failed to prove it is who it says it is!</h1>",
- "<p>The cryptographic certificate it has sent us belongs to someone else!</p>"
- ]
- Just (HandshakeFailed (Error_Protocol (_, _, UnknownCa))) -> unlines [
- "<h1>The site failed to prove it is who it says it is!</h1>",
- "<p>The authority vouching for it is unknown to me!</p>"
- ]
- Just (HandshakeFailed (Error_Protocol (why, _, _desc))) ->
- "Failed to establish secure connection! <em>" ++ why ++ "</em>"
- Just (HandshakeFailed (Error_Certificate why)) -> unlines [
- "<h1>The site failed to prove it is who it says it is!</h1>",
- "<p>" ++ why ++ "</p>"
- ]
- Just (HandshakeFailed (Error_HandshakePolicy why)) ->
- "Invalid handshake policy: <em>" ++ why ++ "</em>"
- Just (HandshakeFailed Error_EOF) -> "Secure session disconnected!"
- Just (HandshakeFailed (Error_Packet why)) ->
- "Invalid security packet: <em>" ++ why ++ "</em>"
- Just (HandshakeFailed (Error_Packet_unexpected a b)) -> unlines [
- "<p>Invalid security packet: <em>" ++ a ++ "</em></p>",
- "<p>" ++ b ++ "</p>"
- ]
- Just (HandshakeFailed (Error_Packet_Parsing why)) ->
- "Invalid security packet: <em>" ++ why ++ "</em>"
- Just ConnectionNotEstablished ->
- "Attempted to send or recieve data before establishing secure connection!"
- Nothing -> "Internal error: " ++ displayException e
-#endif
trans ("en":_) (GeminiError '1' '1' label) =
"<form><label>" ++ label ++ "<input type=password></form>"
trans ("en":_) (GeminiError '1' _ label) = "<form><label>" ++ label ++ "<input></form>"
@@ -162,15 +98,65 @@ trans ("en":_) (HTTPStatus 507 _) = "Insufficient <strong>WebDAV</strong> storag
trans ("en":_) (HTTPStatus 508 _) = "<strong>WebDAV</strong> loop detected!"
trans ("en":_) (HTTPStatus 510 _) = "Further request extensions required!"
trans ("en":_) (HTTPStatus 511 _) = "Authentication into network required!"
-trans ("en":_) (HTTPStatus _ error) = error -- TODO localize
+trans ("en":_) (HTTPStatus _ error) = error -- Fallback
+trans ("en":_) (OtherException error) = "Internal Exception <pre><code>" ++ error ++ "</code></pre>"
+trans ("en":_) (InvalidUrl url message) =
+ "Invalid web address <code>" ++ url ++ "</code>: <em>" ++ message ++ "</em>"
+trans ("en":_) (ProxyError msg code code' msg') = unlines [
+ "<h1>Proxy failed to forward request!<h1>",
+ "<p>" ++ show code ++ " " ++ msg ++ "</p>",
+ "<p>" ++ show code' ++ " " ++ msg' ++ "</p>"
+ ]
+trans ("en":_) (InvalidRequest why) =
+ "Attempted to send invalid auxiliary data: <em>" ++ why ++ "</em>"
+trans ("en":_) InsecureUnestablished =
+ "Attempted to send or recieve data before establishing secure connection!"
+trans ("en":_) (InsecureCertificate why) = unlines [
+ "<h1>The site failed to prove it is who it says it is!</h1>",
+ "<p>" ++ why ++ "</p>",
+ "<p><a href=action:history/back>Leave Insecure Site</a> | ",
+ "<a href=action:novalidate>Accept Imposter Risk &amp; Continue</a></p>"
+ ]
+trans ("en":_) (InsecureTerminated why) = "Secure session disconnected! <em>" ++ why ++ "</em>"
+trans ("en":_) InsecureCertificateUnknownCA = "The authority vouching for it is unknown to me!"
+trans ("en":_) InsecureCertificateUnknown =
+ "The cryptographic certificate it has sent us to prove its identity instead " ++
+ "belongs to someone else!"
+trans ("en":_) InsecureCertificateRevoked =
+ "The cryptographic certificate it has sent us to prove its identity has been revoked!"
+trans ("en":_) InsecureCertificateExpired =
+ "The cryptographic certificate it has sent us to prove its identity has expired!"
+trans ("en":_) InsecureCertificateUnsupported =
+ "It has sent us a cryptographic certificate to prove its identity I failed to make sense of."
+trans ("en":_) (HandshakePacketUnparsed why) = "Invalid security packet: <em>" ++ why ++ "</em>"
+trans ("en":_) (HandshakePacketUnexpected a b) = unlines [
+ "<p>Invalid security packet: <em>" ++ a ++ "</em></p>",
+ "<p>" ++ b ++ "</p>"
+ ]
+trans ("en":_) (HandshakePacketInvalid why) = "Invalid security packet: <em>" ++ why ++ "</em>"
+trans ("en":_) HandshakeEOF = "Secure session disconnected!"
+trans ("en":_) (HandshakePolicy why) = "Invalid handshake policy: <em>" ++ why ++ "</em>"
+trans ("en":_) (HandshakeMisc why) =
+ "Failed to establish secure connection! <em>" ++ why ++ "</em>"
+trans ("en":_) HandshakeError = "Failed to negotiate security parameters!"
+trans ("en":_) HandshakeClosed = "Secure session disconnected!"
+trans ("en":_) (FailedConnect why) = "Failed to open connection to the site: <em>" ++ why ++ "</em>"
+trans ("en":_) TimeoutConnection = "The site took too long to connect!"
+trans ("en":_) TimeoutResponse = "The site took too long to respond!"
--- END LOCALIZATION
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 | MalformedResponse
+ | OpenedWith String | ReadFailed String | RawXML String | MalformedResponse String
| ExcessiveRedirects | HTTPStatus Int String | GeminiError Char Char String
-#if WITH_HTTP_URI
- | Http HttpException
-#endif
+ | OtherException String | InvalidUrl String String | ProxyError String Int Int String
+ | InvalidRequest String
+ | InsecureUnestablished | InsecureCertificate String | InsecureTerminated String
+ | InsecureCertificateUnknownCA | InsecureCertificateUnknown | InsecureCertificateRevoked
+ | InsecureCertificateExpired | InsecureCertificateUnsupported
+ | HandshakePacketUnparsed String | HandshakePacketUnexpected String String
+ | HandshakePacketInvalid String
+ | HandshakeEOF | HandshakePolicy String | HandshakeMisc String | HandshakeError | HandshakeClosed
+ | FailedConnect String | TimeoutConnection | TimeoutResponse