3 files changed, 152 insertions(+), 74 deletions(-)

M src/Network/URI/Fetch.hs
M src/Network/URI/Locale.hs
M src/Network/URI/Messages.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

@@ 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

@@ 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