From 42aa3ea2298322df4caed2eefa19ac63032179f7 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 14 Oct 2020 19:05:01 +1300 Subject: [PATCH] Release 1.4.2.0! Includes improved Gemini support Switched over to OpenSSL for encryption Optionally logs network requests to memory or disk Supports URL rewriting extensions --- hurl.cabal | 2 +- src/Network/URI/Charset.hs | 10 +++++++--- src/Network/URI/Fetch.hs | 33 ++++++++++++++++----------------- src/Network/URI/Messages.hs | 2 ++ 4 files changed, 26 insertions(+), 21 deletions(-) diff --git a/hurl.cabal b/hurl.cabal index 3740b32..0693af8 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: 1.4.1.0 +version: 1.4.2.0 -- A short (one-line) description of the package. synopsis: Haskell URL resolver diff --git a/src/Network/URI/Charset.hs b/src/Network/URI/Charset.hs index ac1df5d..2b200fb 100644 --- a/src/Network/URI/Charset.hs +++ b/src/Network/URI/Charset.hs @@ -7,19 +7,23 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as B import Data.Text.Encoding import Debug.Trace (trace) +import Data.List (intercalate) -- | If the MIMEtype specifies a charset parameter, apply it. resolveCharset :: [String] -- ^ The MIMEtype, split by ';' -> ByteString -- ^ The bytes received from the server -> (String, Either Text ByteString) -- ^ The MIMEtype (minus parameters) & possibly decoded text, to be returned from protocol handlers. -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:('c':'h':'a':'r':'s':'e':'t':'=':charset):params) response = + (parameterizedMIME mime params, Left $ convertCharset charset $ B.toStrict response) +resolveCharset (mime:param:params) response = + resolveCharset (parameterizedMIME mime [param]:params) response resolveCharset [mime] response = (mime, Right $ response) -- 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") +parameterizedMIME mime params = mime ++ ";" ++ intercalate ";" params + -- | As per `resolveCharset`, but also returns given URI (or other type). resolveCharset' :: a -> [String] -> ByteString -> (a, String, Either Text ByteString) resolveCharset' a mimes resp = let (mime, resp') = resolveCharset mimes resp in (a, mime, resp') diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs index 1767d95..58bd6ae 100644 --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -2,7 +2,7 @@ {-# 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, aboutPages), newSession, +module Network.URI.Fetch(Session(locale, aboutPages, redirectCount), newSession, fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR, dispatchByMIME, saveDownload, downloadToURI, -- logging API @@ -84,7 +84,9 @@ data Session = Session { -- | Additional files to serve from about: URIs. aboutPages :: [(FilePath, ByteString)], -- | Log of timestamped/profiled URL requests - requestLog :: MVar [LogRecord] + requestLog :: MVar [LogRecord], + -- | How many redirects to follow for Gemini or HTTP(S) requests + redirectCount :: Int } data LogRecord = LogRecord { @@ -143,7 +145,8 @@ newSession' appname = do #endif locale = ietfLocale, aboutPages = [], - requestLog = log + requestLog = log, + redirectCount = 5 } llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key] @@ -181,6 +184,9 @@ 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 {redirectCount = 0, locale = locale'} _ uri = + return (uri, mimeERR, Left $ Txt.pack $ trans locale' ExcessiveRedirects) + #ifdef WITH_PLUGIN_REWRITES fetchURL' session mimes uri | Just uri' <- applyRewriter (rewriter session) uri = fetchURL' session mimes uri' @@ -202,7 +208,8 @@ fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "h HTTP.requestHeaders = [ ("Accept", C8.pack $ intercalate ", " accept), ("Accept-Language", C8.pack $ intercalate ", " $ locale session) - ] + ], + HTTP.redirectCount = redirectCount session } $ managerHTTP session return $ case ( HTTP.responseBody response, @@ -233,11 +240,13 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { "" ]) ('2', _, mime) -> do - body <- B.hGetContents input' + body <- Strict.hGetContents input' let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime - return $ resolveCharset' uri mime' body + return $ resolveCharset' uri mime' $ B.fromStrict body ('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect -> - fetchURL' sess mimes $ relativeTo redirect' uri + fetchURL' sess { + redirectCount = redirectCount sess - 1 + } 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, mimeERR, Left err) @@ -358,13 +367,3 @@ breakOn c (a:as) | c == a = ([], as) | otherwise = let (x, y) = breakOn c as in (a:x, y) breakOn _ [] = ([], []) #endif - -#ifdef WITH_GEMINI_URI -mWhile test body = do - cond <- test - if cond then do - x <- body - xs <- mWhile test body - return (x:xs) - else return [] -#endif diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs index 0abdb03..15c27e8 100644 --- a/src/Network/URI/Messages.hs +++ b/src/Network/URI/Messages.hs @@ -29,6 +29,7 @@ trans ("en":_) (RequiresInstall mime appsMarkup) = trans ("en":_) (OpenedWith app) = "Opened in " ++ app trans ("en":_) (ReadFailed msg) = "Failed to read file: " ++ msg trans ("en":_) MalformedResponse = "Invalid response!" +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!" @@ -44,6 +45,7 @@ trans [] err = trans ["en"] err data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String | OpenedWith String | ReadFailed String | RawXML String | MalformedResponse + | ExcessiveRedirects #if WITH_HTTP_URI | Http HttpException #endif -- 2.30.2