From a7c88c86ffb0620b2557bb6aa4a35c2749bfaf22 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 16 Apr 2020 20:25:35 +1200 Subject: [PATCH] Expose redirected URIs to caller. --- src/Network/URI/Charset.hs | 6 +++- src/Network/URI/Fetch.hs | 60 +++++++++++++++++++++----------------- 2 files changed, 38 insertions(+), 28 deletions(-) diff --git a/src/Network/URI/Charset.hs b/src/Network/URI/Charset.hs index da98afb..5751eef 100644 --- a/src/Network/URI/Charset.hs +++ b/src/Network/URI/Charset.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | Handles server-specified text decoding. -module Network.URI.Charset(resolveCharset, convertCharset, charsets) where +module Network.URI.Charset(resolveCharset, resolveCharset', convertCharset, charsets) where import Data.Text (Text) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as B @@ -18,6 +18,10 @@ resolveCharset (mime:_:params) response = resolveCharset (mime:params) response resolveCharset [mime] response = (mime, Right $ response) resolveCharset [] response = ("text/plain", Left "Filetype unspecified") +-- | 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') + -- | Decodes bytes according to a charset identified by it's IANA-assigned name(s). convertCharset "iso-8859-1" = decodeLatin1 convertCharset "latin1" = decodeLatin1 diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs index c928942..78b64f3 100644 --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -94,16 +94,22 @@ fetchURL :: Session -- ^ The session of which this request is a part. -> [String] -- ^ The expected MIMEtypes in priority order. -> URI -- ^ The URL to retrieve -> IO (String, Either Text ByteString) -- ^ The MIMEtype & possibly text-decoded response. -fetchURL session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) = - fetchURL session mimes $ uri {uriPath = "version"} -fetchURL Session {aboutPages = pages} _ URI {uriScheme = "about:", uriPath = path} = - return ( +fetchURL sess mimes uri = do + (_, mime, resp) <- fetchURL' sess mimes uri + return (mime, resp) + +-- | As per `fetchURL`, but also returns the redirected URI. +fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString) +fetchURL' session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) = + fetchURL' session mimes $ uri {uriPath = "version"} +fetchURL' Session {aboutPages = pages} _ url@URI {uriScheme = "about:", uriPath = path} = + return (url, Txt.unpack $ convertCharset "utf-8" $ B.toStrict $ llookup (path ++ ".mime") "text/html" pages, Right $ llookup path "" pages) #ifdef WITH_HTTP_URI -fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do +fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do request <- HTTP.requestFromURI uri response <- HTTP.httpLbs request { HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form. @@ -116,18 +122,18 @@ fetchURL session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "ht HTTP.responseBody response, [val | ("content-type", val) <- HTTP.responseHeaders response] ) of - ("", _) -> ("text/plain", Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response) + ("", _) -> (uri, "text/plain", Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response) (response, (mimetype:_)) -> let mime = Txt.toLower $ convertCharset "utf-8" mimetype - in resolveCharset (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime) response - (response, []) -> (defaultMIME, Right response) + in resolveCharset' uri (map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime) response + (response, []) -> (uri, defaultMIME, Right response) `catches` [ - Handler $ \e -> do return ("text/plain", Left $ Txt.pack $ trans (locale session) $ Http e), - Handler $ \(ErrorCall msg) -> do return ("text/plain", Left $ Txt.pack msg) + Handler $ \e -> do return (uri, "text/plain", Left $ Txt.pack $ trans (locale session) $ Http e), + Handler $ \(ErrorCall msg) -> do return (uri, "text/plain", Left $ Txt.pack msg) ] #endif #ifdef WITH_GEMINI_URI -fetchURL sess@Session {connCtxt = ctxt} mimes uri@URI { +fetchURL' sess@Session {connCtxt = ctxt} mimes uri@URI { uriScheme = "gemini:", uriAuthority = Just (URIAuth _ host port) } = do conn <- connectTo ctxt $ ConnectionParams { @@ -141,7 +147,7 @@ fetchURL sess@Session {connCtxt = ctxt} mimes uri@URI { header <- connectionGetLine 1024 conn ret <- case parseHeader header of -- NOTE: This case won't actually do anything until the caller (Rhapsode) implements forms. - ('1', _, label) -> return ("application/xhtml+xml", Left $ Txt.concat [ + ('1', _, label) -> return (uri, "application/xhtml+xml", Left $ Txt.concat [ "
" @@ -149,12 +155,12 @@ fetchURL sess@Session {connCtxt = ctxt} mimes uri@URI { ('2', _, mime) -> do chunks <- mWhile (connectionWaitForInput conn 60000) $ connectionGetChunk conn let mime' = map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime - return $ resolveCharset mime' $ B.fromChunks chunks + return $ resolveCharset' uri mime' $ B.fromChunks chunks ('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect -> - fetchURL sess mimes $ relativeTo redirect' uri + fetchURL' sess 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 ("text/plain", Left err) + (_, _, err) -> return (uri, "text/plain", Left err) connectionClose conn return ret where @@ -165,34 +171,34 @@ fetchURL sess@Session {connCtxt = ctxt} mimes uri@URI { #endif #ifdef WITH_FILE_URI -fetchURL Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do +fetchURL' Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do response <- B.readFile $ uriPath uri - return (defaultMIME, Right response) + return (uri, defaultMIME, Right response) `catch` \e -> do - return ( + return (uri, "text/plain", Left $ Txt.pack $ trans l $ ReadFailed $ displayException (e :: IOException)) #endif #ifdef WITH_DATA_URI -fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} = +fetchURL' _ (defaultMIME:_) uri@URI {uriScheme = "data:"} = let request = uriPath uri ++ uriQuery uri ++ uriFragment uri in case breakOn ',' $ unEscapeString request of - ("", response) -> return (defaultMIME, Left $ Txt.pack response) + ("", response) -> return (uri, defaultMIME, Left $ Txt.pack response) (mime', response) | '4':'6':'e':'s':'a':'b':';':mime <- reverse mime' -> return $ case B64.decode $ C8.pack response of - Left str -> ("text/plain", Left $ Txt.pack str) - Right bytes -> (reverse mime, Right $ B.fromStrict bytes) - (mime, response) -> return (mime, Left $ Txt.pack response) + Left str -> (uri, "text/plain", Left $ Txt.pack str) + Right bytes -> (uri, reverse mime, Right $ B.fromStrict bytes) + (mime, response) -> return (uri, mime, Left $ Txt.pack response) #endif #ifdef WITH_XDG -fetchURL Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do +fetchURL' Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do app <- dispatchURIByMIME a uri ("x-scheme-handler/" ++ init s) - return ("text/html", Left $ Txt.pack $ trans l $ app) + return (uri, "text/html", Left $ Txt.pack $ trans l $ app) #else -fetchURL Session {locale = l} _ URI {uriScheme = scheme} = - return ("text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme) +fetchURL' Session {locale = l} _ URI {uriScheme = scheme} = + return (uri, "text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme) #endif dispatchByMIME :: Session -> String -> URI -> IO (Maybe String) -- 2.30.2