summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <alcinnz@lavabit.com>2022-08-01 21:18:01 +1200
committerAdrian Cochrane <alcinnz@lavabit.com>2022-08-01 21:18:01 +1200
commita841435e2a825ecd8d7f27b0140a2a46e6408fb6 (patch)
treef7d32b34fd18f6e32aed2dd49d95a073c31247ca
parent0836606622d85d93c5aa9177efbe01b09eba4f4f (diff)
downloadhurl-a841435e2a825ecd8d7f27b0140a2a46e6408fb6.tar.gz
hurl-a841435e2a825ecd8d7f27b0140a2a46e6408fb6.tar.bz2
hurl-a841435e2a825ecd8d7f27b0140a2a46e6408fb6.zip
Support clientside certificates for HTTPS & Gemini.
Meanwhile refactor Gemini to use internationalization for its error reporting.
-rw-r--r--hurl.cabal2
-rw-r--r--src/Network/URI/Fetch.hs68
-rw-r--r--src/Network/URI/Messages.hs21
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 [
- "<form><label>",
- Txt.replace "<" "&lt;" $ Txt.replace "&" "&amp;" label,
- "<input /></label></form>"
- ])
('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 "<" "&lt;" $ Txt.replace "&" "&amp;" 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) =
+ "<form><label>" ++ label ++ "<input type=password></form>"
+trans ("en":_) (GeminiError '1' _ label) = "<form><label>" ++ label ++ "<input></form>"
+trans ("en":_) (GeminiError '4' '1' _) = "Site unavailable!"
+trans ("en":_) (GeminiError '4' '2' _) = "Program error!"
+trans ("en":_) (GeminiError '4' '3' _) = "Proxy error!"
+trans ("en":_) (GeminiError '4' '4' timeout) =
+ "Site busy! Please reload after at least " ++ timeout ++ " seconds"
+trans ("en":_) (GeminiError '5' '1' _) = "Page not found!"
+trans ("en":_) (GeminiError '5' '2' _) = "Page deleted!"
+trans ("en":_) (GeminiError '5' '3' _) = "Contacted wrong server!"
+trans ("en":_) (GeminiError '5' '9' _) = "Malformed request, my bad!"
+trans ("en":_) (GeminiError '6' '1' _) = "<form><label>Authentication required" ++
+ "<input type='-argo-keypair' -argo-error='Unauthorized account!'></form>"
+trans ("en":_) (GeminiError '6' '2' _) = "<form><label>Authentication required" ++
+ "<input type='-argo-keypair' -argo-error='Invalid account!'></form>"
+trans ("en":_) (GeminiError '6' _ _) = "<form><label>Authentication required" ++
+ "<input type='-argo-keypair' -argo-error='Invalid account!'></form>"
+trans ("en":_) (GeminiError _ _ error) = error
#endif
--- END LOCALIZATION
@@ -96,7 +115,7 @@ trans [] err = trans ["en"] err
data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String
| OpenedWith String | ReadFailed String | RawXML String | MalformedResponse
- | ExcessiveRedirects
+ | ExcessiveRedirects | GeminiError Char Char String
#if WITH_HTTP_URI
| Http HttpException
#endif