diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/external/lmdb.ml | 84 | ||||
| -rw-r--r-- | lib/management/storage/lmdb.ml | 94 |
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"] |