WIP LMDB backend

1 files changed, 68 insertions, 16 deletions

diff --git a/lib/external/lmdb.ml b/lib/external/lmdb.ml
index 9c1d646..a918ce8 100644
--- a/lib/external/lmdb.ml
+++ b/lib/external/lmdb.ml
@@ -16,28 +16,80 @@ let mdb_mode_t = mode_t
 
 let mdb_result = view ~read:mdb_result_of_int ~write:int_of_mdb_result int
 
-type mdb_env = unit ptr
-let mdb_env = ptr Void
+type mdb_env
+let mdb_env : mdb_env structure typ = structure "mdb_env"
 
 type mdb_dbi = Unsigned.uint
-let mdb_dbi = uint
+let mdb_dbi : mdb_dbi typ = uint
 
-type mdb_txn = unit ptr
-let mdb_txn = ptr Void
+type mdb_txn
+let mdb_txn : mdb_txn structure typ = structure "mdb_txn"
 
-let mdb_env_create = foreign "mdb_env_create" (ptr ptr mdb_env @-> returning mdb_result)
-let mdb_env_create' () =
+type mdb_val
+let mdb_val : mdb_val structure typ = structure "mdb_val"
+let mv_size = field mdb_val "mv_size" size_t
+let mv_data = field mdb_val "mv_data" (ptr void)
+let () = seal mdb_val
+
+let with_output_pointer output_type default body =
   let open Utilities.Result in
-  let env_ptr = allocate mdb_env null in
-  let* () = mdb_env_create env_ptr in
-  Ok (!@ env_ptr)
+  let output_ptr = allocate output_type default in
+  let* () = body output_ptr in
+  Ok (!@ output_ptr)
+
+let mdb_env_create = foreign "mdb_env_create" (ptr (ptr mdb_env) @-> returning mdb_result)
+let mdb_env_create' () = with_output_pointer
+                           (ptr mdb_env)
+                           (from_voidp mdb_env null)
+                           mdb_env_create
 
 let mdb_env_open = foreign "mdb_env_open" (ptr mdb_env @-> string @-> uint @-> mdb_mode_t @-> returning mdb_result)
-let mdb_env_close = foreign "mdb_env_close" (ptr mdb_env @-> returning Void)
+let mdb_env_close = foreign "mdb_env_close" (ptr mdb_env @-> returning void)
 
 let mdb_dbi_open = foreign "mdb_dbi_open" (ptr mdb_txn @-> string @-> uint @-> ptr mdb_dbi @-> returning mdb_result)
-let mdb_dbi_open' txn name flags =
-  let open Utilities.Result in
-  let dbi_ptr = allocate mdb_dbi (Unsigned.UInt.of_int 0) in
-  let* () = mdb_dbi_open txn name flags dbi_ptr in
-  Ok (!@ dbi_ptr)
+let mdb_dbi_open' txn name flags = with_output_pointer
+                                     mdb_dbi
+                                     (Unsigned.UInt.of_int 0)
+                                     (mdb_dbi_open txn name flags)
+
+let mdb_txn_begin = foreign "mdb_txn_begin" (ptr mdb_env @-> ptr mdb_txn @-> uint @-> ptr (ptr mdb_txn) @-> returning mdb_result)
+let mdb_txn_begin' env parent flags = with_output_pointer
+                                        (ptr mdb_txn)
+                                        (from_voidp mdb_txn null)
+                                        (mdb_txn_begin env parent flags)
+
+let mdb_txn_commit = foreign "mdb_txn_commit" (ptr mdb_txn @-> returning mdb_result)
+let mdb_txn_abort = foreign "mdb_txn_abort" (ptr mdb_txn @-> returning mdb_result)
+
+let carray_of_bytes (b : bytes) =
+  let buffer = CArray.make char (Bytes.length b) in
+  Bytes.iteri (CArray.set buffer) b;
+  buffer
+
+let bytes_of_carray arr =
+  let buffer = Bytes.make (CArray.length arr) (Char.chr 0) in
+  CArray.iteri (Bytes.set buffer) arr;
+  buffer
+
+let mdb_val_ptr_of_bytes (b : bytes) =
+  let buf = carray_of_bytes b in
+  let s = make mdb_val in
+  setf s mv_size (Unsigned.Size_t.of_int (Bytes.length b));
+  setf s mv_data (to_voidp (CArray.start buf));
+  addr s
+
+let bytes_of_mdb_val (s : mdb_val structure) =
+  let buf = CArray.from_ptr
+              (from_voidp char (getf s mv_data))
+              (Unsigned.Size_t.to_int (getf s mv_size)) in
+  bytes_of_carray buf
+
+let mdb_get = foreign "mdb_get" (ptr mdb_txn @-> mdb_dbi @-> ptr mdb_val @-> ptr mdb_val @-> returning mdb_result)
+let mdb_get' txn dbi key = with_output_pointer
+                             mdb_val
+                             (make mdb_val)
+                             (mdb_get txn dbi (mdb_val_ptr_of_bytes key))
+                           |> Result.map bytes_of_mdb_val
+
+let mdb_put = foreign "mdb_put" (ptr mdb_txn @-> mdb_dbi @-> ptr mdb_val @-> ptr mdb_val @-> uint @-> returning mdb_result)
+let mdb_put' txn dbi key data flags = mdb_put txn dbi (mdb_val_ptr_of_bytes key) (mdb_val_ptr_of_bytes data) flags