From a841435e2a825ecd8d7f27b0140a2a46e6408fb6 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 1 Aug 2022 21:18:01 +1200 Subject: [PATCH] Support clientside certificates for HTTPS & Gemini. Meanwhile refactor Gemini to use internationalization for its error reporting. --- hurl.cabal | 2 +- src/Network/URI/Fetch.hs | 68 +++++++++++++++++++++++++++++-------- src/Network/URI/Messages.hs | 21 +++++++++++- 3 files changed, 74 insertions(+), 17 deletions(-) diff --git a/hurl.cabal b/hurl.cabal index b4e24d4..1174435 100644 --- a/hurl.cabal +++ b/hurl.cabal @@ -114,7 +114,7 @@ library if flag(http) CPP-options: -DWITH_HTTP_URI build-depends: http-client, http-types >= 0.12 && <0.13, publicsuffixlist >= 0.1, - http-client-tls, time, cookie + http-client-tls, time, cookie, connection, tls, data-default-class other-modules: Network.URI.Cache, Network.URI.CookiesDB if flag(gemini) CPP-options: -DWITH_GEMINI_URI -DWITH_RAW_CONNECTIONS diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs index ba45df7..4a3623b 100644 --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -3,7 +3,7 @@ -- | 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, redirectCount, cachingEnabled, validateCertificates), + Session(locale, aboutPages, redirectCount, cachingEnabled, validateCertificates, credentials), newSession, fetchURL, fetchURL', fetchURLs, submitURL, submitURL', mimeERR, htmlERR, dispatchByMIME, appsForMIME, Application(..), dispatchByApp, @@ -62,7 +62,7 @@ import Network.URI.Cache import Network.URI.CookiesDB #endif -#ifdef WITH_RAW_CONNECTIONS +#if WITH_HTTP_URI || WITH_RAW_CONNECTIONS import qualified Network.Connection as Conn import qualified Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS @@ -91,6 +91,7 @@ import System.Process data Session = Session { #ifdef WITH_HTTP_URI managerHTTP :: HTTP.Manager, + managerHTTPNoValidate :: HTTP.Manager, globalCookieJar :: MVar HTTP.CookieJar, cookiesPath :: FilePath, retroactiveCookies :: Maybe (MVar HTTP.CookieJar), @@ -118,7 +119,10 @@ data Session = Session { -- | App-specific config subdirectory to check appName :: String, -- | Whether to validate the server is who they say they are on secured protocols. - validateCertificates :: Bool + validateCertificates :: Bool, + -- | Bytestrings or files containing the client certificate to use for logging into the server. + credentials :: Maybe (Either (FilePath, FilePath) (C8.ByteString, C8.ByteString)), + credentials' :: MVar (Maybe (Either (FilePath, FilePath) (C8.ByteString, C8.ByteString))) } data LogRecord = LogRecord { @@ -140,8 +144,24 @@ newSession = newSession' "" newSession' :: String -> IO Session newSession' appname = do (ietfLocale, unixLocale) <- rfc2616Locale + credentialsMVar <- newMVar Nothing #ifdef WITH_HTTP_URI - managerHTTP' <- HTTP.newManager $ TLS.tlsManagerSettings + let httpsSettings = (TLS.defaultParamsClient "example.com" "https") { + TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default }, + TLS.clientHooks = def { + TLS.onCertificateRequest = deliverCredentials credentialsMVar + } + } + let httpsSettingsNoValidate = httpsSettings { + TLS.clientShared = def { + TLS.sharedValidationCache = TLS.ValidationCache + (\_ _ _ -> return TLS.ValidationCachePass) + (\_ _ _ -> return ()) + } + } + managerHTTP' <- HTTP.newManager $ TLS.mkManagerSettings (Conn.TLSSettings httpsSettings) Nothing + managerHTTPnovalidate' <- HTTP.newManager $ TLS.mkManagerSettings + (Conn.TLSSettings httpsSettingsNoValidate) Nothing cookiesDir <- getXdgDirectory XdgData "nz.geek.adrian.hurl.cookies2" let cookiesPath' = cookiesDir appname @@ -165,6 +185,7 @@ newSession' appname = do return Session { #ifdef WITH_HTTP_URI managerHTTP = managerHTTP', + managerHTTPNoValidate = managerHTTPnovalidate', globalCookieJar = cookieJar, cookiesPath = cookiesPath', retroactiveCookies = Just cookieJar', @@ -185,7 +206,9 @@ newSession' appname = do redirectCount = 5, cachingEnabled = True, validateCertificates = True, - appName = appname + appName = appname, + credentials = Nothing, + credentials' = credentialsMVar } llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key] @@ -291,6 +314,7 @@ submitURL' session accept uri method encoding query | uriScheme uri `elem` ["htt submitURL' session mimes uri _method _encoding query = fetchURL' session mimes uri { uriQuery = '?':encodeQuery query } encodeQuery :: [(String, Either String FilePath)] -> String +encodeQuery [("", Left query)] = query -- Mostly for the sake of Gemini... encodeQuery query = intercalate "&" $ M.mapMaybe encodePart query where encodePart (key, Left "") = Just $ escape key @@ -364,6 +388,7 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { uriScheme = "gemini:", uriAuthority = Just (URIAuth _ host port) } = do let params = TLS.defaultParamsClient host "gmni" + swapMVar (credentials' sess) (credentials sess) conn <- Conn.connectTo ctxt Conn.ConnectionParams { Conn.connectionHostname = host, Conn.connectionPort = parsePort 1965 port, @@ -374,6 +399,9 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { TLS.sharedValidationCache = TLS.ValidationCache (\_ _ _ -> return TLS.ValidationCachePass) (\_ _ _ -> return ()) + }, + TLS.clientHooks = def { + TLS.onCertificateRequest = deliverCredentials $ credentials' sess } }, Conn.connectionUseSocks = Nothing @@ -381,12 +409,6 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { Conn.connectionPut conn $ C8.pack $ uriToString id uri "\r\n" header <- Conn.connectionGetLine 1027 conn case parseHeader $ C8.unpack header of - -- NOTE: This case won't actually do anything until the caller (Rhapsode) implements forms. - ('1', _, label) -> return (uri, "application/xhtml+xml", Left $ Txt.concat [ - "
" - ]) ('2', _, mime) -> do body <- B.fromChunks <$> connectionGetChunks conn let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime @@ -395,9 +417,9 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@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) + (x, y, err) -> return (uri, mimeERR, Left $ Txt.pack $ + trans l $ 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) @@ -486,6 +508,9 @@ fetchHTTPCached session shouldCache accept@(defaultMIME:_) rawUri cbReq cbResp = | testHSTS now domain hsts -> return rawUri { uriScheme = "https:" }; _ -> return rawUri } + let manager = (if validateCertificates session + then managerHTTP else managerHTTPNoValidate) session + swapMVar (credentials' session) (credentials session) cached <- if shouldCache then readCacheHTTP uri else return (Nothing, Nothing) @@ -502,7 +527,7 @@ fetchHTTPCached session shouldCache accept@(defaultMIME:_) rawUri cbReq cbResp = ] ++ fromMaybe [] cachingHeaders, HTTP.redirectCount = 0 } - response <- HTTP.httpLbs request' $ managerHTTP session + response <- HTTP.httpLbs request' manager cbResp response case ( uriScheme uri, @@ -550,6 +575,19 @@ fetchHTTPCached session _ [] uri _ _ = return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ UnsupportedMIME "") #endif +#if WITH_HTTP_URI || WITH_GEMINI_URI +deliverCredentials credentialsMVar _ = do + credentials' <- readMVar credentialsMVar -- workaround for HTTP-Client-TLS + case credentials' of + Just (Left (public, private)) -> right <$> TLS.credentialLoadX509 public private + Just (Right (public, private)) -> + return $ right $ TLS.credentialLoadX509FromMemory public private + Nothing -> return Nothing + where + right (Left _) = Nothing + right (Right x) = Just x +#endif + -- Downloads utilities -- | write download to a file in the given directory. saveDownload :: URI -> FilePath -> (URI, String, Either Text ByteString) -> IO URI diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs index 6025553..6233d3b 100644 --- a/src/Network/URI/Messages.hs +++ b/src/Network/URI/Messages.hs @@ -88,6 +88,25 @@ trans ("en":_) (Http (HttpExceptionRequest _ (InternalException e))) = case from Just ConnectionNotEstablished -> "Attempted to send or recieve data before establishing secure connection!" Nothing -> "Internal error: " ++ displayException e +trans ("en":_) (GeminiError '1' '1' label) = + "