From a70796e500daf85c3910125b712af8e84ec0edfc Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 6 Aug 2022 19:25:10 +1200 Subject: [PATCH] Allow overriding localizations logic, including throwing as error. Release HURL 2.2! --- ChangeLog.md | 7 ++ hurl.cabal | 2 +- src/Network/URI/Fetch.hs | 43 +++++----- src/Network/URI/Locale.hs | 94 ++++++++++----------- src/Network/URI/Messages.hs | 163 +++++++++++++++++++----------------- 5 files changed, 162 insertions(+), 147 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 408704d..3f41653 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for hurl +## 2.2.0.0 -- 2022-08-06 +* Fix webform submission, refine API, & support multiple encodings. +* Switch from OpenSSL to `tls`/Cryptonite for a cryptographic backend for better error reporting & to fix Gemini implementation +* Support clientside certificates in Gemini & HTTPS +* Support HSTS with bypass +* Allow overriding HURL's error-reporting localization + ## 2.1.0.1 -- 2021-03-09 * Fixes a build failure. diff --git a/hurl.cabal b/hurl.cabal index 1174435..bbd5656 100644 --- a/hurl.cabal +++ b/hurl.cabal @@ -10,7 +10,7 @@ name: hurl -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 2.1.0.1 +version: 2.2.0.0 -- A short (one-line) description of the package. synopsis: Haskell URL resolver diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs index 9e9e43e..298779e 100644 --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -108,6 +108,8 @@ data Session = Session { #endif -- | The languages (RFC2616-encoded) to which responses should be localized. locale :: [String], + -- | Callback function for localizing error messages, or throwing exceptions + trans' :: Errors -> String, -- | Additional files to serve from about: URIs. aboutPages :: [(FilePath, ByteString)], -- | Log of timestamped/profiled URL requests @@ -201,6 +203,7 @@ newSession' appname = do rewriter = rewriters, #endif locale = ietfLocale, + trans' = trans ietfLocale, aboutPages = [], requestLog = Nothing, redirectCount = 5, @@ -324,8 +327,8 @@ encodeQuery query = intercalate "&" $ M.mapMaybe encodePart query -- | As per `fetchURL`, but also returns the redirected URI. fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString) -fetchURL' Session {redirectCount = 0, locale = locale'} _ uri = - return (uri, mimeERR, Left $ Txt.pack $ trans locale' ExcessiveRedirects) +fetchURL' sess@Session {redirectCount = 0 } _ uri = + return (uri, mimeERR, Left $ Txt.pack $ trans' sess ExcessiveRedirects) #ifdef WITH_PLUGIN_REWRITES fetchURL' session mimes uri @@ -333,14 +336,13 @@ fetchURL' session mimes uri #endif #ifdef WITH_PLUGIN_EXEC -fetchURL' session@Session { appName = appname, locale = l } mimes - uri@(URI "ext:" Nothing path query _) = do +fetchURL' session@Session { appName = appname } mimes uri@(URI "ext:" Nothing path query _) = do dir <- getXdgDirectory XdgData "nz.geek.adrian.hurl" sysdirs <- getXdgDirectoryList XdgDataDirs let dirs = concat [[dir' appname, dir'] | dir' <- dir : sysdirs] programs <- findExecutablesInDirectories dirs ("bin" path) case programs of - [] -> return (uri, mimeERR, Left $ Txt.pack $ trans l $ ReadFailed "404") + [] -> return (uri, mimeERR, Left $ Txt.pack $ trans' session $ ReadFailed "404") program:_ -> do let args = case query of { '?':rest -> split (== '&') rest; @@ -384,7 +386,7 @@ fetchURL' session accept uri | uriScheme uri `elem` ["http:", "https:"] = #endif #ifdef WITH_GEMINI_URI -fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { +fetchURL' sess@Session { connCtxt = ctxt } mimes uri@URI { uriScheme = "gemini:", uriAuthority = Just (URIAuth _ host port) } = do let params = TLS.defaultParamsClient host "gmni" @@ -418,12 +420,12 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { redirectCount = redirectCount sess - 1 } mimes $ relativeTo redirect' uri (x, y, err) -> return (uri, mimeERR, Left $ Txt.pack $ - trans l $ GeminiError x y $ Txt.unpack $ + trans' sess $ GeminiError x y $ Txt.unpack $ Txt.replace "<" "<" $ Txt.replace "&" "&" err) where parseHeader :: String -> (Char, Char, Text) parseHeader (major:minor:meta) = (major, minor, Txt.strip $ Txt.pack meta) - parseHeader header = ('4', '1', Txt.pack $ trans l $ MalformedResponse header) + parseHeader header = ('4', '1', Txt.pack $ trans' sess $ MalformedResponse header) handleIOErr :: IOError -> IO Strict.ByteString handleIOErr _ = return "" connectionGetChunks conn = do @@ -432,12 +434,12 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { #endif #ifdef WITH_FILE_URI -fetchURL' Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do +fetchURL' sess (defaultMIME:_) uri@URI {uriScheme = "file:"} = do response <- B.readFile $ uriPath uri return (uri, defaultMIME, Right response) `catch` \e -> do return (uri, mimeERR, - Left $ Txt.pack $ trans l $ ReadFailed $ displayException (e :: IOException)) + Left $ Txt.pack $ trans' sess $ ReadFailed $ displayException (e :: IOException)) #endif #ifdef WITH_DATA_URI @@ -453,21 +455,21 @@ fetchURL' _ (defaultMIME:_) uri@URI {uriScheme = "data:"} = #endif #ifdef WITH_XDG -fetchURL' Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do +fetchURL' sess@Session { apps = a } _ uri@(URI {uriScheme = s}) = do app <- dispatchURIByMIME a uri ("x-scheme-handler/" ++ init s) - return (uri, htmlERR, Left $ Txt.pack $ trans l $ app) + return (uri, htmlERR, Left $ Txt.pack $ trans' sess $ app) #else -fetchURL' Session {locale = l} _ URI {uriScheme = scheme} = - return (uri, mimeERR, Left $ Txt.pack $ trans l $ UnsupportedScheme scheme) +fetchURL' sess _ URI {uriScheme = scheme} = + return (uri, mimeERR, Left $ Txt.pack $ trans' sess $ UnsupportedScheme scheme) #endif dispatchByMIME :: Session -> String -> URI -> IO (Maybe String) #if WITH_XDG -dispatchByMIME Session {locale = l, apps = a} mime uri = do +dispatchByMIME sess@Session { apps = a } mime uri = do err <- dispatchURIByMIME a uri mime return $ case err of UnsupportedMIME _ -> Nothing - _ -> Just $ trans l err + _ -> Just $ trans' sess err #else dispatchByMIME _ _ _ = return Nothing #endif @@ -497,7 +499,8 @@ dispatchByApp _ _ _ _ = return False #endif #ifdef WITH_HTTP_URI -fetchHTTPCached session shouldCache accept@(defaultMIME:_) rawUri cbReq cbResp = do +fetchHTTPCached session @ Session { trans' = t} shouldCache + accept@(defaultMIME:_) rawUri cbReq cbResp = do now <- getCurrentTime hsts <- readMVar $ hstsDomains session uri <- case (uriScheme rawUri, uriAuthority rawUri) of { @@ -556,7 +559,7 @@ fetchHTTPCached session shouldCache accept@(defaultMIME:_) rawUri cbReq cbResp = return $ Left $ relativeTo uri' uri (Status code msg, "", _) -> return $ Right (Txt.pack mimeERR, B.fromStrict $ C8.pack $ - trans (locale session) $ HTTPStatus code $ C8.unpack msg) + trans' session $ HTTPStatus code $ C8.unpack msg) (_, body, (mimetype:_)) -> do cacheHTTP uri response forkIO cleanCacheHTTP -- Try to keep diskspace down... @@ -572,9 +575,9 @@ 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 $ transHttp (locale session) e) + `catch` \e -> do return (rawUri, mimeERR, Left $ Txt.pack $ transHttp t e) fetchHTTPCached session _ [] uri _ _ = - return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ UnsupportedMIME "") + return (uri, mimeERR, Left $ Txt.pack $ trans' session $ UnsupportedMIME "") #endif #if WITH_HTTP_URI || WITH_GEMINI_URI diff --git a/src/Network/URI/Locale.hs b/src/Network/URI/Locale.hs index d537d1e..9a4061a 100644 --- a/src/Network/URI/Locale.hs +++ b/src/Network/URI/Locale.hs @@ -70,64 +70,64 @@ 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 +transHttp trans' (InvalidUrlException url msg) = trans' $ InvalidUrl url msg +transHttp trans' (HttpExceptionRequest _ (TooManyRedirects _)) = trans' $ ExcessiveRedirects +transHttp trans' (HttpExceptionRequest _ ResponseTimeout) = trans' $ TimeoutResponse +transHttp trans' (HttpExceptionRequest _ ConnectionTimeout) = trans' $ TimeoutConnection +transHttp trans' (HttpExceptionRequest _ (ConnectionFailure err)) = + trans' $ FailedConnect $ displayException err +transHttp trans' (HttpExceptionRequest _ (StatusCodeException _ code)) = + trans' $ HTTPStatus (fromMaybe 500 $ readMaybe $ C8.unpack code) "" +transHttp trans' (HttpExceptionRequest _ OverlongHeaders) = + trans' $ HTTPStatus 431 "Overlong Headers" +transHttp trans' (HttpExceptionRequest _ (InvalidStatusLine why)) = + trans' $ MalformedResponse $ C8.unpack why +transHttp trans' (HttpExceptionRequest _ (InvalidHeader why)) = + trans' $ MalformedResponse $ C8.unpack why +transHttp trans' (HttpExceptionRequest _ (InvalidRequestHeader why)) = + trans' $ InvalidRequest $ C8.unpack why +transHttp trans' (HttpExceptionRequest _ (ProxyConnectException a b (Status code msg))) = + trans' $ 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 +transHttp trans' (HttpExceptionRequest _ NoResponseDataReceived) = + trans' $ MalformedResponse "Empty" +transHttp trans' (HttpExceptionRequest _ TlsNotSupported) = + trans' $ HandshakeMisc "Unsupported" +transHttp trans' (HttpExceptionRequest _ (WrongRequestBodyStreamSize a b)) = + trans' $ OtherException $ unlines ["Wrong request bodysize", show a, show b] +transHttp trans' (HttpExceptionRequest _ (ResponseBodyTooShort a b)) = + trans' $ MalformedResponse ("Too short " ++ show a ++ '<' : show b) +transHttp trans' (HttpExceptionRequest _ InvalidChunkHeaders) = + trans' $ MalformedResponse "Chunk headers" +transHttp trans' (HttpExceptionRequest _ IncompleteHeaders) = + trans' $ MalformedResponse "Incomplete headers" +transHttp trans' (HttpExceptionRequest _ (InvalidDestinationHost why)) = + trans' $ FailedConnect $ C8.unpack why +transHttp trans' (HttpExceptionRequest _ (HttpZlibException _)) = + trans' $ MalformedResponse "ZLib compression" +transHttp trans' (HttpExceptionRequest _ ConnectionClosed) = + trans' $ FailedConnect "already-closed" +transHttp trans' (HttpExceptionRequest _ (InvalidProxySettings why)) = + trans' $ FailedConnect ("proxy (" ++ Txt.unpack why ++ ")") +transHttp trans' (HttpExceptionRequest _ (InvalidProxyEnvironmentVariable key value)) = + trans' $ FailedConnect ("proxy (" ++ Txt.unpack key ++ '=' : Txt.unpack value ++ ")") +transHttp trans' (HttpExceptionRequest _ (InternalException e)) = + trans' $ 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 + InsecureCertificate $ trans' InsecureCertificateUnsupported Just (HandshakeFailed (Error_Protocol (_, _, CertificateExpired))) -> - InsecureCertificate $ trans locales InsecureCertificateExpired + InsecureCertificate $ trans' InsecureCertificateExpired Just (HandshakeFailed (Error_Protocol (_, _, CertificateRevoked))) -> - InsecureCertificate $ trans locales InsecureCertificateRevoked + InsecureCertificate $ trans' InsecureCertificateRevoked Just (HandshakeFailed (Error_Protocol (_, _, CertificateUnknown))) -> - InsecureCertificate $ trans locales InsecureCertificateUnknown + InsecureCertificate $ trans' InsecureCertificateUnknown Just (HandshakeFailed (Error_Protocol (_, _, UnknownCa))) -> - InsecureCertificate $ trans locales InsecureCertificateUnknownCA + InsecureCertificate $ trans' InsecureCertificateUnknownCA Just (HandshakeFailed (Error_Protocol (why, _, _))) -> HandshakeMisc why Just (HandshakeFailed (Error_Certificate why)) -> InsecureCertificate why Just (HandshakeFailed (Error_HandshakePolicy why)) -> HandshakePolicy why diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs index 423f7ac..ccb36a6 100644 --- a/src/Network/URI/Messages.hs +++ b/src/Network/URI/Messages.hs @@ -13,58 +13,60 @@ module Network.URI.Messages (trans, Errors(..)) where import Data.List (stripPrefix) import Data.Maybe (fromMaybe) +import Control.Exception (Exception) trans _ (RawXML markup) = markup --- BEGIN LOCALIZATION -trans ("en":_) (UnsupportedScheme scheme) = "Unsupported protocol " ++ scheme -trans ("en":_) (UnsupportedMIME mime) = "Unsupported filetype " ++ mime -trans ("en":_) (RequiresInstall mime appsMarkup) = - "

Please install a compatible app to open " ++ linkType ++ " links

\n" ++ appsMarkup +("en":_) `trans` UnsupportedScheme scheme = "Unsupported protocol " ++ scheme +("en":_) `trans` UnsupportedMIME mime = "Unsupported filetype " ++ mime +("en":_) `trans` RequiresInstall mime appsMarkup = + "

Please install a compatible app to open " ++ linkType ++ + " links

\n" ++ 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 why) = "Invalid response! " ++ why -trans ("en":_) ExcessiveRedirects = "Too many redirects!" -trans ("en":_) (GeminiError '1' '1' label) = +("en":_) `trans` OpenedWith app = "Opened in " ++ app +("en":_) `trans` ReadFailed msg = "Failed to read file: " ++ msg +("en":_) `trans` MalformedResponse why = "Invalid response! " ++ why +("en":_) `trans` ExcessiveRedirects = "Too many redirects!" +("en":_) `trans` GeminiError '1' '1' label = "