unikernel/duniverse/pgx/pgx_async/bin/dune

@@ -0,0 +1,7 @@
+(executables
+ (names pgx_async_example)
+ (libraries pgx_async))
+
+(alias
+ (name examples)
+ (deps pgx_async_example.exe))

unikernel/duniverse/pgx/pgx_async/bin/pgx_async_example.ml

@@ -0,0 +1,141 @@
+(* A basic example of Pgx_async usage *)
+open Core_kernel
+open Async_kernel
+open Async_unix
+
+module Employee = struct
+  let create db =
+    Pgx_async.simple_query
+      db
+      {|
+      CREATE TEMPORARY TABLE Employee (
+        id SERIAL PRIMARY KEY,
+        name VARCHAR(100) NOT NULL UNIQUE);
+    |}
+    |> Deferred.ignore_m
+  ;;
+
+  (* This function lets us insert multiple users relatively efficiently *)
+  let insert_many db names =
+    let params = List.map names ~f:(fun name -> Pgx_async.Value.[ of_string name ]) in
+    Pgx_async.execute_many
+      db
+      ~params
+      ~query:
+        {|
+      INSERT INTO Employee (name)
+      VALUES ($1)
+      RETURNING id
+    |}
+    >>| List.map ~f:(function
+            | [ [ id ] ] -> Pgx.Value.to_int_exn id
+            | _ -> assert false)
+  ;;
+
+  let insert ~name db = insert_many db [ name ] >>| List.hd_exn
+end
+
+module Facility = struct
+  let create db =
+    Pgx_async.simple_query
+      db
+      {|
+      CREATE TEMPORARY TABLE Facility (
+        id SERIAL PRIMARY KEY,
+        name VARCHAR(100) NOT NULL UNIQUE,
+        director_id INT REFERENCES Employee(id) ON DELETE SET NULL);
+
+      CREATE INDEX facility_director_id ON Facility (director_id);
+    |}
+    |> Deferred.ignore_m
+  ;;
+
+  let insert ~name ?director_id db =
+    let params = Pgx_async.Value.[ of_string name; opt of_int director_id ] in
+    Pgx_async.execute
+      db
+      ~params
+      {|
+      INSERT INTO Facility (name, director_id)
+      VALUES ($1, $2)
+      RETURNING id
+    |}
+    >>| function
+    | [ [ id ] ] -> Pgx.Value.to_int_exn id
+    | _ -> assert false
+  ;;
+
+  let all_name_and_director_name db =
+    Pgx_async.execute
+      db
+      {|
+      SELECT f.name, e.name
+      FROM Facility f
+      LEFT JOIN Employee e ON e.id = f.director_id
+    |}
+    >>| List.map ~f:(function
+            | [ name; director_name ] ->
+              Pgx.Value.(to_string_exn name, to_string director_name)
+            | _ -> assert false)
+  ;;
+
+  let reassign_director db ~director_id ~from_facility_id ~to_facility_id =
+    (* Note: with_transaction doesn't currently have any special handling
+       for concurrent queries *)
+    Pgx_async.with_transaction db
+    @@ fun db ->
+    let params = Pgx.Value.[ of_int director_id; of_int from_facility_id ] in
+    Pgx_async.execute
+      db
+      ~params
+      {|
+      UPDATE Facility SET director_id = NULL WHERE id = $2 AND director_id = $1
+    |}
+    >>= fun _ ->
+    let params = Pgx.Value.[ of_int director_id; of_int to_facility_id ] in
+    Pgx_async.execute
+      db
+      ~params
+      {|
+      UPDATE Facility SET director_id = $1 WHERE id = $2
+    |}
+    |> Deferred.ignore_m
+  ;;
+end
+
+let setup db = Employee.create db >>= fun () -> Facility.create db
+
+let main () =
+  Pgx_async.with_conn
+  @@ fun db ->
+  setup db
+  >>= fun () ->
+  Employee.insert ~name:"Steve" db
+  >>= fun steve_id ->
+  (* Parallel queries are not an error, but will execute in serial *)
+  [ Facility.insert ~name:"Headquarters" ~director_id:steve_id db
+  ; Facility.insert ~name:"New Office" db
+  ]
+  |> Deferred.all
+  >>= function
+  | [ headquarters_id; new_office_id ] ->
+    Facility.all_name_and_director_name db
+    >>| List.iter ~f:(fun (name, director_name) ->
+            let director_name = Option.value director_name ~default:"(none)" in
+            printf "The director of %s is %s\n" name director_name)
+    >>= fun () ->
+    print_endline "Re-assigning Steve to the New Office";
+    Facility.reassign_director
+      db
+      ~director_id:steve_id
+      ~from_facility_id:headquarters_id
+      ~to_facility_id:new_office_id
+    >>= fun () ->
+    Facility.all_name_and_director_name db
+    >>| List.iter ~f:(fun (name, director_name) ->
+            let director_name = Option.value director_name ~default:"(none)" in
+            printf "The director of %s is %s\n" name director_name)
+  | _ -> assert false
+;;
+
+let () = Thread_safe.block_on_async_exn main

unikernel/duniverse/pgx/pgx_async/src/dune

@@ -0,0 +1,16 @@
+(* -*- 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_async)
+ (wrapped false)
+ (libraries async_kernel async_unix conduit-async pgx_value_core)
+ |} ^ preprocess ^ {|)
+|}

unikernel/duniverse/pgx/pgx_async/src/pgx_async.ml

@@ -0,0 +1,200 @@
+open Core_kernel
+open Async_kernel
+open Async_unix
+
+(* Pgx allows to generate bindings from any module implementing their
+   THREAD signature which encompasses monadic concurrency + IO. The
+   implementation that we've chosen here is a deferred represents an
+   asynchronous value returned by pgx and Writer.t/Reader.t are the
+   channels it uses for communication *)
+
+exception Pgx_eof [@@deriving sexp]
+
+module Thread = struct
+  type 'a t = 'a Deferred.t
+
+  let return = return
+  let ( >>= ) = ( >>= )
+
+  let catch f on_exn =
+    try_with ~extract_exn:true f
+    >>= function
+    | Ok x -> return x
+    | Error exn -> on_exn exn
+  ;;
+
+  type sockaddr =
+    | Unix of string
+    | Inet of string * int
+
+  type in_channel = Reader.t
+  type out_channel = Writer.t
+
+  let output_char w char = return (Writer.write_char w char)
+  let output_string w s = return (Writer.write w s)
+
+  let output_binary_int w n =
+    let chr = Caml.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));
+    return @@ Writer.write_char w (chr (n land 255))
+  ;;
+
+  let flush = Writer.flushed
+
+  let input_char r =
+    Reader.read_char r
+    >>| function
+    | `Ok c -> c
+    | `Eof -> raise Pgx_eof
+  ;;
+
+  let input_binary_int r =
+    let b = Bytes.create 4 in
+    Reader.really_read r b
+    >>| function
+    | `Eof _ -> raise Pgx_eof
+    | `Ok ->
+      let code = Caml.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)
+      lor code (Bytes.get b 3)
+  ;;
+
+  let really_input r s pos len =
+    Reader.really_read r ~pos ~len s
+    >>| function
+    | `Ok -> ()
+    | `Eof _ -> raise Pgx_eof
+  ;;
+
+  let close_in = Reader.close
+
+  let open_connection sockaddr =
+    match sockaddr with
+    | Unix path -> Conduit_async.connect (`Unix_domain_socket path)
+    | Inet (host, port) ->
+      Uri.make ~host ~port ()
+      |> Conduit_async.V3.resolve_uri
+      >>= Conduit_async.V3.connect
+      >>| fun (_socket, in_channel, out_channel) -> in_channel, out_channel
+  ;;
+
+  type ssl_config = Conduit_async.Ssl.config
+
+  let upgrade_ssl =
+    try
+      let default_config = Conduit_async.V1.Conduit_async_ssl.Ssl_config.configure () in
+      `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
+    | _ -> `Not_supported
+  ;;
+
+  (* The unix getlogin syscall can fail *)
+  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 ()
+  ;;
+
+  let protect f ~finally = Monitor.protect f ~finally
+
+  module Sequencer = struct
+    type 'a monad = 'a t
+    type 'a t = 'a Sequencer.t
+
+    let create t = Sequencer.create ~continue_on_error:true t
+    let enqueue = Throttle.enqueue
+  end
+end
+
+include Pgx.Make (Thread)
+
+(* pgx uses configures this value at build time. But this breaks when
+   pgx is installed before postgres itself. We prefer to set this variable
+   at runtime and override the `connect` function from to respect it *)
+let default_unix_domain_socket_dir =
+  let debian_default = "/var/run/postgresql" in
+  Lazy_deferred.create (fun () ->
+      Sys.is_directory debian_default
+      >>| function
+      | `Yes -> debian_default
+      | `No | `Unknown -> "/tmp")
+;;
+
+(* Fail if PGDATABASE environment variable is not set. *)
+let check_pgdatabase =
+  lazy
+    (let db = "PGDATABASE" in
+     if Option.is_none (Sys.getenv db)
+     then failwithf "%s environment variable must be set." db ())
+;;
+
+let connect
+    ?ssl
+    ?host
+    ?port
+    ?user
+    ?password
+    ?database
+    ?unix_domain_socket_dir
+    ?verbose
+    ?max_message_length
+    ()
+  =
+  if Option.is_none database then Lazy.force check_pgdatabase;
+  (match unix_domain_socket_dir with
+  | Some p -> return p
+  | None -> Lazy_deferred.force_exn default_unix_domain_socket_dir)
+  >>= fun unix_domain_socket_dir ->
+  connect
+    ?ssl
+    ?host
+    ?port
+    ?user
+    ?password
+    ?database
+    ?verbose
+    ?max_message_length
+    ~unix_domain_socket_dir
+    ()
+;;
+
+let with_conn
+    ?ssl
+    ?host
+    ?port
+    ?user
+    ?password
+    ?database
+    ?unix_domain_socket_dir
+    ?verbose
+    ?max_message_length
+    f
+  =
+  connect
+    ?ssl
+    ?host
+    ?port
+    ?user
+    ?password
+    ?database
+    ?unix_domain_socket_dir
+    ?verbose
+    ?max_message_length
+    ()
+  >>= fun dbh -> Monitor.protect (fun () -> f dbh) ~finally:(fun () -> close dbh)
+;;
+
+let execute_pipe ?params db query =
+  Pipe.create_reader ~close_on_exception:false
+  @@ fun writer ->
+  execute_iter ?params db query ~f:(fun row -> Pipe.write_if_open writer row)
+;;
+
+module Value = Pgx_value_core

unikernel/duniverse/pgx/pgx_async/src/pgx_async.mli

@@ -0,0 +1,18 @@
+(** Async based Postgres client based on Pgx. *)
+open Async_kernel
+
+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
+
+(** 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. *)
+val execute_pipe : ?params:Pgx.row -> t -> string -> Pgx.row Pipe.Reader.t
+
+(** Exposed for backwards compatiblity. New code should use [Pgx_value_core] directly. *)
+module Value = Pgx_value_core

unikernel/duniverse/pgx/pgx_async/src/pgx_async_test.ml

@@ -0,0 +1,37 @@
+open Core_kernel
+open Async_kernel
+open Async_unix
+module Pga = Pgx_async
+
+let default_database = "postgres"
+let set_to_default_db () = Unix.putenv ~key:"PGDATABASE" ~data:default_database
+
+let random_db () =
+  let random_char () = 10 |> Random.int |> Int.to_string |> Char.of_string in
+  "pgx_test_" ^ String.init 8 ~f:(fun _ -> random_char ())
+;;
+
+let ignore_empty = function
+  | [] -> ()
+  | _ :: _ -> invalid_arg "ignore_empty"
+;;
+
+let drop_db dbh ~db_name = Pga.execute dbh ("DROP DATABASE " ^ db_name) >>| ignore_empty
+
+let create_db dbh ~db_name =
+  Pga.execute dbh ("CREATE DATABASE " ^ db_name) >>| ignore_empty
+;;
+
+let with_temp_db f =
+  let db_name = random_db () in
+  Pga.with_conn ~database:default_database (fun dbh ->
+      create_db dbh ~db_name
+      >>= fun () ->
+      Monitor.protect
+        (fun () -> Pga.with_conn ~database:db_name (fun test_dbh -> f test_dbh ~db_name))
+        ~finally:(fun () -> drop_db dbh ~db_name))
+;;
+
+type 'a new_db_callback = Pgx_async.t -> db_name:string -> 'a Deferred.t
+
+let () = Random.self_init ~allow_in_tests:true ()

unikernel/duniverse/pgx/pgx_async/src/pgx_async_test.mli

@@ -0,0 +1,12 @@
+(** Testing library for code that uses postgres *)
+
+open Async_kernel
+
+val set_to_default_db : unit -> unit
+
+type 'a new_db_callback = Pgx_async.t -> db_name:string -> 'a Deferred.t
+
+(** [with_temp_db f] creates a temporary database and executes [f] with a database
+    handle to this db and the name of the db. Once [f] executes or raises, the temp database
+    will be deleted. *)
+val with_temp_db : 'a new_db_callback -> 'a Deferred.t

unikernel/duniverse/pgx/pgx_async/test/dune

@@ -0,0 +1,4 @@
+(tests
+ (names test_pgx_async)
+ (package pgx_async)
+ (libraries alcotest alcotest-async pgx_async pgx_test))

unikernel/duniverse/pgx/pgx_async/test/test_pgx_async.ml

@@ -0,0 +1,13 @@
+module Alcotest_io = struct
+  type 'a test_case = 'a Alcotest_async.test_case
+
+  let test_case name speed f = Alcotest_async.test_case name speed f
+
+  let run name tests =
+    Async_unix.Thread_safe.block_on_async_exn @@ fun () -> Alcotest_async.run name tests
+  ;;
+end
+
+include Pgx_test.Make_tests (Pgx_async) (Alcotest_io)
+
+let () = run_tests ~library_name:"pgx_async"