From 5c4812d56d065967a78916152634edb78696237a Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 4 Aug 2022 21:44:19 +1200 Subject: [PATCH] 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. --- src/Network/URI/Fetch.hs | 4 +- src/Network/URI/Locale.hs | 96 ++++++++++++++++++++++++++- src/Network/URI/Messages.hs | 126 ++++++++++++++++-------------------- 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! " ++ why ++ "" - Just (HandshakeFailed (Error_Misc msg)) -> - "Failed to establish secure connection! " ++ msg ++ "" - Just (HandshakeFailed (Error_Protocol (_, _, CloseNotify))) -> - "Secure session disconnected!" - Just (HandshakeFailed (Error_Protocol (_, _, HandshakeFailure))) -> - "Failed to negotiate security parameters!" - Just (HandshakeFailed (Error_Protocol (_, _, BadCertificate))) -> - "

The site failed to prove it is who it says it is!

" - Just (HandshakeFailed (Error_Protocol (_, _, UnsupportedCertificate))) -> unlines [ - "

The site failed to prove it is who it says it is!

", - "

It has sent us a cryptographic certificate I failed to make sense of.

" - ] - Just (HandshakeFailed (Error_Protocol (_, _, CertificateExpired))) -> unlines [ - "

The site failed to prove it is who it says it is!

", - "

The cryptographic certificate it has sent to us has expired!

" - ] - Just (HandshakeFailed (Error_Protocol (_, _, CertificateRevoked))) -> unlines [ - "

The site failed to prove it is who it says it is!

", - "

The cryptographic certificate it has sent us has been revoked!

" - ] - Just (HandshakeFailed (Error_Protocol (_, _, CertificateUnknown))) -> unlines [ - "

The site failed to prove it is who it says it is!

", - "

The cryptographic certificate it has sent us belongs to someone else!

" - ] - Just (HandshakeFailed (Error_Protocol (_, _, UnknownCa))) -> unlines [ - "

The site failed to prove it is who it says it is!

", - "

The authority vouching for it is unknown to me!

" - ] - Just (HandshakeFailed (Error_Protocol (why, _, _desc))) -> - "Failed to establish secure connection! " ++ why ++ "" - Just (HandshakeFailed (Error_Certificate why)) -> unlines [ - "

The site failed to prove it is who it says it is!

", - "

" ++ why ++ "

" - ] - Just (HandshakeFailed (Error_HandshakePolicy why)) -> - "Invalid handshake policy: " ++ why ++ "" - Just (HandshakeFailed Error_EOF) -> "Secure session disconnected!" - Just (HandshakeFailed (Error_Packet why)) -> - "Invalid security packet: " ++ why ++ "" - Just (HandshakeFailed (Error_Packet_unexpected a b)) -> unlines [ - "

Invalid security packet: " ++ a ++ "

", - "

" ++ b ++ "

" - ] - Just (HandshakeFailed (Error_Packet_Parsing why)) -> - "Invalid security packet: " ++ why ++ "" - Just ConnectionNotEstablished -> - "Attempted to send or recieve data before establishing secure connection!" - Nothing -> "Internal error: " ++ displayException e -#endif trans ("en":_) (GeminiError '1' '1' label) = "