Add support for returning results using Postgres' binary format

Author: pbiggar

examples/Makefile

@@ -1,4 +1,4 @@
-TARGETS = $(addsuffix .bc, async cursor dump populate prompt test_lo)
+TARGETS = $(addsuffix .bc, async binary cursor dump populate prompt test_lo)
 
 .PHONY: all clean
 

examples/binary.ml

@@ -0,0 +1,103 @@
+(* Create a table, insert a binary string various ways, and read it various ways *)
+
+open! Postgresql
+
+let _ =
+  if Array.length Sys.argv <> 3 then (
+    Printf.printf "\
+      Usage:  dump conninfo table\n\
+      Connect to PostgreSQL with [conninfo] (e.g. \"host=localhost\"),\n\
+      and create, write to, read from, and then DELETE [table]\n";
+    exit 1)
+
+let table = Sys.argv.(2)
+let c =
+  try new connection ~conninfo:Sys.argv.(1) () with
+  | Error e ->
+    prerr_endline (string_of_error e);
+    exit 34
+  | e ->
+    prerr_endline (Printexc.to_string e);
+    exit 35
+
+
+let create_table () : unit =
+  c#exec ~expect:[Command_ok]
+    ("create table " ^ table ^ " (data bytea)")
+  |> ignore
+
+let write_escaped data : unit =
+  c#exec ~expect:[Command_ok]
+    ("insert into " ^ table
+     ^ " (data)"
+     ^ " VALUES ('"
+     ^ c#escape_bytea data
+     ^ "')")
+  |> ignore
+
+let write_binary data : unit =
+  c#exec ~expect:[Command_ok]
+    ~params:[|data|] ~binary_params:[|true|]
+    ("insert into " ^ table
+     ^ " (data)"
+     ^ " VALUES ($1)")
+  |> ignore
+
+let read_escaped () : string list =
+  let result =
+    c#exec ~expect:[Tuples_ok]
+      ("select data from " ^ table)
+  in
+  result#get_all_lst
+  |> List.map List.hd
+  |> List.map unescape_bytea
+
+let read_binary () : string list =
+  let result =
+    c#exec ~expect:[Tuples_ok] ~binary_result:true
+      ("select data from " ^ table)
+  in
+  result#get_all_lst
+  |> List.map List.hd
+
+let delete_table () : unit =
+  c#exec ~expect:[Command_ok]
+    ("drop table if exists " ^ table ^ " cascade")
+  |> ignore
+
+let string_list_to_string  l =
+  "["
+  ^ (String.concat ", " l)
+  ^ "]"
+
+let main () =
+  delete_table ();
+  create_table ();
+  (* first 'line' of a compiled binary, pasted in *)
+  let data = "ELF>0L@–„$@8	@%$@@@¯¯888†¿†¿ p√p√0p√0ÿ‚! (ƒ(ƒ0(ƒ000TTTDDPÂtd`‘`‘`‘Ã[Ã[QÂtdRÂtdp√p√0p√0êê∑Åù[»·≥¢l∆'„¶•0ë5!@ÇÄ%$ √ bFÄ@ê Ú0êÄàê‡ÄÉê– " in
+  write_escaped data;
+  write_binary data;
+  let read_esc = read_escaped () in
+  let read_bin = read_binary () in
+  let expected = [data; data] in
+  (* print_endline ("expected: " ^ string_list_to_string expected); *)
+  (* print_endline ("read_escaped: " ^ string_list_to_string read_esc); *)
+  (* print_endline ("read_binary: " ^ string_list_to_string read_bin); *)
+  if read_esc <> expected
+  then prerr_endline "read_escaped <> expected";
+  if read_bin <> expected
+  then prerr_endline "read_binary <> expected";
+  if read_esc <> read_bin
+  then prerr_endline "read_escaped <> read_binary";
+  delete_table ();
+  ()
+
+
+let _ =
+  try main () with
+  | Error e ->
+    prerr_endline (string_of_error e);
+    exit 23
+  | e ->
+    prerr_endline (Printexc.to_string e);
+    exit 24

examples/jbuild

@@ -1,7 +1,7 @@
 (jbuild_version 1)
 
 (executables (
-  (names (async cursor dump populate prompt test_lo))
+  (names (async binary cursor dump populate prompt test_lo))
   (flags (
     :standard
     -w -9 -strict-sequence -principal -short-paths

src/postgresql.ml

@@ -369,7 +369,7 @@ module Stub = struct
   external result_isnull : result -> bool = "PQres_isnull" [@@noalloc]
 
   external exec_params :
-    connection -> string -> string array -> bool array -> result
+    connection -> string -> string array -> bool array -> bool -> result
     = "PQexecParams_stub"
 
   external prepare : connection -> string -> string -> result = "PQprepare_stub"
@@ -896,10 +896,14 @@ object (self)
   method empty_result status =
     new result (wrap_conn (fun conn -> (Stub.make_empty_res conn status)))
 
-  method exec ?(expect = []) ?(params = [||]) ?(binary_params = [||]) query =
+  method exec
+    ?(expect = []) ?(params = [||]) ?(binary_params = [||])
+    ?(binary_result = false) query =
     let r =
       wrap_conn (fun conn ->
-        let r = Stub.exec_params conn query params binary_params in
+        let r =
+          Stub.exec_params conn query params binary_params binary_result
+        in
         if Stub.result_isnull r then signal_error conn
         else r)
     in

src/postgresql.mli

@@ -581,18 +581,23 @@ object
 
   method exec :
     ?expect : result_status list -> ?params : string array ->
-    ?binary_params : bool array -> string -> result
-  (** [exec ?expect ?params ?binary_params query] synchronous execution
-      of query or command [query].  The result status will be checked
-      against all elements in [expect].  If [expect] is not empty and if
-      there is no match, the exception [Unexpected_status] will be raised.
+    ?binary_params : bool array -> ?binary_result : bool ->
+    string -> result
+
+  (** [exec ?expect ?params ?binary_params ?binary_result query]
+      synchronous execution of query or command [query].  The result
+      status will be checked against all elements in [expect].  If
+      [expect] is not empty and if there is no match, the exception
+      [Unexpected_status] will be raised.
 
       Additional query parameters can be passed in the [params] array.
       They must not be escaped and they can be referred to in [query]
       as $1, $2, ...  The value [null] can be used in the [params]
       array to denote an SQL NULL. It is possible to specify that some
       of the query parameters are passed as binary strings using the
-      [binary_params] array.
+      [binary_params] array. By default, results are returned in text
+      format, but will be returned in binary format if [binary_result]
+      is true.
 
       If no (or an empty) query parameter is passed, it is possible to
       emit several commands with a single call.
@@ -602,6 +607,7 @@ object
       @param expect default = []
       @param params default = [||]
       @param binary_params default = [||]
+      @param binary_result default = false
 
       @raise Error if there is a connection error.
       @raise Error if there is an unexpected result status.

src/postgresql_stubs.c

@@ -623,7 +623,8 @@ static inline void free_params_shallow(
 }
 
 CAMLprim value PQexecParams_stub(
-  value v_conn, value v_query, value v_params, value v_binary_params)
+  value v_conn, value v_query, value v_params, value v_binary_params,
+  value v_binary_result)
 {
   CAMLparam1(v_conn);
   PGconn *conn = get_conn(v_conn);
@@ -636,11 +637,12 @@ CAMLprim value PQexecParams_stub(
   int *formats, *lengths;
   copy_binary_params(v_params, v_binary_params, nparams, &formats, &lengths);
   memcpy(query, String_val(v_query), len);
+  bool binary_result = Bool_val(v_binary_result);
   caml_enter_blocking_section();
     res =
-      (nparams == 0)
+      (nparams == 0 && !binary_result)
         ? PQexec(conn, query)
-        : PQexecParams(conn, query, nparams, NULL, params, lengths, formats, 0);
+        : PQexecParams(conn, query, nparams, NULL, params, lengths, formats, binary_result);
     free_binary_params(formats, lengths);
     free_params(params, nparams);
     caml_stat_free(query);