From c62474ca4be894f2f20c1ce64015018f2bc8b804 Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 29 Apr 2021 09:27:34 -0600 Subject: [PATCH 01/11] PoC: Add TLS support This adds TLS support for Pgx_async using Conduit. This is only a proof of concept because: - We're using the Conduit.V1 interface, which we may not want to rely on (the latest is V3) - We need to add support for Pgx_async - We probably need better error handling than asserts Resolves #107 --- pgx/src/io_intf.ml | 1 + pgx/src/pgx.ml | 22 ++++++++++++++++++++++ pgx_async.opam | 2 ++ pgx_async/src/dune | 2 +- pgx_async/src/pgx_async.ml | 20 +++++++++----------- 5 files changed, 35 insertions(+), 12 deletions(-) diff --git a/pgx/src/io_intf.ml b/pgx/src/io_intf.ml index 867ac38..e6c55c0 100644 --- a/pgx/src/io_intf.ml +++ b/pgx/src/io_intf.ml @@ -14,6 +14,7 @@ module type S = sig | Inet of string * int val open_connection : sockaddr -> (in_channel * out_channel) t + val upgrade_ssl : in_channel -> out_channel -> (in_channel * out_channel) t val output_char : out_channel -> char -> unit t val output_binary_int : out_channel -> int -> unit t val output_string : out_channel -> string -> unit t diff --git a/pgx/src/pgx.ml b/pgx/src/pgx.ml index 9c00400..2bcf0f2 100644 --- a/pgx/src/pgx.ml +++ b/pgx/src/pgx.ml @@ -288,6 +288,7 @@ module Message_out = struct | Describe_portal of portal (* DP *) | Startup_message of startup | Simple_query of query + | SSLRequest [@@deriving sexp] let add_byte buf i = @@ -381,6 +382,10 @@ module Message_out = struct add_byte msg 0; None, Buffer.contents msg | Simple_query q -> Some 'Q', str q + | SSLRequest -> + let msg = Buffer.create 8 in + add_int32 msg 80877103l; + None, Buffer.contents msg ;; end @@ -526,6 +531,21 @@ module Make (Thread : Io) = struct (*----- Connection. -----*) + let attempt_tls_upgrade ({ ichan ; chan ; _ } as conn) = + let msg = Message_out.SSLRequest in + send_message conn msg + >>= fun () -> + flush chan + >>= fun () -> + input_char ichan + >>= (function + | 'S' -> + upgrade_ssl ichan chan + >>= fun (ichan, chan) -> + return { conn with ichan ; chan } + | 'N' -> return conn + | _c -> assert false) + let connect ?host ?port @@ -600,6 +620,8 @@ module Make (Thread : Io) = struct ; prepared_num = Int64.of_int 0 } in + attempt_tls_upgrade conn + >>= fun conn -> (* Send the StartUpMessage. NB. At present we do not support SSL. *) let msg = Message_out.Startup_message { Message_out.user; database } in (* Loop around here until the database gives a ReadyForQuery message. *) diff --git a/pgx_async.opam b/pgx_async.opam index e9dbcfe..8f9e4b8 100644 --- a/pgx_async.opam +++ b/pgx_async.opam @@ -12,8 +12,10 @@ depends: [ "dune" {>= "1.11"} "alcotest-async" {with-test & >= "1.0.0"} "async_kernel" {>= "v0.13.0"} + "async_ssl" "async_unix" {>= "v0.13.0"} "base64" {with-test & >= "3.0.0"} + "conduit-async" "ocaml" {>= "4.08"} "pgx" {= version} "pgx_value_core" {= version} diff --git a/pgx_async/src/dune b/pgx_async/src/dune index 5e63847..e361930 100644 --- a/pgx_async/src/dune +++ b/pgx_async/src/dune @@ -11,6 +11,6 @@ let () = Jbuild_plugin.V1.send @@ {| (library (public_name pgx_async) (wrapped false) - (libraries async_kernel async_unix pgx_value_core) + (libraries async_kernel async_unix conduit-async pgx_value_core) |} ^ preprocess ^ {|) |} diff --git a/pgx_async/src/pgx_async.ml b/pgx_async/src/pgx_async.ml index 7aec8ae..5b37381 100644 --- a/pgx_async/src/pgx_async.ml +++ b/pgx_async/src/pgx_async.ml @@ -73,21 +73,19 @@ module Thread = struct let close_in = Reader.close let open_connection sockaddr = - let get_reader_writer socket = - let fd = Socket.fd socket in - Reader.create fd, Writer.create fd - in match sockaddr with - | Unix path -> - let unix_sockaddr = Tcp.Where_to_connect.of_unix_address (`Unix path) in - Tcp.connect_sock unix_sockaddr >>| get_reader_writer + | Unix path -> Conduit_async.connect (`Unix_domain_socket path) | Inet (host, port) -> - let inet_sockaddr = - Tcp.Where_to_connect.of_host_and_port (Host_and_port.create ~host ~port) - in - Tcp.connect_sock inet_sockaddr >>| get_reader_writer + Uri.make ~host ~port () + |> Conduit_async.V3.resolve_uri + >>= Conduit_async.V3.connect + >>| fun (_socket, in_channel, out_channel) -> in_channel, out_channel ;; + let upgrade_ssl in_channel out_channel = + let config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in + Conduit_async.V1.Conduit_async_ssl.ssl_connect config in_channel out_channel + (* The unix getlogin syscall can fail *) let getlogin () = Unix.getuid () |> Unix.Passwd.getbyuid_exn >>| fun { name; _ } -> name From c7829b2044c1ebe18ea1872ea124ff5b50e2023e Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 29 Apr 2021 09:30:44 -0600 Subject: [PATCH 02/11] Add a comment about how the TLS upgrade works --- pgx/src/pgx.ml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/pgx/src/pgx.ml b/pgx/src/pgx.ml index 2bcf0f2..8465d74 100644 --- a/pgx/src/pgx.ml +++ b/pgx/src/pgx.ml @@ -532,6 +532,14 @@ module Make (Thread : Io) = struct (*----- Connection. -----*) let attempt_tls_upgrade ({ ichan ; chan ; _ } as conn) = + (* To initiate an SSL-encrypted connection, the frontend initially sends an SSLRequest message rather than a + StartupMessage. The server then responds with a single byte containing S or N, indicating that it is willing + or unwilling to perform SSL, respectively. The frontend might close the connection at this point if it is + dissatisfied with the response. To continue after S, perform an SSL startup handshake (not described here, + part of the SSL specification) with the server. If this is successful, continue with sending the usual + StartupMessage. In this case the StartupMessage and all subsequent data will be SSL-encrypted. To continue + after N, send the usual StartupMessage and proceed without encryption. + See https://www.postgresql.org/docs/9.3/protocol-flow.html#AEN100021 *) let msg = Message_out.SSLRequest in send_message conn msg >>= fun () -> From fda45308bca88f8768bd5475a0e4c0410d3fc94d Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 29 Apr 2021 09:45:44 -0600 Subject: [PATCH 03/11] Make TLS support optional --- pgx/src/io_intf.ml | 2 +- pgx/src/pgx.ml | 34 +++++++++++++++++++++------------- pgx_async/src/pgx_async.ml | 12 +++++++++--- 3 files changed, 31 insertions(+), 17 deletions(-) diff --git a/pgx/src/io_intf.ml b/pgx/src/io_intf.ml index e6c55c0..1b1a870 100644 --- a/pgx/src/io_intf.ml +++ b/pgx/src/io_intf.ml @@ -14,7 +14,7 @@ module type S = sig | Inet of string * int val open_connection : sockaddr -> (in_channel * out_channel) t - val upgrade_ssl : in_channel -> out_channel -> (in_channel * out_channel) t + val upgrade_ssl : [ `Not_supported | `Supported of (in_channel -> out_channel -> (in_channel * out_channel) t) ] val output_char : out_channel -> char -> unit t val output_binary_int : out_channel -> int -> unit t val output_string : out_channel -> string -> unit t diff --git a/pgx/src/pgx.ml b/pgx/src/pgx.ml index 8465d74..fa97b6f 100644 --- a/pgx/src/pgx.ml +++ b/pgx/src/pgx.ml @@ -540,19 +540,26 @@ module Make (Thread : Io) = struct StartupMessage. In this case the StartupMessage and all subsequent data will be SSL-encrypted. To continue after N, send the usual StartupMessage and proceed without encryption. See https://www.postgresql.org/docs/9.3/protocol-flow.html#AEN100021 *) - let msg = Message_out.SSLRequest in - send_message conn msg - >>= fun () -> - flush chan - >>= fun () -> - input_char ichan - >>= (function - | 'S' -> - upgrade_ssl ichan chan - >>= fun (ichan, chan) -> - return { conn with ichan ; chan } - | 'N' -> return conn - | _c -> assert false) + match Io.upgrade_ssl with + | `Not_supported -> return conn + | `Supported upgrade_ssl -> + Stdlib.print_string "Attempting STARTLS\n"; + let msg = Message_out.SSLRequest in + send_message conn msg + >>= fun () -> + flush chan + >>= fun () -> + input_char ichan + >>= (function + | 'S' -> + Stdlib.print_string "Upgrading to TLS\n"; + upgrade_ssl ichan chan + >>= fun (ichan, chan) -> + return { conn with ichan ; chan } + | 'N' -> + Stdlib.print_string "Not upgrading\n"; + return conn + | _c -> assert false) let connect ?host @@ -603,6 +610,7 @@ module Make (Thread : Io) = struct (try Inet (Sys.getenv "PGHOST", port) with | Not_found -> (* use Unix domain socket. *) + Stdlib.print_string "Using Unix socket\n"; let path = sprintf "%s/.s.PGSQL.%d" unix_domain_socket_dir port in Unix path) in diff --git a/pgx_async/src/pgx_async.ml b/pgx_async/src/pgx_async.ml index 5b37381..bdfd6be 100644 --- a/pgx_async/src/pgx_async.ml +++ b/pgx_async/src/pgx_async.ml @@ -82,9 +82,15 @@ module Thread = struct >>| fun (_socket, in_channel, out_channel) -> in_channel, out_channel ;; - let upgrade_ssl in_channel out_channel = - let config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in - Conduit_async.V1.Conduit_async_ssl.ssl_connect config in_channel out_channel + let upgrade_ssl = + try + let config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in + Stdlib.print_string "TLS supported\n"; + `Supported (fun in_channel out_channel -> + Conduit_async.V1.Conduit_async_ssl.ssl_connect config in_channel out_channel) + with _ -> + Stdlib.print_string "TLS not supported\n"; + `Not_supported (* The unix getlogin syscall can fail *) let getlogin () = Unix.getuid () |> Unix.Passwd.getbyuid_exn >>| fun { name; _ } -> name From b93623e4807e44af0084800eb439e87ba8490075 Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 29 Apr 2021 09:52:52 -0600 Subject: [PATCH 04/11] Make Pgx_lwt and Pgx_unix compile --- pgx_lwt/src/pgx_lwt.ml | 1 + pgx_unix/src/pgx_unix.ml | 2 ++ 2 files changed, 3 insertions(+) diff --git a/pgx_lwt/src/pgx_lwt.ml b/pgx_lwt/src/pgx_lwt.ml index 70f827d..b44d836 100644 --- a/pgx_lwt/src/pgx_lwt.ml +++ b/pgx_lwt/src/pgx_lwt.ml @@ -47,6 +47,7 @@ module Thread = struct let close_in = Io.close_in let open_connection = Io.open_connection + let upgrade_ssl = `Not_supported let getlogin = Io.getlogin let debug s = Logs_lwt.debug (fun m -> m "%s" s) let protect f ~finally = Lwt.finalize f finally diff --git a/pgx_unix/src/pgx_unix.ml b/pgx_unix/src/pgx_unix.ml index d0b94b6..501ceb4 100644 --- a/pgx_unix/src/pgx_unix.ml +++ b/pgx_unix/src/pgx_unix.ml @@ -55,6 +55,8 @@ module Simple_thread = struct Unix.open_connection std_socket ;; + let upgrade_ssl = `Not_supported + let output_char = output_char let output_binary_int = output_binary_int let output_string = output_string From 8d8d75061e435f6206db9fde179a6ad8f4fff4a3 Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 29 Apr 2021 10:01:50 -0600 Subject: [PATCH 05/11] Make async_ssl optional --- pgx_async.opam | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/pgx_async.opam b/pgx_async.opam index 8f9e4b8..d7ec956 100644 --- a/pgx_async.opam +++ b/pgx_async.opam @@ -12,7 +12,6 @@ depends: [ "dune" {>= "1.11"} "alcotest-async" {with-test & >= "1.0.0"} "async_kernel" {>= "v0.13.0"} - "async_ssl" "async_unix" {>= "v0.13.0"} "base64" {with-test & >= "3.0.0"} "conduit-async" @@ -20,6 +19,9 @@ depends: [ "pgx" {= version} "pgx_value_core" {= version} ] +depopts: [ + "async_ssl" +] build: [ ["dune" "subst"] {pinned} [ From 1fafbea9aeaecd6633a9c5fa9ffe986c562af927 Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 6 May 2021 11:50:20 -0600 Subject: [PATCH 06/11] Add arguments to control SSL --- pgx/src/io_intf.ml | 13 ++++++++- pgx/src/pgx.ml | 55 ++++++++++++++++++++++--------------- pgx/src/pgx_intf.ml | 7 +++-- pgx_async/src/pgx_async.ml | 17 +++++++++--- pgx_async/src/pgx_async.mli | 3 +- pgx_lwt/src/pgx_lwt.ml | 1 + pgx_unix/src/pgx_unix.ml | 3 +- 7 files changed, 68 insertions(+), 31 deletions(-) diff --git a/pgx/src/io_intf.ml b/pgx/src/io_intf.ml index 1b1a870..00babdd 100644 --- a/pgx/src/io_intf.ml +++ b/pgx/src/io_intf.ml @@ -14,7 +14,18 @@ module type S = sig | Inet of string * int val open_connection : sockaddr -> (in_channel * out_channel) t - val upgrade_ssl : [ `Not_supported | `Supported of (in_channel -> out_channel -> (in_channel * out_channel) t) ] + + type ssl_config + + val upgrade_ssl + : [ `Not_supported + | `Supported of + ?ssl_config:ssl_config + -> in_channel + -> out_channel + -> (in_channel * out_channel) t + ] + val output_char : out_channel -> char -> unit t val output_binary_int : out_channel -> int -> unit t val output_string : out_channel -> string -> unit t diff --git a/pgx/src/pgx.ml b/pgx/src/pgx.ml index fa97b6f..62e0d60 100644 --- a/pgx/src/pgx.ml +++ b/pgx/src/pgx.ml @@ -531,7 +531,7 @@ module Make (Thread : Io) = struct (*----- Connection. -----*) - let attempt_tls_upgrade ({ ichan ; chan ; _ } as conn) = + let attempt_tls_upgrade ?(ssl = `Auto) ({ ichan; chan; _ } as conn) = (* To initiate an SSL-encrypted connection, the frontend initially sends an SSLRequest message rather than a StartupMessage. The server then responds with a single byte containing S or N, indicating that it is willing or unwilling to perform SSL, respectively. The frontend might close the connection at this point if it is @@ -540,28 +540,37 @@ module Make (Thread : Io) = struct StartupMessage. In this case the StartupMessage and all subsequent data will be SSL-encrypted. To continue after N, send the usual StartupMessage and proceed without encryption. See https://www.postgresql.org/docs/9.3/protocol-flow.html#AEN100021 *) - match Io.upgrade_ssl with - | `Not_supported -> return conn - | `Supported upgrade_ssl -> - Stdlib.print_string "Attempting STARTLS\n"; - let msg = Message_out.SSLRequest in - send_message conn msg - >>= fun () -> - flush chan - >>= fun () -> - input_char ichan - >>= (function - | 'S' -> - Stdlib.print_string "Upgrading to TLS\n"; - upgrade_ssl ichan chan - >>= fun (ichan, chan) -> - return { conn with ichan ; chan } - | 'N' -> - Stdlib.print_string "Not upgrading\n"; - return conn - | _c -> assert false) + match ssl with + | `No -> return conn + | (`Auto | `Always _) as ssl -> + (match Io.upgrade_ssl with + | `Not_supported -> return conn + | `Supported upgrade_ssl -> + Stdlib.print_string "Attempting STARTLS\n"; + let msg = Message_out.SSLRequest in + send_message conn msg + >>= fun () -> + flush chan + >>= fun () -> + input_char ichan + >>= (function + | 'S' -> + Stdlib.print_string "Upgrading to TLS\n"; + let ssl_config = + match ssl with + | `Auto -> None + | `Always ssl_config -> Some ssl_config + in + upgrade_ssl ?ssl_config ichan chan + >>= fun (ichan, chan) -> return { conn with ichan; chan } + | 'N' -> + Stdlib.print_string "Not upgrading\n"; + return conn + | _c -> assert false)) + ;; let connect + ?ssl ?host ?port ?user @@ -636,7 +645,7 @@ module Make (Thread : Io) = struct ; prepared_num = Int64.of_int 0 } in - attempt_tls_upgrade conn + attempt_tls_upgrade ?ssl conn >>= fun conn -> (* Send the StartUpMessage. NB. At present we do not support SSL. *) let msg = Message_out.Startup_message { Message_out.user; database } in @@ -703,6 +712,7 @@ module Make (Thread : Io) = struct ;; let with_conn + ?ssl ?host ?port ?user @@ -714,6 +724,7 @@ module Make (Thread : Io) = struct f = connect + ?ssl ?host ?port ?user diff --git a/pgx/src/pgx_intf.ml b/pgx/src/pgx_intf.ml index f6167ad..6bd16e4 100644 --- a/pgx/src/pgx_intf.ml +++ b/pgx/src/pgx_intf.ml @@ -5,6 +5,7 @@ module type S = sig module Io : sig type 'a t + type ssl_config val return : 'a -> 'a t val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t @@ -22,7 +23,8 @@ module type S = sig possible denial of service. You may want to set this to a smaller size to avoid this happening. *) val connect - : ?host:string + : ?ssl:[ `Auto | `No | `Always of Io.ssl_config ] + -> ?host:string -> ?port:int -> ?user:string -> ?password:string @@ -42,7 +44,8 @@ module type S = sig [close]. This is the preferred way to use this library since it cleans up after itself. *) val with_conn - : ?host:string + : ?ssl:[ `Auto | `No | `Always of Io.ssl_config ] + -> ?host:string -> ?port:int -> ?user:string -> ?password:string diff --git a/pgx_async/src/pgx_async.ml b/pgx_async/src/pgx_async.ml index bdfd6be..7e9cc16 100644 --- a/pgx_async/src/pgx_async.ml +++ b/pgx_async/src/pgx_async.ml @@ -82,15 +82,20 @@ module Thread = struct >>| fun (_socket, in_channel, out_channel) -> in_channel, out_channel ;; + type ssl_config = Conduit_async.Ssl.config + let upgrade_ssl = try - let config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in + let default_config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in Stdlib.print_string "TLS supported\n"; - `Supported (fun in_channel out_channel -> - Conduit_async.V1.Conduit_async_ssl.ssl_connect config in_channel out_channel) - with _ -> + `Supported + (fun ?(ssl_config = default_config) in_channel out_channel -> + Conduit_async.V1.Conduit_async_ssl.ssl_connect ssl_config in_channel out_channel) + with + | _ -> Stdlib.print_string "TLS not supported\n"; `Not_supported + ;; (* The unix getlogin syscall can fail *) let getlogin () = Unix.getuid () |> Unix.Passwd.getbyuid_exn >>| fun { name; _ } -> name @@ -134,6 +139,7 @@ let check_pgdatabase = ;; let connect + ?ssl ?host ?port ?user @@ -150,6 +156,7 @@ let connect | None -> Lazy_deferred.force_exn default_unix_domain_socket_dir) >>= fun unix_domain_socket_dir -> connect + ?ssl ?host ?port ?user @@ -162,6 +169,7 @@ let connect ;; let with_conn + ?ssl ?host ?port ?user @@ -173,6 +181,7 @@ let with_conn f = connect + ?ssl ?host ?port ?user diff --git a/pgx_async/src/pgx_async.mli b/pgx_async/src/pgx_async.mli index 8adc38f..43b7ac5 100644 --- a/pgx_async/src/pgx_async.mli +++ b/pgx_async/src/pgx_async.mli @@ -7,7 +7,8 @@ include Pgx.S with type 'a Io.t = 'a Deferred.t module Thread : Pgx.Io with type 'a t = 'a Deferred.t val with_conn - : ?host:string + : ?ssl:[ `Auto | `No | `Always of Io.ssl_config ] + -> ?host:string -> ?port:int -> ?user:string -> ?password:string diff --git a/pgx_lwt/src/pgx_lwt.ml b/pgx_lwt/src/pgx_lwt.ml index b44d836..c70ac8a 100644 --- a/pgx_lwt/src/pgx_lwt.ml +++ b/pgx_lwt/src/pgx_lwt.ml @@ -47,6 +47,7 @@ module Thread = struct let close_in = Io.close_in let open_connection = Io.open_connection + type ssl_config let upgrade_ssl = `Not_supported let getlogin = Io.getlogin let debug s = Logs_lwt.debug (fun m -> m "%s" s) diff --git a/pgx_unix/src/pgx_unix.ml b/pgx_unix/src/pgx_unix.ml index 501ceb4..965f7f6 100644 --- a/pgx_unix/src/pgx_unix.ml +++ b/pgx_unix/src/pgx_unix.ml @@ -55,8 +55,9 @@ module Simple_thread = struct Unix.open_connection std_socket ;; - let upgrade_ssl = `Not_supported + type ssl_config + let upgrade_ssl = `Not_supported let output_char = output_char let output_binary_int = output_binary_int let output_string = output_string From 5fc8f7e38f14b681474fb77d5729c96cf04dedfa Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 6 May 2021 11:52:30 -0600 Subject: [PATCH 07/11] List new deps correctly in dune-project --- dune-project | 5 ++++- pgx_async.opam | 4 +--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/dune-project b/dune-project index 6af5f58..c5fda85 100644 --- a/dune-project +++ b/dune-project @@ -86,12 +86,15 @@ (and :with-test (>= 3.0.0))) + conduit-async (ocaml (>= 4.08)) (pgx (= :version)) (pgx_value_core - (= :version)))) + (= :version))) + (depopts + async_ssl)) (package (name pgx_lwt) diff --git a/pgx_async.opam b/pgx_async.opam index d7ec956..3c7e88d 100644 --- a/pgx_async.opam +++ b/pgx_async.opam @@ -19,9 +19,7 @@ depends: [ "pgx" {= version} "pgx_value_core" {= version} ] -depopts: [ - "async_ssl" -] +depopts: ["async_ssl"] build: [ ["dune" "subst"] {pinned} [ From 33346859da57989a2d3f196c5d2bc8b22eebad82 Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 6 May 2021 12:23:44 -0600 Subject: [PATCH 08/11] Use debug instead of printing directly to console --- pgx/src/pgx.ml | 22 ++++++++++++++-------- pgx_async/src/pgx_async.ml | 5 +---- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/pgx/src/pgx.ml b/pgx/src/pgx.ml index 62e0d60..3c5152e 100644 --- a/pgx/src/pgx.ml +++ b/pgx/src/pgx.ml @@ -544,9 +544,13 @@ module Make (Thread : Io) = struct | `No -> return conn | (`Auto | `Always _) as ssl -> (match Io.upgrade_ssl with - | `Not_supported -> return conn + | `Not_supported -> + debug + "TLS-support is not compiled into this Pgx library, not attempting to upgrade" + >>| fun () -> conn | `Supported upgrade_ssl -> - Stdlib.print_string "Attempting STARTLS\n"; + debug "Request SSL upgrade from server" + >>= fun () -> let msg = Message_out.SSLRequest in send_message conn msg >>= fun () -> @@ -555,7 +559,8 @@ module Make (Thread : Io) = struct input_char ichan >>= (function | 'S' -> - Stdlib.print_string "Upgrading to TLS\n"; + debug "Server supports TLS, attempting to upgrade" + >>= fun () -> let ssl_config = match ssl with | `Auto -> None @@ -563,10 +568,12 @@ module Make (Thread : Io) = struct in upgrade_ssl ?ssl_config ichan chan >>= fun (ichan, chan) -> return { conn with ichan; chan } - | 'N' -> - Stdlib.print_string "Not upgrading\n"; - return conn - | _c -> assert false)) + | 'N' -> debug "Server does not support TLS, not upgrading" >>| fun () -> conn + | c -> + fail_msg + "Got unexpected response '%c' from server after SSLRequest message. Response \ + should always be 'S' or 'N'." + c)) ;; let connect @@ -619,7 +626,6 @@ module Make (Thread : Io) = struct (try Inet (Sys.getenv "PGHOST", port) with | Not_found -> (* use Unix domain socket. *) - Stdlib.print_string "Using Unix socket\n"; let path = sprintf "%s/.s.PGSQL.%d" unix_domain_socket_dir port in Unix path) in diff --git a/pgx_async/src/pgx_async.ml b/pgx_async/src/pgx_async.ml index 7e9cc16..0e3ac26 100644 --- a/pgx_async/src/pgx_async.ml +++ b/pgx_async/src/pgx_async.ml @@ -87,14 +87,11 @@ module Thread = struct let upgrade_ssl = try let default_config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in - Stdlib.print_string "TLS supported\n"; `Supported (fun ?(ssl_config = default_config) in_channel out_channel -> Conduit_async.V1.Conduit_async_ssl.ssl_connect ssl_config in_channel out_channel) with - | _ -> - Stdlib.print_string "TLS not supported\n"; - `Not_supported + | _ -> `Not_supported ;; (* The unix getlogin syscall can fail *) From d4f426a2d746bb94fe7de36f7f3b89eb58b5ab18 Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 6 May 2021 12:54:21 -0600 Subject: [PATCH 09/11] Error out if TLS support is not provided --- pgx/src/pgx.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/pgx/src/pgx.ml b/pgx/src/pgx.ml index 3c5152e..4ae77e5 100644 --- a/pgx/src/pgx.ml +++ b/pgx/src/pgx.ml @@ -545,6 +545,12 @@ module Make (Thread : Io) = struct | (`Auto | `Always _) as ssl -> (match Io.upgrade_ssl with | `Not_supported -> + (match ssl with + | `Always _ -> + failwith + "TLS support is not compiled into this Pgx library but ~ssl was set to \ + `Always" + | _ -> ()); debug "TLS-support is not compiled into this Pgx library, not attempting to upgrade" >>| fun () -> conn From 993def62525a6b67572f6edc5c9ce7a787f36554 Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 6 May 2021 13:15:03 -0600 Subject: [PATCH 10/11] Support passing ssl_config through --- pgx/src/pgx.mli | 3 ++- pgx_async/src/pgx_async.mli | 18 ++++-------------- 2 files changed, 6 insertions(+), 15 deletions(-) diff --git a/pgx/src/pgx.mli b/pgx/src/pgx.mli index 526f400..cbf5ec6 100644 --- a/pgx/src/pgx.mli +++ b/pgx/src/pgx.mli @@ -49,4 +49,5 @@ module Value = Pgx_value module type S = Pgx_intf.S -module Make (Thread : Io) : S with type 'a Io.t = 'a Thread.t +module Make (Thread : Io) : + S with type 'a Io.t = 'a Thread.t and type Io.ssl_config = Thread.ssl_config diff --git a/pgx_async/src/pgx_async.mli b/pgx_async/src/pgx_async.mli index 43b7ac5..f816033 100644 --- a/pgx_async/src/pgx_async.mli +++ b/pgx_async/src/pgx_async.mli @@ -1,24 +1,14 @@ (** Async based Postgres client based on Pgx. *) open Async_kernel -include Pgx.S with type 'a Io.t = 'a Deferred.t +include + Pgx.S + with type 'a Io.t = 'a Deferred.t + and type Io.ssl_config = Conduit_async.Ssl.config (* for testing purposes *) module Thread : Pgx.Io with type 'a t = 'a Deferred.t -val with_conn - : ?ssl:[ `Auto | `No | `Always of Io.ssl_config ] - -> ?host:string - -> ?port:int - -> ?user:string - -> ?password:string - -> ?database:string - -> ?unix_domain_socket_dir:string - -> ?verbose:int - -> ?max_message_length:int - -> (t -> 'a Deferred.t) - -> 'a Deferred.t - (** Like [execute] but returns a pipe so you can operate on the results before they have all returned. Note that [execute_iter] and [execute_fold] can perform significantly better because they don't have as much overhead. *) From dd4f573d1349d75d571d83d38c3fcc8b52dee4ac Mon Sep 17 00:00:00 2001 From: Brendan Long Date: Thu, 6 May 2021 13:41:31 -0600 Subject: [PATCH 11/11] Make async_ssl required --- dune-project | 11 +++++------ pgx_async.opam | 2 +- pgx_lwt_unix.opam | 1 - 3 files changed, 6 insertions(+), 8 deletions(-) diff --git a/dune-project b/dune-project index c5fda85..5b18faf 100644 --- a/dune-project +++ b/dune-project @@ -21,7 +21,7 @@ (name pgx) (synopsis "Pure-OCaml PostgreSQL client library") (description - "PGX is a pure-OCaml PostgreSQL client library, supporting Async, LWT, or synchronous operations.") + "PGX is a pure-OCaml PostgreSQL client library, supporting Async, LWT, or synchronous operations.") (depends (alcotest (and @@ -52,9 +52,9 @@ (package (name pgx_unix) (synopsis - "PGX using the standard library's Unix module for IO (synchronous)") + "PGX using the standard library's Unix module for IO (synchronous)") (description - "PGX using the standard library's Unix module for IO (synchronous)") + "PGX using the standard library's Unix module for IO (synchronous)") (depends (alcotest (and @@ -82,6 +82,7 @@ (>= "v0.13.0")) (async_unix (>= "v0.13.0")) + async_ssl (base64 (and :with-test @@ -92,9 +93,7 @@ (pgx (= :version)) (pgx_value_core - (= :version))) - (depopts - async_ssl)) + (= :version)))) (package (name pgx_lwt) diff --git a/pgx_async.opam b/pgx_async.opam index 3c7e88d..b6a7eff 100644 --- a/pgx_async.opam +++ b/pgx_async.opam @@ -13,13 +13,13 @@ depends: [ "alcotest-async" {with-test & >= "1.0.0"} "async_kernel" {>= "v0.13.0"} "async_unix" {>= "v0.13.0"} + "async_ssl" "base64" {with-test & >= "3.0.0"} "conduit-async" "ocaml" {>= "4.08"} "pgx" {= version} "pgx_value_core" {= version} ] -depopts: ["async_ssl"] build: [ ["dune" "subst"] {pinned} [ diff --git a/pgx_lwt_unix.opam b/pgx_lwt_unix.opam index 9a8e7e0..3163469 100644 --- a/pgx_lwt_unix.opam +++ b/pgx_lwt_unix.opam @@ -12,7 +12,6 @@ depends: [ "dune" {>= "1.11"} "alcotest-lwt" {with-test & >= "1.0.0"} "base64" {with-test & >= "3.0.0"} - "lwt" "ocaml" {>= "4.08"} "pgx" {= version} "pgx_lwt" {= version}