Storage layer scaffolding, LMDB backend

17 files changed, 245 insertions, 45 deletions

diff --git a/flake.nix b/flake.nix
index 276925f..b709079 100644
--- a/flake.nix
+++ b/flake.nix
@@ -26,12 +26,18 @@
             duneVersion = "3";
             src = self;
 
-            propagatedBuildInputs = [
-              ocamlPackages.batteries
-              ocamlPackages.ctypes
-              ocamlPackages.ctypes-foreign
-            ];
+            propagatedBuildInputs = (with pkgs; [
+              lmdb
+            ]) ++ (with ocamlPackages; [
+              batteries
+              ctypes
+              ctypes-foreign
+              sexplib
+              digestif
+            ]);
+
             checkInputs = [ ocamlPackages.alcotest ];
+
             doCheck = true;
 
             meta = {
@@ -48,17 +54,11 @@
         {
           default = pkgs.mkShell {
             inputsFrom = [ self.packages.${pkgs.system}.default ];
-            packages = [
-              pkgs.dune_3
-              ocamlPackages.ocaml
-              ocamlPackages.ocaml-lsp
-              ocamlPackages.ocamlformat
-              ocamlPackages.utop
-              ocamlPackages.batteries
-              ocamlPackages.alcotest
-              ocamlPackages.ctypes
-              ocamlPackages.ctypes-foreign
-            ];
+            packages = (with ocamlPackages; [
+              ocaml-lsp
+              ocamlformat
+              utop
+            ]);
           };
         });
     };
diff --git a/lib/abstract/Storage.ml b/lib/abstract/Storage.ml
index f456567..2358c67 100644
--- a/lib/abstract/Storage.ml
+++ b/lib/abstract/Storage.ml
@@ -2,8 +2,7 @@ module type STORAGE = sig
   type connection
   type transaction
 
-  val connect :
-    Concepts.Configuration.configuration -> (connection, Concepts.Condition.condition) result
+  val connect : Concepts.Configuration.term -> (connection, Concepts.Condition.condition) result
 
   (** begin a transaction within `connection` *)
   val start : connection -> (transaction, Concepts.Condition.condition) result
diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml
index f4fcea1..0d7f8d0 100644
--- a/lib/backend/storage/LMDB.ml
+++ b/lib/backend/storage/LMDB.ml
@@ -55,11 +55,8 @@ module C = struct
     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)
-  [@@ocamlformat "disable"]
+  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)
@@ -125,12 +122,20 @@ end
 type connection = {env: C.mdb_env_ptr; dbi: C.mdb_dbi}
 type transaction = {tx: C.mdb_txn_ptr; dbi: C.mdb_dbi}
 
-let connect (_ : Concepts.Configuration.configuration) =
+let parse (c : Concepts.Configuration.term) =
+  let open Concepts.Configuration in
+  let open Utilities.Result in
+  let* config = as_dictionary c "lmdb" in
+  let* path = value_for "path" config |> fmap as_string in
+  let* mode = value_for "mode" config |> fmap as_int in
+  Ok (path, mode)
+
+let connect (c : Concepts.Configuration.term) =
+  let open Utilities.Result in
+  let* path, mode = parse c in
   begin
-    let open Utilities.Result in
     let* env = C.mdb_env_create' () in
-    (* TODO: make the path, POSIX mode a config parameter *)
-    match C.mdb_env_open env "/tmp/sakura.db" Unsigned.UInt.zero (PosixTypes.Mode.of_int 420) with
+    match C.mdb_env_open env path Unsigned.UInt.zero (PosixTypes.Mode.of_int mode) with
     | Error x -> C.mdb_env_close env; Error x
     | Ok () ->
         let* tx = C.mdb_txn_begin' env C.null_txn Unsigned.UInt.zero in
@@ -139,6 +144,9 @@ let connect (_ : Concepts.Configuration.configuration) =
         Ok {env; dbi}
   end
   |> Result.map_error Error.lmdb_error
+  |> Result.map_error
+       Concepts.Condition.(
+         complement ("path" |=| Concepts.Value.String path & "mode" |=| Concepts.Value.Integer mode) )
 
 let start ({env; dbi} : connection) =
   C.mdb_txn_begin' env C.null_txn Unsigned.UInt.zero
diff --git a/lib/concepts/Condition.ml b/lib/concepts/Condition.ml
index cc0f7a7..16f02d0 100644
--- a/lib/concepts/Condition.ml
+++ b/lib/concepts/Condition.ml
@@ -18,6 +18,8 @@ let condition name message ?parent props =
       |> Option.value ~default:BatMap.empty
       |> props }
 
+let complement props ({properties; _} as condition) = {condition with properties= props properties}
+
 let to_string_hum {name; message; properties; backtrace} =
   let properties' =
     properties
diff --git a/lib/concepts/Condition.mli b/lib/concepts/Condition.mli
index fba43e6..86c86fa 100644
--- a/lib/concepts/Condition.mli
+++ b/lib/concepts/Condition.mli
@@ -10,5 +10,8 @@ val empty : ps
 (** construct a condition out of a name, a message, a set of properties and an optional parent *)
 val condition : string -> string -> ?parent:condition -> ps -> condition
 
+(** complement a condition with an extra set of properties *)
+val complement : ps -> condition -> condition
+
 (** print a condition to a human-readable string *)
 val to_string_hum : condition -> string
diff --git a/lib/concepts/Configuration.ml b/lib/concepts/Configuration.ml
index 06434c2..5ca95d5 100644
--- a/lib/concepts/Configuration.ml
+++ b/lib/concepts/Configuration.ml
@@ -1 +1,70 @@
-type configuration = unit
+open Sexplib.Sexp
+
+type term = Sexplib.Sexp.t
+
+module Error = struct
+  open Condition
+
+  let missing_key key =
+    condition "missing-key" "An expected key was not found" ("key" |=| Value.String key)
+
+  let mismatched_tag expected actual =
+    condition "mismatched-tag" "A tag did not match what was expected"
+      ("expected" |=| Value.String expected & "actual" |=| Value.String actual)
+
+  let syntax_error form =
+    condition "syntax-error" "Syntax error"
+      ("form" |=| Value.String (Sexplib.Sexp.to_string_hum form))
+
+  let tagless_form form =
+    condition "tagless-form" "Cannot take tag of an atom or an empty list"
+      ~parent:(syntax_error form) empty
+
+  let bodyless_form form =
+    condition "bodyless-form" "Cannot take body of an atom or an empty list"
+      ~parent:(syntax_error form) empty
+
+  let malformed_pair form =
+    condition "malformed-pair" "Expected a pair of key and value" ~parent:(syntax_error form) empty
+
+  let expected_atom form =
+    condition "expected-atom" "Expected atom but got list structure" ~parent:(syntax_error form)
+      empty
+
+  let not_a_number form =
+    condition "not-a-number" "Could not parse value as number" ~parent:(syntax_error form) empty
+end
+
+let term_of_sexp t = t
+let tag_of = function List (Atom tag :: _) -> Ok tag | form -> Error (Error.tagless_form form)
+let body_of = function List (_ :: body) -> Ok body | form -> Error (Error.bodyless_form form)
+
+type dictionary = (string, term) BatMap.t
+
+let value_for k ?default d =
+  let default = Option.to_result ~none:(Error.missing_key k) default in
+  BatMap.find_opt k d |> Option.map (fun x -> Ok x) |> Option.value ~default
+
+let as_dictionary t tag : (dictionary, Condition.condition) result =
+  let open Utilities.Result in
+  let strip_tag (tag : string) (t : term) =
+    let* tag' = tag_of t in
+    if tag' = tag then body_of t else Error (Error.mismatched_tag tag tag')
+  in
+  let as_dictionary' pairs =
+    List.fold_right
+      (fun term dict ->
+        let* dict = dict in
+        match term with
+        | List [Atom k; v] -> Ok (BatMap.add k v dict)
+        | p -> Error (Error.malformed_pair p) )
+      pairs (Ok BatMap.empty)
+  in
+  strip_tag tag t |> fmap as_dictionary'
+
+let as_string = function Atom s -> Ok s | form -> Error (Error.expected_atom form)
+
+let as_int f =
+  let open Utilities.Result in
+  let* s = as_string f in
+  int_of_string_opt s |> Option.to_result ~none:(Error.not_a_number f)
diff --git a/lib/concepts/Configuration.mli b/lib/concepts/Configuration.mli
index 5e16ff9..d633f5c 100644
--- a/lib/concepts/Configuration.mli
+++ b/lib/concepts/Configuration.mli
@@ -1,2 +1,13 @@
-(** an abstract representation for a system configuration *)
-type configuration
+(** an abstract representation of a system configuration expression *)
+type term
+
+val term_of_sexp : Sexplib.Sexp.t -> term
+val tag_of : term -> (string, Condition.condition) result
+
+(** an abstract type associating strings to configuration values *)
+type dictionary
+
+val value_for : string -> ?default:term -> dictionary -> (term, Condition.condition) result
+val as_dictionary : term -> string -> (dictionary, Condition.condition) result
+val as_int : term -> (int, Condition.condition) result
+val as_string : term -> (string, Condition.condition) result
diff --git a/lib/concepts/Hash.ml b/lib/concepts/Hash.ml
index 681ec4a..106e731 100644
--- a/lib/concepts/Hash.ml
+++ b/lib/concepts/Hash.ml
@@ -1,5 +1,7 @@
-type hash = bytes
+type hash = Digestif.SHA256.t
 
-let hash_of_value (_ : Value.value) = failwith "TODO"
-let hash_equals (_ : hash) (_ : hash) = failwith "TODO"
-let bytes_of_hash (h : hash) = h
+let hash_of_value (v : Value.value) =
+  Representation.(blob_of_value v |> bytes_of_blob) |> Digestif.SHA256.digest_bytes
+
+let hash_equals = Digestif.SHA256.equal
+let bytes_of_hash (h : hash) = Bytes.of_string (Digestif.SHA256.to_raw_string h)
diff --git a/lib/concepts/Representation.ml b/lib/concepts/Representation.ml
index d353a38..856ae11 100644
--- a/lib/concepts/Representation.ml
+++ b/lib/concepts/Representation.ml
@@ -1,6 +1,34 @@
-type blob = unit
+type blob = bytes
 
-let blob_of_value (_ : Value.value) = failwith "TODO"
-let value_of_blob (_ : blob) = failwith "TODO"
-let blob_of_bytes (_ : bytes) = failwith "TODO"
-let bytes_of_blob (_ : blob) = failwith "TODO"
+let blob_of_bytes (b : bytes) = b
+let bytes_of_blob (b : blob) = b
+
+(* A blob is a one-byte constructor tag followed by its payload. The
+   tag makes the encoding self-describing so [value_of_blob] can
+   recover the constructor:
+   - String  ['\000'] ++ raw utf-8 bytes
+   - Integer ['\001'] ++ 8-byte big-endian int64 *)
+let tag_string = '\000'
+let tag_integer = '\001'
+
+let blob_of_value = function
+  | Value.String s ->
+      let b = Bytes.create (1 + String.length s) in
+      Bytes.set b 0 tag_string;
+      Bytes.blit_string s 0 b 1 (String.length s);
+      b
+  | Value.Integer n ->
+      let b = Bytes.create 9 in
+      Bytes.set b 0 tag_integer;
+      Bytes.set_int64_be b 1 (Int64.of_int n);
+      b
+
+let value_of_blob (b : blob) =
+  let n = Bytes.length b in
+  if n = 0 then invalid_arg "value_of_blob: empty blob";
+  match Bytes.get b 0 with
+  | c when c = tag_string -> Value.String (Bytes.sub_string b 1 (n - 1))
+  | c when c = tag_integer ->
+      if n <> 9 then invalid_arg "value_of_blob: malformed integer payload";
+      Value.Integer (Int64.to_int (Bytes.get_int64_be b 1))
+  | c -> invalid_arg (Printf.sprintf "value_of_blob: unknown tag %C" c)
diff --git a/lib/concepts/Value.ml b/lib/concepts/Value.ml
index 65a0439..75b0e88 100644
--- a/lib/concepts/Value.ml
+++ b/lib/concepts/Value.ml
@@ -1,3 +1,6 @@
 type value = String of string | Integer of int
 
 let to_string = function String s -> s | Integer n -> Int.to_string n
+
+let equal x y =
+  match x, y with String x, String y -> x = y | Integer x, Integer y -> x = y | _, _ -> false
diff --git a/lib/concepts/Value.mli b/lib/concepts/Value.mli
index 9644443..c1a9f18 100644
--- a/lib/concepts/Value.mli
+++ b/lib/concepts/Value.mli
@@ -3,3 +3,6 @@ type value = String of string | Integer of int
 
 (** given a value, return a string representation of it *)
 val to_string : value -> string
+
+(** given two values, are they the same? *)
+val equal : value -> value -> bool
diff --git a/lib/dune b/lib/dune
index 6fc5388..c494f86 100644
--- a/lib/dune
+++ b/lib/dune
@@ -3,4 +3,5 @@
 (library
  (name rnt)
  (public_name rnt)
- (libraries batteries ctypes ctypes-foreign))
+ (libraries batteries ctypes ctypes-foreign sexplib digestif)
+ (flags :standard -cclib -llmdb))
diff --git a/lib/rnt.ml b/lib/rnt.ml
deleted file mode 100644
index 7192e6b..0000000
--- a/lib/rnt.ml
+++ /dev/null
@@ -1,3 +0,0 @@
-(** RNT: Relations, Not Tables. *)
-
-let version = "0.1.0"
diff --git a/test/Helpers.ml b/test/Helpers.ml
new file mode 100644
index 0000000..bf34b82
--- /dev/null
+++ b/test/Helpers.ml
@@ -0,0 +1,19 @@
+open Rnt
+
+let rec recursively_remove path =
+  if Sys.is_directory path then begin
+    Sys.readdir path |> Array.iter (fun name -> recursively_remove (Filename.concat path name));
+    Unix.rmdir path
+  end
+  else Sys.remove path
+
+let with_temporary_directory prefix ?(suffix = "") f =
+  let path = Filename.temp_dir ~temp_dir:"/tmp" prefix suffix in
+  Fun.protect (fun () -> f path) ~finally:(fun () -> recursively_remove path)
+
+let condition_as_failure = function
+  | Ok r -> r
+  | Error c -> Alcotest.fail (Concepts.Condition.to_string_hum c)
+
+let pp_value ppf v = Format.pp_print_string ppf (Concepts.Value.to_string v)
+let value = Alcotest.testable pp_value Concepts.Value.equal
diff --git a/test/dune b/test/dune
index 3c52f25..861e93a 100644
--- a/test/dune
+++ b/test/dune
@@ -1,3 +1,5 @@
+(include_subdirs qualified)
+
 (test
  (name test_rnt)
  (libraries rnt alcotest))
diff --git a/test/test_rnt.ml b/test/test_rnt.ml
index 4838ff4..5dd79cf 100644
--- a/test/test_rnt.ml
+++ b/test/test_rnt.ml
@@ -1,2 +1,2 @@
-let test_version () = Alcotest.(check string) "version" "0.1.0" Rnt.version
-let () = Alcotest.run "rnt" ["smoke", [Alcotest.test_case "version" `Quick test_version]]
+let all_suites = Unit.Backend.Storage.suites ()
+let () = Alcotest.run "RNT" all_suites
diff --git a/test/unit/backend/Storage.ml b/test/unit/backend/Storage.ml
new file mode 100644
index 0000000..91db411
--- /dev/null
+++ b/test/unit/backend/Storage.ml
@@ -0,0 +1,53 @@
+open Rnt
+
+module type CONFIGURATOR = sig
+  val configure : string -> Rnt.Concepts.Configuration.term
+end
+
+module Make (S : Abstract.Storage.STORAGE) (C : CONFIGURATOR) = struct
+  open Alcotest
+
+  let with_connection f () =
+    Helpers.with_temporary_directory "storage-test" begin fun dir ->
+        begin
+          let open Utilities.Result in
+          let* conn = S.connect (C.configure dir) in
+          Ok (f conn)
+        end
+        |> Helpers.condition_as_failure
+      end
+
+  let storage_and_retrieval conn =
+    let key = Concepts.Hash.hash_of_value (Concepts.Value.String "value") in
+    let value = Concepts.Value.Integer 42 in
+    let blob = Concepts.Representation.blob_of_value value in
+    let v, v' =
+      begin
+        let open Utilities.Result in
+        let* tx = S.start conn in
+        let* v = S.get tx key in
+        let* () = S.put tx key blob in
+        let* v' = S.get tx key in
+        Ok Concepts.Representation.(Option.map value_of_blob v, Option.map value_of_blob v')
+      end
+      |> Helpers.condition_as_failure
+    in
+    check (option Helpers.value) "`get` before `put` should return no value" None v;
+    check (option Helpers.value) "`get` after `put` should return the inserted value" (Some value)
+      v'
+
+  let suite prefix =
+    ( "storage/" ^ prefix,
+      [test_case "storage-and-retrieval" `Quick (with_connection storage_and_retrieval)] )
+end
+
+module LMDB_Configurator : CONFIGURATOR = struct
+  let configure base =
+    let open Sexplib.Sexp in
+    List [Atom "lmdb"; List [Atom "path"; Atom base]; List [Atom "mode"; Atom "420"]]
+    |> Rnt.Concepts.Configuration.term_of_sexp
+end
+
+module LMDB = Make (Rnt.Backend.Storage.LMDB) (LMDB_Configurator)
+
+let suites () = [LMDB.suite "lmdb"]