3 files changed, 74 insertions(+), 17 deletions(-)

M hurl.cabal
M src/Network/URI/Fetch.hs
M src/Network/URI/Messages.hs

@@ 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

@@ 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

@@ 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