WIP LMDB backend

2 files changed, 162 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
diff --git a/lib/management/storage/lmdb.ml b/lib/management/storage/lmdb.ml
new file mode 100644
index 0000000..80153cd
--- /dev/null
+++ b/lib/management/storage/lmdb.ml
@@ -0,0 +1,94 @@
+let not_implemented = Obj.magic ()
+
+module Backend : Physical.BACKEND = struct
+  open External.Lmdb
+  open Ctypes
+
+  module MDB_Errors = struct
+    let mdb_notfound = -30798
+  end
+
+  type configuration = { path : string; name : string }
+  type connection = { env : mdb_env structure ptr; dbi : mdb_dbi }
+  type error = int
+
+  type _ Effect.t +=
+     | Current: mdb_txn structure ptr Effect.t
+     | Rollback: unit Effect.t
+
+  let parse (expr : Sexplib.Sexp.t) =
+    let open Utilities.Result in
+    let* keys = Configuration.map_of_sexp expr in
+    let* path = Utilities.StringMap.find_opt "path" keys
+                |> Option.to_result ~none:"Missing key: path"
+                |> fmap (Configuration.atom_of_sexp)
+    in
+    let* name = Utilities.StringMap.find_opt "name" keys
+                |> Option.to_result ~none:"Missing key: name"
+                |> fmap (Configuration.atom_of_sexp)
+    in
+    Ok { path; name }
+
+  let current_tx () = Effect.perform Current
+  let current_tx' () = try current_tx () with Effect.Unhandled Current -> (from_voidp mdb_txn null)
+
+  let with_transaction' env body =
+    let open Utilities.Result in
+    let success = ref false in
+    let* tx = mdb_txn_begin' env (current_tx' ()) (Unsigned.UInt.of_int 0) in
+    Fun.protect
+      (fun () ->
+        match body () with
+        | x ->
+           let* () = mdb_txn_commit tx in
+           success := true;
+           Ok (Some x)
+        | effect Current, k -> Effect.Deep.continue k tx
+        (* Should a transaction abort be an error value? *)
+        | effect Rollback, _ ->
+           let* () = mdb_txn_abort tx in
+           success := true;
+           Ok None)
+      ~finally:(fun () -> if not !success then mdb_txn_abort tx |> ignore)
+
+  let with_transaction { env; _ } body = with_transaction' env body
+
+  let connect { path; name } =
+    let open Utilities.Result in
+    let* env = mdb_env_create' () in
+    match mdb_env_open env path (Unsigned.UInt.of_int 0) PosixTypes.Mode.zero with
+    | Error x ->
+       mdb_env_close env;
+       Error x
+    | Ok () ->
+       Result.bind
+         (with_transaction' env
+            (fun () ->
+              let* dbi = mdb_dbi_open' (current_tx ()) name (Unsigned.UInt.of_int 0) in
+              Ok { env; dbi }))
+         Option.get
+
+  let disconnect { env; _ } =
+    mdb_env_close env
+
+  let begin_transaction _conn = not_implemented
+
+  let commit _conn = not_implemented
+
+  let rollback _conn = not_implemented
+
+  let get { dbi; _ } hash =
+    match mdb_get' (current_tx ()) dbi (Bytes.of_string hash) with
+    | Ok x -> Ok (Some x)
+    | Error e when e = MDB_Errors.mdb_notfound -> Ok (None)
+    | Error e -> Error e
+
+  let put _conn _hash _value = not_implemented
+
+  let exists _conn _hash = not_implemented
+
+  let get_many _conn _hashes = not_implemented
+
+  let put_many _conn _values = not_implemented
+end
+[@warning "-38-32"]