B-trees & serialization with bencode

5 files changed, 233 insertions, 0 deletions

diff --git a/lib/concepts/Codec.ml b/lib/concepts/Codec.ml
new file mode 100644
index 0000000..758d718
--- /dev/null
+++ b/lib/concepts/Codec.ml
@@ -0,0 +1,182 @@
+ module Error = struct
+  open Condition
+
+  let unexpected_end =
+    condition "codec-unexpected-end" "Unexpected end of input while decoding" empty
+
+  let malformed_integer digits =
+    condition "codec-malformed-integer" "A byte run is not a valid integer"
+      ("digits" |=| Value.String digits)
+
+  let unexpected_byte c =
+    condition "codec-unexpected-byte" "Unexpected byte while decoding"
+      ("byte" |=| Value.String (String.make 1 c))
+
+  let string_out_of_bounds length =
+    condition "codec-string-out-of-bounds" "A string length runs past the end of input"
+      ("length" |=| Value.Integer length)
+
+  let trailing_bytes =
+    condition "codec-trailing-bytes" "Bytes remain after a complete value" empty
+
+  let tag_mismatch ~expected ~actual =
+    condition "codec-tag-mismatch" "A value with a different tag was expected"
+      ("expected" |=| Value.String (String.make 1 expected) &
+       "actual" |=| Value.String (String.make 1 actual))
+
+  let type_mismatch ~expected =
+    condition "codec-type-mismatch" "A Bencode value of a different shape was expected"
+      ("expected" |=| Value.String expected)
+
+  let missing_field key =
+    condition "codec-missing-field" "A required field is absent"
+      ("field" |=| Value.String key)
+
+  let unexpected_object ~expected ~actual =
+    condition "codec-unexpected-object" "The decoded object is not of the expected kind"
+      ("expected" |=| Value.String expected & "actual" |=| Value.String actual)
+end
+
+(* A self-describing serialization used as the uniform wire format for
+   durable objects. Chosen over an ad-hoc key=value scheme because it
+   nests (a multigroup holds a map of relation hashes) and has a
+   single byte form for a given value (dict keys are emitted sorted),
+   which matters once these bytes are content-addressed.
+
+   Grammar:
+   - Int    "i" <decimal> "e" (negatives allowed)
+   - String <length> ":" <raw bytes>
+   - List   "l" <element>* "e"
+   - Dict   "d" (<String key> <value>)* "e" keys sorted on encode *)
+module Bencode = struct
+  type t = Tagged of char * t | Int of int | String of string | List of t list | Dict of (string * t) list
+
+  let rec encode buf = function
+    | Tagged (tag, value) ->
+       Buffer.add_char buf 't';
+       Buffer.add_char buf tag;
+       encode buf value
+    | Int n ->
+       Buffer.add_char buf 'i';
+       Buffer.add_string buf (string_of_int n);
+       Buffer.add_char buf 'e'
+    | String s ->
+       Buffer.add_string buf (string_of_int (String.length s));
+       Buffer.add_char buf ':';
+       Buffer.add_string buf s
+    | List xs ->
+       Buffer.add_char buf 'l';
+       List.iter (encode buf) xs;
+       Buffer.add_char buf 'e'
+    | Dict kvs ->
+       Buffer.add_char buf 'd';
+       List.iter
+         (fun (k, v) ->
+           encode buf (String k);
+           encode buf v )
+         (List.sort (fun (a, _) (b, _) -> String.compare a b) kvs);
+       Buffer.add_char buf 'e'
+
+  let to_bytes (value : t) : bytes =
+    let buf = Buffer.create 256 in
+    encode buf value;
+    Buffer.to_bytes buf
+
+  let as_string = function String s -> Ok s | _ -> Error (Error.type_mismatch ~expected:"string")
+  let as_int = function Int n -> Ok n | _ -> Error (Error.type_mismatch ~expected:"integer")
+  let as_list = function List l -> Ok l | _ -> Error (Error.type_mismatch ~expected:"list")
+  let as_dict = function Dict d -> Ok d | _ -> Error (Error.type_mismatch ~expected:"dict")
+
+  let of_bytes (bytes : bytes) : (t, Condition.condition) result =
+    let open Utilities.Result in
+    let s = Bytes.to_string bytes in
+    let n = String.length s in
+    let pos = ref 0 in
+    let peek () = if !pos >= n then Error (Error.unexpected_end) else Ok (s.[!pos]) in
+    let advance () = incr pos in
+    (* Read the decimal run up to (and consuming) [term]. *)
+    let read_int_from start term =
+      let rec scan () =
+        let* c = peek () in
+        if c = term then begin
+          let digits = String.sub s start (!pos - start) in
+          advance ();
+          match int_of_string_opt digits with
+          | Some i -> Ok i
+          | None -> Error (Error.malformed_integer digits)
+        end
+        else begin
+          advance ();
+          scan ()
+        end
+      in
+      scan ()
+    in
+    let read_int term = read_int_from !pos term in
+    let read_char () =
+      let* c = peek () in
+      advance ();
+      Ok c
+    in
+    let rec parse () =
+      let* c = peek () in
+      advance ();
+      match c with
+      | 't' ->
+         let* tag = read_char () in
+         let* data = parse () in
+         Ok (Tagged (tag, data))
+      | 'i' ->
+         let* n = read_int 'e' in
+         Ok (Int n)
+      | 'l' -> parse_list []
+      | 'd' -> parse_dict []
+      | c when c >= '0' && c <= '9' -> parse_string_from (!pos - 1)
+      | c -> Error (Error.unexpected_byte c)
+    and parse_string () =
+      parse_string_from !pos
+    and parse_string_from start =
+      let* len = read_int_from start ':' in
+      if len < 0 || !pos + len > n then
+        Error (Error.string_out_of_bounds len)
+      else
+        let str = String.sub s !pos len in
+        pos := !pos + len;
+        Ok (String str)
+    and parse_list acc =
+      let* c = peek () in
+      if c = 'e' then (advance (); Ok (List (List.rev acc)))
+      else
+        let* result = parse () in
+        parse_list (result :: acc)
+    and parse_dict acc =
+      let* c = peek () in
+      if c = 'e' then (advance (); Ok (Dict (List.rev acc)))
+      else
+        let* key = parse_string () in
+        let* key = as_string key in
+        let* value = parse () in
+        parse_dict ((key, value) :: acc)
+    in
+    let* value = parse () in
+    if !pos <> n then Error Error.trailing_bytes else
+      Ok value
+
+  let to_blob x = to_bytes x |> Representation.blob_of_bytes
+  let of_blob b = Representation.bytes_of_blob b |> of_bytes
+
+  let with_tag t = function
+    | Tagged (t', v) ->
+       if t = t' then
+         Ok v
+       else
+         Error (Error.tag_mismatch ~expected:t ~actual:t')
+    | _ -> Error (Error.type_mismatch ~expected:"tagged")
+
+  let field key = function
+    | Dict kvs -> (
+      match List.assoc_opt key kvs with
+      | Some v -> Ok v
+      | None -> Error (Error.missing_field key) )
+    | _ -> Error (Error.type_mismatch ~expected:"dict")
+end
diff --git a/lib/concepts/Hash.ml b/lib/concepts/Hash.ml
index f467ee7..aac7428 100644
--- a/lib/concepts/Hash.ml
+++ b/lib/concepts/Hash.ml
@@ -2,8 +2,31 @@
 
 type hash = Digestif.SHA256.t
 
+let size = 256/8
+
+let compare h1 h2 = Digestif.SHA256.unsafe_compare h1 h2
+                    |> Ordering.of_int
+
 let hash_of_value (v : Value.value) =
   Representation.(blob_of_value v |> bytes_of_blob) |> Digestif.SHA256.digest_bytes
 
+let hash_of_bytes bytes = Digestif.SHA256.digest_bytes bytes
+
+let hash_of_blob blob = Representation.bytes_of_blob blob |> Digestif.SHA256.digest_bytes
+
+let to_raw_string hash = Digestif.SHA256.to_raw_string hash
+
+let of_raw_string str = Digestif.SHA256.of_raw_string str
+
 let hash_equals = Digestif.SHA256.equal
 let bytes_of_hash (h : hash) = Bytes.of_string (Digestif.SHA256.to_raw_string h)
+
+let power_of_two p =
+  let b = Bytes.make 32 '\x00' in
+  let byte = 31 - (p / 8) in
+  Bytes.set b byte (Char.chr (1 lsl (p mod 8)));
+  Bytes.unsafe_to_string b
+
+let pick n hash =
+  let threshold = Digestif.SHA256.of_raw_string (power_of_two (256 - n)) in
+  compare hash threshold = Ordering.Smaller
diff --git a/lib/concepts/Hash.mli b/lib/concepts/Hash.mli
index b100cd7..44fb3d0 100644
--- a/lib/concepts/Hash.mli
+++ b/lib/concepts/Hash.mli
@@ -1,11 +1,32 @@
 (** an abstract value representing a hash *)
 type hash
 
+(** the size of a hash, in bytes *)
+val size : int
+
 (** given a value, compute it's hash *)
 val hash_of_value : Value.value -> hash
 
+(** given a bag of bytes, compute it's hash *)
+val hash_of_bytes : bytes -> hash
+
+(** given a blob, compute it's hash *)
+val hash_of_blob : Representation.blob -> hash
+
+(** given a hash, return a representation of it as a string (/not/ the usual hex representation!) *)
+val to_raw_string : hash -> string
+
+(** given a string containing a representation of a hash (as per `to_raw_string`), return the corresponding hash *)
+val of_raw_string : string -> hash
+
+(** compare two hashes lexicographically *)
+val compare : hash -> hash -> Ordering.ordering
+
 (** given two hashes, are they the same? *)
 val hash_equals : hash -> hash -> bool
 
 (** given a hash, return a `bytes` representation of it *)
 val bytes_of_hash : hash -> bytes
+
+(** pick one every 1/2^n hashes *)
+val pick : int -> hash -> bool
diff --git a/lib/concepts/Ordering.ml b/lib/concepts/Ordering.ml
new file mode 100644
index 0000000..42b20e5
--- /dev/null
+++ b/lib/concepts/Ordering.ml
@@ -0,0 +1,4 @@
+type ordering = Equal | Smaller | Greater
+
+let of_int x =
+  if x < 0 then Smaller else if x > 0 then Greater else Equal
diff --git a/lib/concepts/Ordering.mli b/lib/concepts/Ordering.mli
new file mode 100644
index 0000000..ab8a3f4
--- /dev/null
+++ b/lib/concepts/Ordering.mli
@@ -0,0 +1,3 @@
+type ordering = Equal | Smaller | Greater
+
+val of_int : int -> ordering