Storage layer scaffolding, LMDB backend

8 files changed, 133 insertions, 12 deletions

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