From a1aaaf9a557657e58dfa5b82692079422065a242 Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:36:44 +0100 Subject: [PATCH 01/11] Remove dead code --- pgx/test/test_pgx_value.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/pgx/test/test_pgx_value.ml b/pgx/test/test_pgx_value.ml index a3b0900..a648f92 100644 --- a/pgx/test/test_pgx_value.ml +++ b/pgx/test/test_pgx_value.ml @@ -7,7 +7,6 @@ let pp_value ppf x = Sexp.pp_hum ppf (sexp_of_t x) let equal_value (x : t) (y : t) = x = y let pp_hstore ppf x = Sexp.pp_hum ppf (sexp_of_hstore x) let equal_hstore x y = Sexp.equal (sexp_of_hstore x) (sexp_of_hstore y) -let printer sexp value = sexp value |> Sexp.to_string_hum let sort_hstore = List.sort (fun (k, _) (k', _) -> String.compare k k') let to_hstore_sorted v = to_hstore v |> Option.map sort_hstore let to_hstore_sorted_exn v = to_hstore_exn v |> sort_hstore From 7eb5cf5c3034a9add39190427a9660efcb32909a Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:37:18 +0100 Subject: [PATCH 02/11] Upgrade to newer Uuidm versions --- pgx/test/test_pgx_value.ml | 6 ++++-- pgx_test/src/pgx_test.ml | 4 +++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/pgx/test/test_pgx_value.ml b/pgx/test/test_pgx_value.ml index a648f92..3e897df 100644 --- a/pgx/test/test_pgx_value.ml +++ b/pgx/test/test_pgx_value.ml @@ -3,6 +3,8 @@ open Sexplib0 open Sexplib0.Sexp_conv open Pgx.Value +let uuid_v4 = Uuidm.v4_gen (Random.State.make_self_init ()) + let pp_value ppf x = Sexp.pp_hum ppf (sexp_of_t x) let equal_value (x : t) (y : t) = x = y let pp_hstore ppf x = Sexp.pp_hum ppf (sexp_of_hstore x) @@ -168,7 +170,7 @@ let () = ; null ; of_point (-5., 100.) ; unit - ; of_uuid (Uuidm.create `V4) + ; of_uuid (uuid_v4 ()) ; of_string all_chars ] ] @@ -196,7 +198,7 @@ let () = of_uuid to_uuid to_uuid_exn - [ Uuidm.create `V4 ] + [ uuid_v4 () ] [ ""; "asd" ] ] ;; diff --git a/pgx_test/src/pgx_test.ml b/pgx_test/src/pgx_test.ml index 96337ce..7f076bd 100644 --- a/pgx_test/src/pgx_test.ml +++ b/pgx_test/src/pgx_test.ml @@ -1,5 +1,7 @@ external reraise : exn -> _ = "%reraise" +let uuid_v4 = Uuidm.v4_gen (Random.State.make_self_init ()) + module type S = sig val run_tests : library_name:string -> unit end @@ -394,7 +396,7 @@ struct "CREATE TABLE multi_typed(uuid uuid, int int, string text, numeric \ numeric);" >>= fun _ -> - let expect_uuid = Uuidm.create `V4 in + let expect_uuid = uuid_v4 () in let params = let open Pgx.Value in [ of_uuid expect_uuid From 75deebd00e31cd3eff49c95f140980c057299b09 Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:41:41 +0100 Subject: [PATCH 03/11] Upgrade to newer OCaml versions where Caml has been renamed to Stdlib --- pgx_async/src/pgx_async.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pgx_async/src/pgx_async.ml b/pgx_async/src/pgx_async.ml index 0e3ac26..c50b1b7 100644 --- a/pgx_async/src/pgx_async.ml +++ b/pgx_async/src/pgx_async.ml @@ -34,7 +34,7 @@ module Thread = struct let output_string w s = return (Writer.write w s) let output_binary_int w n = - let chr = Caml.Char.chr in + let chr = Stdlib.Char.chr in Writer.write_char w (chr (n lsr 24)); Writer.write_char w (chr ((n lsr 16) land 255)); Writer.write_char w (chr ((n lsr 8) land 255)); @@ -56,7 +56,7 @@ module Thread = struct >>| function | `Eof _ -> raise Pgx_eof | `Ok -> - let code = Caml.Char.code in + let code = Stdlib.Char.code in (code (Bytes.get b 0) lsl 24) lor (code (Bytes.get b 1) lsl 16) lor (code (Bytes.get b 2) lsl 8) From 783989b6ee722abf315d3defcec84d1cc7bba5b9 Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:42:36 +0100 Subject: [PATCH 04/11] Upgrade to newer Core versions --- pgx_async/bin/pgx_async_example.ml | 2 +- pgx_async/src/pgx_async.ml | 2 +- pgx_async/src/pgx_async_test.ml | 2 +- pgx_value_core/src/pgx_value_core.ml | 8 ++++---- pgx_value_core/src/pgx_value_core.mli | 10 +++++----- pgx_value_core/test/test_pgx_value_core.ml | 12 ++++++------ 6 files changed, 18 insertions(+), 18 deletions(-) diff --git a/pgx_async/bin/pgx_async_example.ml b/pgx_async/bin/pgx_async_example.ml index 5e06a4e..a5c6f43 100644 --- a/pgx_async/bin/pgx_async_example.ml +++ b/pgx_async/bin/pgx_async_example.ml @@ -1,5 +1,5 @@ (* A basic example of Pgx_async usage *) -open Core_kernel +open Core open Async_kernel open Async_unix diff --git a/pgx_async/src/pgx_async.ml b/pgx_async/src/pgx_async.ml index c50b1b7..a9082cd 100644 --- a/pgx_async/src/pgx_async.ml +++ b/pgx_async/src/pgx_async.ml @@ -1,4 +1,4 @@ -open Core_kernel +open Core open Async_kernel open Async_unix diff --git a/pgx_async/src/pgx_async_test.ml b/pgx_async/src/pgx_async_test.ml index 24d505d..a34a17c 100644 --- a/pgx_async/src/pgx_async_test.ml +++ b/pgx_async/src/pgx_async_test.ml @@ -1,4 +1,4 @@ -open Core_kernel +open Core open Async_kernel open Async_unix module Pga = Pgx_async diff --git a/pgx_value_core/src/pgx_value_core.ml b/pgx_value_core/src/pgx_value_core.ml index 82595c9..2850247 100644 --- a/pgx_value_core/src/pgx_value_core.ml +++ b/pgx_value_core/src/pgx_value_core.ml @@ -1,4 +1,4 @@ -open Core_kernel +open Core include Pgx.Value let of_time t = @@ -18,7 +18,7 @@ let of_time t = 2016-06-07 15:37:46Z (utc timezone) -> 2016-06-07 11:37:46-04 2016-06-07 15:37:46-04 (local timezone) -> 2016-06-07 15:37:46-04 *) - Time.to_string_abs ~zone:Time.Zone.utc t |> Pgx.Value.of_string + Time_float.to_string_abs ~zone:Time_float.Zone.utc t |> Pgx.Value.of_string ;; let to_time' = @@ -36,7 +36,7 @@ let to_time' = For the first one we need to indicate that it's a UTC time by appending a 'Z'. For the second one we need to append the minutes to the timezone. - Without these formattings Time.of_string fails spectacularly + Without these formattings Time_float.of_string fails spectacularly *) let open Re in let tz = seq [ alt [ char '-'; char '+' ]; digit; digit ] in @@ -44,7 +44,7 @@ let to_time' = let localtz_no_min = seq [ tz; eol ] |> compile in let localtz = seq [ tz; char ':'; digit; digit; eol ] |> compile in fun s -> - Time.of_string + Time_float.of_string_with_utc_offset @@ match matches utctz s, matches localtz s, matches localtz_no_min s with | [], [], [] -> s ^ "Z" diff --git a/pgx_value_core/src/pgx_value_core.mli b/pgx_value_core/src/pgx_value_core.mli index cbff542..8762f68 100644 --- a/pgx_value_core/src/pgx_value_core.mli +++ b/pgx_value_core/src/pgx_value_core.mli @@ -1,5 +1,5 @@ -(** Pgx_value types using Core_kernel's Date and Time modules *) -open Core_kernel +(** Pgx_value types using Core's Date and Time_float modules *) +open Core type v = Pgx.Value.v [@@deriving compare, sexp_of] type t = Pgx.Value.t [@@deriving compare, sexp_of] @@ -9,6 +9,6 @@ include module type of Pgx.Value with type v := v and type t := t val of_date : Date.t -> t val to_date_exn : t -> Date.t val to_date : t -> Date.t option -val of_time : Time.t -> t -val to_time_exn : t -> Time.t -val to_time : t -> Time.t option +val of_time : Time_float.t -> t +val to_time_exn : t -> Time_float.t +val to_time : t -> Time_float.t option diff --git a/pgx_value_core/test/test_pgx_value_core.ml b/pgx_value_core/test/test_pgx_value_core.ml index 0380eb5..16f5169 100644 --- a/pgx_value_core/test/test_pgx_value_core.ml +++ b/pgx_value_core/test/test_pgx_value_core.ml @@ -1,18 +1,18 @@ -open Core_kernel +open Core module Value = Pgx_value_core let time_roundtrip str = Value.of_string str |> Value.to_time_exn -let printer = Time.to_string_abs ~zone:Time.Zone.utc +let printer = Time_float.to_string_abs ~zone:Time_float.Zone.utc let time_testable = - Alcotest.testable (fun ppf t -> Format.pp_print_string ppf (printer t)) Time.equal + Alcotest.testable (fun ppf t -> Format.pp_print_string ppf (printer t)) Time_float.equal ;; let check_time = Alcotest.check time_testable let check_string = Alcotest.(check string) let test_time_of_string _ = - let expected = Time.of_string "2016-03-15 19:55:18.123456-04:00" in + let expected = Time_float.of_string_with_utc_offset "2016-03-15 19:55:18.123456-04:00" in check_time "without TZ" expected (time_roundtrip "2016-03-15 23:55:18.123456"); check_time "zulu" expected (time_roundtrip "2016-03-15 23:55:18.123456Z"); check_time "hour TZ" expected (time_roundtrip "2016-03-15 19:55:18.123456-04"); @@ -20,7 +20,7 @@ let test_time_of_string _ = ;; let test_time_of_string_no_ms _ = - let expected = Time.of_string "2016-03-15 19:55:18-04:00" in + let expected = Time_float.of_string_with_utc_offset "2016-03-15 19:55:18-04:00" in check_time "without TZ" expected (time_roundtrip "2016-03-15 23:55:18"); check_time "zulu" expected (time_roundtrip "2016-03-15 23:55:18Z"); check_time "hour TZ" expected (time_roundtrip "2016-03-15 19:55:18-04"); @@ -30,7 +30,7 @@ let test_time_of_string_no_ms _ = let test_time_conversion_roundtrip _ = let expected_str = "2016-03-15 23:55:18.123456Z" in check_string "parse-print" expected_str (time_roundtrip expected_str |> printer); - let expected_time = Time.of_string expected_str in + let expected_time = Time_float.of_string_with_utc_offset expected_str in check_time "print-parse" expected_time (Value.of_time expected_time |> Value.to_time_exn) ;; From ff700e2a4b17afc946837c1b3430ea37a13e8782 Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:35:53 +0100 Subject: [PATCH 05/11] Upgrade to newer Async versions --- dune-project | 6 ++++-- pgx_async.opam | 5 +++-- pgx_async/src/dune | 2 +- pgx_async/src/pgx_async.ml | 4 ++-- 4 files changed, 10 insertions(+), 7 deletions(-) diff --git a/dune-project b/dune-project index 479cd2b..035c409 100644 --- a/dune-project +++ b/dune-project @@ -78,10 +78,12 @@ (and :with-test (>= "1.0.0"))) + (async_log + (>= "v0.17.0")) (async_kernel - (>= "v0.13.0")) + (>= "v0.17.0")) (async_unix - (>= "v0.13.0")) + (>= "v0.17.0")) async_ssl (base64 (and diff --git a/pgx_async.opam b/pgx_async.opam index faede9c..79a90a9 100644 --- a/pgx_async.opam +++ b/pgx_async.opam @@ -11,8 +11,9 @@ bug-reports: "https://github.com/arenadotio/pgx/issues" depends: [ "dune" {>= "3.2"} "alcotest-async" {with-test & >= "1.0.0"} - "async_kernel" {>= "v0.13.0"} - "async_unix" {>= "v0.13.0"} + "async_log" {>= "v0.17.0"} + "async_kernel" {>= "v0.17.0"} + "async_unix" {>= "v0.17.0"} "async_ssl" "base64" {with-test & >= "3.0.0"} "conduit-async" {>= "1.5.0"} diff --git a/pgx_async/src/dune b/pgx_async/src/dune index e361930..d344ce8 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 conduit-async pgx_value_core) + (libraries async_kernel async_log 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 a9082cd..0179a6f 100644 --- a/pgx_async/src/pgx_async.ml +++ b/pgx_async/src/pgx_async.ml @@ -98,8 +98,8 @@ module Thread = struct let getlogin () = Unix.getuid () |> Unix.Passwd.getbyuid_exn >>| fun { name; _ } -> name let debug msg = - Log.Global.debug ~tags:[ "lib", "pgx_async" ] "%s" msg; - Log.Global.flushed () + Async_log.Global.debug ~tags:[ "lib", "pgx_async" ] "%s" msg; + Async_log.Global.flushed () ;; let protect f ~finally = Monitor.protect f ~finally From 96b361d3230104e1559f06ceb126c9cfd8d17522 Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:43:49 +0100 Subject: [PATCH 06/11] Upgrade to newer Mirage RNG versions --- pgx_lwt_mirage/src/pgx_lwt_mirage.ml | 2 +- pgx_lwt_mirage/src/pgx_lwt_mirage.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/pgx_lwt_mirage/src/pgx_lwt_mirage.ml b/pgx_lwt_mirage/src/pgx_lwt_mirage.ml index 3796948..66fc2ee 100644 --- a/pgx_lwt_mirage/src/pgx_lwt_mirage.ml +++ b/pgx_lwt_mirage/src/pgx_lwt_mirage.ml @@ -24,7 +24,7 @@ let ( let* ) = Lwt.bind let ( let+ ) t f = Lwt.map f t module Make - (RANDOM : Mirage_random.S) + (RANDOM : Mirage_crypto_rng_mirage.S) (TIME : Mirage_time.S) (MCLOCK : Mirage_clock.MCLOCK) (PCLOCK : Mirage_clock.PCLOCK) diff --git a/pgx_lwt_mirage/src/pgx_lwt_mirage.mli b/pgx_lwt_mirage/src/pgx_lwt_mirage.mli index 62bfd24..942679a 100644 --- a/pgx_lwt_mirage/src/pgx_lwt_mirage.mli +++ b/pgx_lwt_mirage/src/pgx_lwt_mirage.mli @@ -18,7 +18,7 @@ *) module Make - (RANDOM : Mirage_random.S) + (RANDOM : Mirage_crypto_rng_mirage.S) (TIME : Mirage_time.S) (MCLOCK : Mirage_clock.MCLOCK) (PCLOCK : Mirage_clock.PCLOCK) From 410d4076407522c45627ad7697539c86b08ad1f9 Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:44:05 +0100 Subject: [PATCH 07/11] Upgrade to newer Mirage versions --- pgx_lwt_mirage/src/pgx_lwt_mirage.ml | 11 +++++++---- pgx_lwt_mirage/src/pgx_lwt_mirage.mli | 6 ++++-- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/pgx_lwt_mirage/src/pgx_lwt_mirage.ml b/pgx_lwt_mirage/src/pgx_lwt_mirage.ml index 66fc2ee..9f0d772 100644 --- a/pgx_lwt_mirage/src/pgx_lwt_mirage.ml +++ b/pgx_lwt_mirage/src/pgx_lwt_mirage.ml @@ -28,7 +28,9 @@ module Make (TIME : Mirage_time.S) (MCLOCK : Mirage_clock.MCLOCK) (PCLOCK : Mirage_clock.PCLOCK) - (STACK : Tcpip.Stack.V4V6) = + (STACK : Tcpip.Stack.V4V6) + (H : Happy_eyeballs_mirage.S with type stack = STACK.t + and type flow = STACK.TCP.flow) = struct module Channel = Mirage_channel.Make (STACK.TCP) @@ -86,7 +88,7 @@ struct let getlogin () = Lwt.fail_with "Running under MirageOS. getlogin not available." end - module Dns = Dns_client_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK) + module Dns = Dns_client_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK) (H) type sockaddr = Thread.sockaddr = | Unix of string @@ -95,7 +97,8 @@ struct module TCP = Conduit_mirage.TCP (STACK) let connect_stack stack sockaddr = - let dns = Dns.create stack in + let tcp_stack, dns_stack = stack in + let dns = Dns.create (tcp_stack, dns_stack) in let* client = match sockaddr with | Unix _ -> Lwt.fail_with "Running under MirageOS. Unix sockets are not available." @@ -109,7 +112,7 @@ struct | Ok ipaddr -> Lwt.return (`TCP (Ipaddr.V4 ipaddr, port)) | Error (`Msg msg) -> Lwt.fail_with msg)) in - let+ flow = TCP.connect stack client in + let+ flow = TCP.connect tcp_stack client in let ch = Channel.create flow in ch, ch ;; diff --git a/pgx_lwt_mirage/src/pgx_lwt_mirage.mli b/pgx_lwt_mirage/src/pgx_lwt_mirage.mli index 942679a..429aa2d 100644 --- a/pgx_lwt_mirage/src/pgx_lwt_mirage.mli +++ b/pgx_lwt_mirage/src/pgx_lwt_mirage.mli @@ -22,6 +22,8 @@ module Make (TIME : Mirage_time.S) (MCLOCK : Mirage_clock.MCLOCK) (PCLOCK : Mirage_clock.PCLOCK) - (STACK : Tcpip.Stack.V4V6) : sig - val connect : STACK.t -> (module Pgx_lwt.S) + (STACK : Tcpip.Stack.V4V6) + (H : Happy_eyeballs_mirage.S with type stack = STACK.t + and type flow = STACK.TCP.flow) : sig + val connect : STACK.t * H.t -> (module Pgx_lwt.S) end From c840d6a8069647d03a4f799facd7a641c69b82af Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:52:55 +0100 Subject: [PATCH 08/11] Fix warning about missing explicit inclusion of the unix libraray --- pgx_unix/src/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pgx_unix/src/dune b/pgx_unix/src/dune index 1672d25..e75c6c2 100644 --- a/pgx_unix/src/dune +++ b/pgx_unix/src/dune @@ -10,6 +10,6 @@ let () = Jbuild_plugin.V1.send @@ {| (library (public_name pgx_unix) - (libraries pgx) + (libraries pgx unix) |} ^ preprocess ^ {|) |} From 7412f1911486927b9d60fb4cbb431e41a11f1f8e Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Wed, 5 Feb 2025 07:54:04 +0100 Subject: [PATCH 09/11] Add pgx_eio for Eio support --- dune-project | 11 ++ pgx_eio.opam | 32 ++++ pgx_eio/src/dune | 15 ++ pgx_eio/src/pgx_eio.ml | 273 +++++++++++++++++++++++++++++++++++ pgx_eio/src/pgx_eio.mli | 53 +++++++ pgx_eio/test/dune | 4 + pgx_eio/test/test_pgx_eio.ml | 12 ++ 7 files changed, 400 insertions(+) create mode 100644 pgx_eio.opam create mode 100644 pgx_eio/src/dune create mode 100644 pgx_eio/src/pgx_eio.ml create mode 100644 pgx_eio/src/pgx_eio.mli create mode 100644 pgx_eio/test/dune create mode 100644 pgx_eio/test/test_pgx_eio.ml diff --git a/dune-project b/dune-project index 035c409..f32c878 100644 --- a/dune-project +++ b/dune-project @@ -98,6 +98,17 @@ (pgx_value_core (= :version)))) +(package + (name pgx_eio) + (synopsis "Pgx using Eio for IO") + (description "Pgx using Eio for IO") + (depends + eio + (ocaml + (>= 5.00)) + (pgx + (= :version)))) + (package (name pgx_lwt) (synopsis "Pgx using Lwt for IO") diff --git a/pgx_eio.opam b/pgx_eio.opam new file mode 100644 index 0000000..1c92738 --- /dev/null +++ b/pgx_eio.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Pgx using Eio for IO" +description: "Pgx using Eio for IO" +maintainer: ["Arena Developers "] +authors: ["Arena Developers "] +license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" +homepage: "https://github.com/arenadotio/pgx" +doc: "https://arenadotio.github.io/pgx" +bug-reports: "https://github.com/arenadotio/pgx/issues" +depends: [ + "dune" {>= "3.2"} + "eio" + "ocaml" {>= "5.00"} + "pgx" {= version} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/arenadotio/pgx.git" diff --git a/pgx_eio/src/dune b/pgx_eio/src/dune new file mode 100644 index 0000000..08581d7 --- /dev/null +++ b/pgx_eio/src/dune @@ -0,0 +1,15 @@ +(* -*- tuareg -*- *) + +let preprocess = + match Sys.getenv "BISECT_ENABLE" with + | "yes" -> "(preprocess (pps bisect_ppx))" + | _ -> "" + | exception Not_found -> "" + +let () = Jbuild_plugin.V1.send @@ {| + +(library + (public_name pgx_eio) + (libraries eio eio_main pgx unix) + |} ^ preprocess ^ {|) +|} diff --git a/pgx_eio/src/pgx_eio.ml b/pgx_eio/src/pgx_eio.ml new file mode 100644 index 0000000..fac619c --- /dev/null +++ b/pgx_eio/src/pgx_eio.ml @@ -0,0 +1,273 @@ +(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. + * + * PG'OCaml - type safe interface to PostgreSQL. + * Copyright (C) 2005-2009 Richard Jones and other authors. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Library General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this library; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + * Boston, MA 02111-1307, USA. + *) + +module type S = Pgx.S with type 'a Io.t = 'a + +external reraise : exn -> _ = "%reraise" + +module Io = struct + type 'a t = 'a + type ssl_config + let return x = x + let (>>=) v f = f v + let catch f fexn = + try f () with + | e -> fexn e + let protect f ~(finally : unit -> unit) = + let result = ref None in + try + result := Some (f ()); + raise Exit + with + | Exit as e -> + finally (); + (match !result with + | Some x -> x + | None -> reraise e) + | e -> + finally (); + reraise e +end + +let make ~net ~sw = + let module Thread = struct + include Io + type sockaddr = + | Unix of string + | Inet of string * int + type close_flow = unit -> unit + type in_channel = Eio.Buf_read.t * close_flow + type out_channel = Eio.Buf_write.t + let random_list_element lst = + List.nth lst (Random.int (List.length lst)) + let open_connection sockaddr = + let addr : Eio.Net.Sockaddr.stream = + match sockaddr with + | Unix path -> `Unix path + | Inet (hostname, port) -> + let service = string_of_int port in + let addrs = Eio.Net.getaddrinfo_stream net hostname ~service in + random_list_element addrs + in + let flow = Eio.Net.connect ~sw net addr in + let r = Eio.Buf_read.of_flow ~max_size:(1 * 1024 * 1024) flow in + let close_flow_triggered, resolve_close_flow_triggered = Eio.Promise.create () in + let w, resolve_w = Eio.Promise.create () in + Eio.Fiber.fork ~sw begin fun () -> + Eio.Buf_write.with_flow ~initial_size:(4 * 1024) flow begin fun w -> + Eio.Promise.resolve resolve_w w; + Eio.Promise.await close_flow_triggered + end; + Eio.Net.close flow + end; + let w = Eio.Promise.await w in + let close_flow () = + Eio.Promise.resolve resolve_close_flow_triggered () + in + (r, close_flow), w + let upgrade_ssl = `Not_supported + let output_char w c = + Eio.Buf_write.char w c + let output_binary_int w n = + Eio.Buf_write.BE.uint32 w (Int32.of_int n) + let output_string w s = + Eio.Buf_write.string w s + let flush w = + Eio.Buf_write.flush w + let input_char (r, _) = + Eio.Buf_read.any_char r + let input_binary_int (r, _) = + Eio.Buf_read.BE.uint32 r |> Int32.to_int + let really_input (r, _) buf pos len = + let s = Eio.Buf_read.take len r in + Bytes.blit_string s 0 buf pos len + let close_in (_r, close_flow) = + close_flow () + let getlogin () = + Eio_unix.run_in_systhread @@ fun () -> + (* The unix getlogin syscall can fail *) + let uid = Unix.getuid () in + let pwuid = Unix.getpwuid uid in + pwuid.pw_name + let debug = prerr_endline + module Sequencer = struct + type 'a monad = 'a t + type 'a t = 'a * Eio.Mutex.t + let create t = + t, Eio.Mutex.create () + let enqueue (t, mutex) f = + Eio.Mutex.use_rw ~protect:true mutex (fun () -> f t) + end + end in + let module M = Pgx.Make (Thread) in + (module M : S) + +module type S_with_t = sig + module Impl : S + val t : Impl.t +end + +module type S_with_Prepared_s = sig + module Impl : S + val s : Impl.Prepared.s +end + +type t = (module S_with_t) + +let connect + ~net + ~sw + (* ?(ssl:[ `Always of ssl_config | `Auto | `No ] option) *) + ?host + ?port + ?user + ?password + ?database + ?unix_domain_socket_dir + ?verbose + ?max_message_length + () + = + let (module Impl) = make ~net ~sw in + let t = Impl.connect ?ssl:None ?host ?port ?user ?password ?database ?unix_domain_socket_dir ?verbose ?max_message_length () in + let module M = struct + module Impl = Impl + let t = t + end in + ((module M) : t) + +let with_conn + ~net + (* ?(ssl:[ `Always of ssl_config | `Auto | `No ] option) *) + ?host + ?port + ?user + ?password + ?database + ?unix_domain_socket_dir + ?verbose + ?max_message_length + f + = + Eio.Switch.run begin fun sw -> + let (module Impl) = make ~net ~sw in + Impl.with_conn ?ssl:None ?host ?port ?user ?password ?database ?unix_domain_socket_dir ?verbose ?max_message_length begin fun t -> + let module M = struct + module Impl = Impl + let t = t + end in + f ((module M) : t) + end + end + +let close ((module M) : t) = + M.Impl.close M.t + +let ping ((module M) : t) = + M.Impl.ping M.t + +let alive ((module M) : t) = + M.Impl.alive M.t + +let begin_work ?isolation ?access ?deferrable ((module M) : t) = + let t = M.Impl.begin_work ?isolation ?access ?deferrable M.t in + let module M = struct + module Impl = M.Impl + let t = t + end in + ((module M) : t) + +let commit ((module M) : t) = + M.Impl.commit M.t + +let rollback ((module M) : t) = + M.Impl.rollback M.t + +let with_transaction ?isolation ?access ?deferrable ((module M) : t) f = + M.Impl.with_transaction ?isolation ?access ?deferrable M.t begin fun t -> + let module M = struct + module Impl = M.Impl + let t = t + end in + f ((module M) : t) + end + +module Prepared = struct + type s = (module S_with_Prepared_s) + let sexp_of_s ((module M) : s) = + M.Impl.Prepared.sexp_of_s M.s + let prepare ?name ?types ((module M) : t) ~query = + let s = M.Impl.Prepared.prepare ?name ?types M.t ~query in + let module M = struct + module Impl = M.Impl + let s = s + end in + ((module M) : s) + let close ((module M) : s) = + M.Impl.Prepared.close M.s + let with_prepare ?name ?types ((module M) : t) ~query ~f = + M.Impl.Prepared.with_prepare ?name ?types M.t ~query ~f:begin fun s -> + let module M = struct + module Impl = M.Impl + let s = s + end in + f ((module M) : s) + end + let execute ?portal ((module M) : s) = + M.Impl.Prepared.execute ?portal M.s + let execute_unit ?portal ((module M) : s) ~params = + M.Impl.Prepared.execute_unit ?portal M.s ~params + let execute_fold ?portal ((module M) : s) ~params ~init ~f = + M.Impl.Prepared.execute_fold ?portal M.s ~params ~init ~f + let execute_iter ?portal ((module M) : s) ~params ~f = + M.Impl.Prepared.execute_iter ?portal M.s ~params ~f + let execute_map ?portal ((module M) : s) ~params ~f = + M.Impl.Prepared.execute_map ?portal M.s ~params ~f + let execute_many ((module M) : s) ~params = + M.Impl.Prepared.execute_many M.s ~params + let describe ((module M) : s) = + M.Impl.Prepared.describe M.s + let close_portal ?portal ((module M) : s) = + M.Impl.Prepared.close_portal ?portal M.s + let describe_portal ?portal ((module M) : s) = + M.Impl.Prepared.describe_portal ?portal M.s +end + +let execute ?params ((module M) : t) query = + M.Impl.execute ?params M.t query + +let execute_unit ?params ((module M) : t) query = + M.Impl.execute_unit ?params M.t query + +let execute_fold ?params ((module M) : t) query ~init ~f = + M.Impl.execute_fold ?params M.t query ~init ~f + +let execute_map ?params ((module M) : t) query ~f = + M.Impl.execute_map ?params M.t query ~f + +let execute_iter ?params ((module M) : t) query ~f = + M.Impl.execute_iter ?params M.t query ~f + +let execute_many ((module M) : t) ~query ~params = + M.Impl.execute_many M.t ~query ~params + +let simple_query ((module M) : t) query = + M.Impl.simple_query M.t query diff --git a/pgx_eio/src/pgx_eio.mli b/pgx_eio/src/pgx_eio.mli new file mode 100644 index 0000000..9fb479d --- /dev/null +++ b/pgx_eio/src/pgx_eio.mli @@ -0,0 +1,53 @@ +(* PG'OCaml is a set of OCaml bindings for the PostgreSQL database. + * + * PG'OCaml - type safe interface to PostgreSQL. + * Copyright (C) 2005-2009 Richard Jones and other authors. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library General Public + * License as published by the Free Software Foundation; either + * version 2 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Library General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this library; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + * Boston, MA 02111-1307, USA. + *) + +module type S = Pgx.S with type 'a Io.t = 'a + +val make : net:_ Eio.Net.t -> sw:Eio.Switch.t -> (module S) + +include S + +val connect : + net:[> [> `Generic ] Eio.Net.ty ] Eio.Resource.t -> + sw:Eio.Switch.t -> + ?host:string -> + ?port:int -> + ?user:string -> + ?password:string -> + ?database:string -> + ?unix_domain_socket_dir:string -> + ?verbose:int -> + ?max_message_length:int -> + unit -> + t + +val with_conn : + net:[> [> `Generic ] Eio.Net.ty ] Eio.Resource.t -> + ?host:string -> + ?port:int -> + ?user:string -> + ?password:string -> + ?database:string -> + ?unix_domain_socket_dir:string -> + ?verbose:int -> + ?max_message_length:int -> + (t -> 'a) -> + 'a diff --git a/pgx_eio/test/dune b/pgx_eio/test/dune new file mode 100644 index 0000000..6e2baca --- /dev/null +++ b/pgx_eio/test/dune @@ -0,0 +1,4 @@ +(test + (name test_pgx_eio) + (package pgx_eio) + (libraries eio_main pgx_test pgx_eio)) diff --git a/pgx_eio/test/test_pgx_eio.ml b/pgx_eio/test/test_pgx_eio.ml new file mode 100644 index 0000000..81d6980 --- /dev/null +++ b/pgx_eio/test/test_pgx_eio.ml @@ -0,0 +1,12 @@ +let () = + Eio_main.run @@ fun env -> + Eio.Switch.run @@ fun sw -> + let net = env#net in + let (module Pgx_eio_impl) = Pgx_eio.make ~net ~sw in + let module Alcotest_io = struct + type 'a test_case = 'a Alcotest.test_case + let test_case name speed f = Alcotest.test_case name speed f + let run name tests = Alcotest.run name tests + end in + let module Pgx_test_eio = Pgx_test.Make_tests (Pgx_eio_impl) (Alcotest_io) in + Pgx_test_eio.run_tests ~library_name:"pgx_eio" From 9b7fc421a51ad503c505ab59b5c567f6b1f42832 Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Sun, 9 Feb 2025 02:31:59 +0100 Subject: [PATCH 10/11] Fix warning on pgx_eio startup and clarify the non-support of SSL --- pgx_eio/src/pgx_eio.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pgx_eio/src/pgx_eio.ml b/pgx_eio/src/pgx_eio.ml index fac619c..8ae5141 100644 --- a/pgx_eio/src/pgx_eio.ml +++ b/pgx_eio/src/pgx_eio.ml @@ -147,7 +147,7 @@ let connect () = let (module Impl) = make ~net ~sw in - let t = Impl.connect ?ssl:None ?host ?port ?user ?password ?database ?unix_domain_socket_dir ?verbose ?max_message_length () in + let t = Impl.connect ~ssl:`No ?host ?port ?user ?password ?database ?unix_domain_socket_dir ?verbose ?max_message_length () in let module M = struct module Impl = Impl let t = t @@ -169,7 +169,7 @@ let with_conn = Eio.Switch.run begin fun sw -> let (module Impl) = make ~net ~sw in - Impl.with_conn ?ssl:None ?host ?port ?user ?password ?database ?unix_domain_socket_dir ?verbose ?max_message_length begin fun t -> + Impl.with_conn ~ssl:`No ?host ?port ?user ?password ?database ?unix_domain_socket_dir ?verbose ?max_message_length begin fun t -> let module M = struct module Impl = Impl let t = t From 873b92243e5c5d1ba8b5aaa4a2c2a9a1642589e8 Mon Sep 17 00:00:00 2001 From: Volker Diels-Grabsch Date: Sun, 9 Feb 2025 02:48:34 +0100 Subject: [PATCH 11/11] Reduce dependencies of pgx_eio --- pgx_eio/src/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pgx_eio/src/dune b/pgx_eio/src/dune index 08581d7..f4f4406 100644 --- a/pgx_eio/src/dune +++ b/pgx_eio/src/dune @@ -10,6 +10,6 @@ let () = Jbuild_plugin.V1.send @@ {| (library (public_name pgx_eio) - (libraries eio eio_main pgx unix) + (libraries eio eio.unix pgx unix) |} ^ preprocess ^ {|) |}