Commit b5878143 authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

playing around with serialization of persistent store

parent d981e02a
......@@ -76,7 +76,7 @@ let list_branches db request =
let body =
Hashtbl.to_alist branches
|> List.map ~f:(fun (name, hash) ->
name, `String (Speechcake.Store.Hash.SHA256.to_string hash))
name, `String (Speechcake.Database.VS.Hash.to_string hash))
|> fun pairs -> `Assoc pairs
|> Yojson.Basic.to_string in
Dream.json body
......
......@@ -53,15 +53,15 @@ module Interval = struct
let to_json ((l, r), t) =
let open Decoders_yojson.Basic.Encode in
list value
[ string (Int64.to_string l)
; string (Int64.to_string r)
[ int (Int64.to_int_exn l)
; int (Int64.to_int_exn r)
; string t
]
let of_json =
let open Decoders_yojson.Basic.Decode in
let* l = index 0 string >|= Int64.of_string in
let* r = index 1 string >|= Int64.of_string in
let* l = index 0 int >|= Int64.of_int in
let* r = index 1 int >|= Int64.of_int in
let+ t = index 2 string in
(l, r), t
end
......
......@@ -4,7 +4,7 @@ module Log = (val Logs.src_log src : Logs.LOG)
module Make (C : Store.Contents.S) = struct
module PS = Store.Persistent_store.Make (Store.Hash.SHA256)
module PS = Store.Persistent_store.Make (Store.Hash.BLAKE2B)
module VS = Store.Version_store.Make (C) (PS)
type t = (string, VS.t) Core.Hashtbl.t
......
......@@ -55,3 +55,6 @@ end
module SHA256 = Make (Digestif.SHA256)
module Small_BLAKE2B = Digestif.Make_BLAKE2B (struct let digest_size = 8 end)
module BLAKE2B = Make (Small_BLAKE2B)
......@@ -50,5 +50,6 @@ module type Intf = sig
module Make : MAKER
module SHA256 : S
module BLAKE2B : S
end
......@@ -15,19 +15,18 @@ module Make (H : Hash.S) = struct
let pp_hash = H.pp
type small =
| Empty
| Null
| Bool of bool
| Int of int
| Float of float
| Ptr of hash
| Head of [ `A | `L ] * hash option
| Sstr of string
[@@deriving eq]
let pp_small ppf =
let open Fmt in
function
| Empty -> pf ppf "<empty>"
| Null -> pf ppf "<null>"
| Bool b -> pf ppf "b:%b" b
| Int i -> pf ppf "i:%d" i
......@@ -37,6 +36,7 @@ module Make (H : Hash.S) = struct
| Head (`A, None) -> pf ppf "a:<empty>"
| Head (`L, Some l) -> pf ppf "l:%a" H.pp l
| Head (`L, None) -> pf ppf "l:<empty>"
| Sstr s -> pf ppf "s:%s" s
let feed_ptr_option p =
match p with
......@@ -46,19 +46,20 @@ module Make (H : Hash.S) = struct
let hash_small t =
let open H in
match t with
| Empty -> init ~tag:0L () |> finish
| Null -> init ~tag:(-1L) () |> finish
| Null -> init ~tag:0L () |> finish
| Bool b -> init ~tag:1L () |> feed_string (Bool.to_string b) |> finish
| Int i -> init ~tag:2L () |> feed_int64 (Int64.of_int i) |> finish
| Float f -> init ~tag:3L () |> feed_string (Float.to_string f) |> finish
| Ptr h -> init ~tag:4L () |> feed_hash h |> finish
| Head (`A, a) -> init ~tag:5L () |> feed_ptr_option a |> finish
| Head (`L, l) -> init ~tag:6L () |> feed_ptr_option l |> finish
| Sstr s -> init ~tag:7L () |> feed_string s |> finish
type large =
| String of string
| Named of string * small
| Pair of small * small
| Bottom of int * small array
| Intern of int * hash array
| Root of small
[@@deriving eq]
......@@ -67,25 +68,31 @@ module Make (H : Hash.S) = struct
function
| String s -> pf ppf "s:%s" s
| Named (n, t) -> pf ppf "n:(%s, %a)" n pp_small t
| Pair (l, r) -> pf ppf "p:(%a, %a)" pp_small l pp_small r
| Bottom (n, a) -> pf ppf "b:(%d, %a)" n (array pp_small) a
| Intern (n, a) -> pf ppf "i:(%d, %a)" n (array pp_hash) a
| Root r -> pf ppf "r:%a" pp_small r
let hash_large b =
let open H in
begin match b with
| String s ->
init ~tag:6L ()
init ~tag:7L ()
|> feed_string s
|> finish
| Named (n, t) ->
init ~tag:7L ()
init ~tag:8L ()
|> feed_string n
|> feed_hash (hash_small t)
|> finish
| Pair (l, r) ->
init ~tag:8L ()
|> feed_hash (hash_small l)
|> feed_hash (hash_small r)
| Bottom (n, a) ->
init ~tag:9L ()
|> feed_int n
|> feed_list feed_hash (Array.to_list a |> Base.List.map ~f:hash_small)
|> finish
| Intern (n, a) ->
init ~tag:10L ()
|> feed_int n
|> feed_list feed_hash (Array.to_list a)
|> finish
| Root root ->
hash_small root
......@@ -128,24 +135,36 @@ module Make (H : Hash.S) = struct
|> Base.List.filter_map ~f
let of_list (store : Store.t) (elts : small list) =
let rec upper xs acc =
let bottom =
Base.List.chunks_of ~length:32 elts
|> Base.List.map ~f:Array.of_list
|> Base.List.map ~f:(fun a -> Bottom (Array.length a, a))
|> Base.List.map ~f:(fun b -> Store.put store b)
in
let rec upper' xs =
match xs with
| [] -> None
| x :: [] -> Some x
| xs ->
Base.List.chunks_of ~length:32 xs
|> Base.List.map ~f:Array.of_list
|> Base.List.map ~f:(fun a -> Intern (Array.length a, a))
|> Base.List.map ~f:(fun b -> Store.put store b)
|> upper'
in
(*let rec upper xs acc =
match xs with
| [] -> List.rev acc
| a :: [] -> List.rev (a :: acc)
| a :: b :: rest ->
let data = Pair (a, b) in
let key = Store.put store data in
upper rest (Ptr key :: acc) in
let rec loop xs =
match xs with
| [] -> None
| [ x ] -> Some x
| xs -> loop (upper xs []) in
let elts =
upper rest (Ptr key :: acc) in*)
(*let elts =
if (List.length elts mod 2) = 1
then elts @ [ Empty ]
else elts in
let root = loop elts in
else elts in*)
let root = upper' bottom in
root
let of_json (t : Store.t) (json : Yojson.Basic.t) =
......@@ -155,6 +174,7 @@ module Make (H : Hash.S) = struct
| `Bool b -> Bool b
| `Int i -> Int i
| `Float f -> Float f
| `String s when String.length s < 16 -> Sstr s
| `String s -> Ptr (Store.put t (String s))
| `Assoc kvs ->
Base.List.sort kvs
......@@ -163,16 +183,14 @@ module Make (H : Hash.S) = struct
Ptr (Store.put t (Named (k, loop v))))
|> of_list t
|> (function
| Some (Ptr key) -> Head (`A, Some key)
| Some _ -> failwith "broken of_json/`Assoc"
| None -> Head (`A, None))
| Some hash -> Head (`A, Some hash)
| None -> Head (`A, None))
| `List xs ->
Base.List.map xs ~f:loop
|> of_list t
|> (function
| Some (Ptr key) -> Head (`L, Some key)
| Some _ -> failwith "broken of_json/`List"
| None -> Head (`L, None))
| Some hash -> Head (`L, Some hash)
| None -> Head (`L, None))
in
loop json
......@@ -181,8 +199,14 @@ module Make (H : Hash.S) = struct
let rec hydrate_assoc (t : Store.t) root =
let rec loop root =
match Store.get t root with
| Some (Pair (Ptr l, Ptr r)) -> (loop l) @ (loop r)
| Some (Pair (Ptr l, Empty)) -> loop l
| Some (Intern (_, a)) ->
Array.to_list a
|> Base.List.map ~f:loop
|> Base.List.concat
| Some (Bottom (_, a)) ->
Array.to_list a
|> Base.List.filter_map ~f:(function Ptr p -> Some (loop p) | _ -> None)
|> Base.List.concat
| Some (Named (n, v)) -> [ n, to_json t v ]
| Some other ->
failwith (Fmt.str "hydrate_assoc: broken tree: %a" Block.pp other)
......@@ -194,13 +218,14 @@ module Make (H : Hash.S) = struct
and hydrate_list (t : Store.t) root =
let rec loop root =
match Store.get t root with
| Some (String s) -> [ `String s ]
| Some (Pair (Ptr l, Ptr r)) -> (loop l) @ (loop r)
| Some (Pair (Ptr l, Empty)) -> loop l
| Some (Pair (Ptr l, r)) -> (loop l) @ [ to_json t r ]
| Some (Pair (l, Ptr r)) -> (to_json t l) :: (loop r)
| Some (Pair (l, Empty)) -> [ to_json t l ]
| Some (Pair (l, r)) -> [ to_json t l; to_json t r ]
| Some (Intern (_, a)) ->
Array.to_list a
|> Base.List.map ~f:loop
|> Base.List.concat
| Some (Bottom (_, a)) ->
Array.to_list a
|> Base.List.map ~f:(to_json t)
| Some (String s) -> [ `String s ]
| Some other ->
failwith (Fmt.str "hydrate_list: broken tree: %a" Block.pp other)
| None ->
......@@ -209,7 +234,6 @@ module Make (H : Hash.S) = struct
loop root
and to_json (t : Store.t) = function
| Empty -> failwith "cannot encode Empty"
| Null -> `Null
| Bool b -> `Bool b
| Int i -> `Int i
......@@ -221,12 +245,14 @@ module Make (H : Hash.S) = struct
| Head (`A, None) -> `Assoc []
| Head (`L, Some root) -> `List (hydrate_list t root)
| Head (`L, None) -> `List []
| Sstr s -> `String s
and block_to_json (t : Store.t) blk =
match blk with
| String s -> `String s
| Named _ -> failwith "cannot encode named"
| Pair _ -> failwith "cannot encode pair"
| Bottom _ -> failwith "cannot encode bottom"
| Intern _ -> failwith "cannot encode intern"
| Root r -> to_json t r
......@@ -263,23 +289,24 @@ module Make (H : Hash.S) = struct
let value =
function
| Empty -> atom "empty"
| Null -> atom "null"
| Bool b -> tagged "bool" [ bool b ]
| Int i -> tagged "int" [ int i ]
| Float f -> tagged "float" [ float f ]
| Ptr p -> tagged "ptr" [ ptr p ]
| Null -> null
| Bool b -> bool b
| Int i -> int i
| Float f -> float f
| Ptr p -> tagged "ptr" [ ptr p ]
| Head (`A, Some root) -> tagged "assoc" [ ptr root ]
| Head (`A, None) -> tagged "assoc" [ null ]
| Head (`L, Some root) -> tagged "list" [ ptr root ]
| Head (`L, None) -> tagged "list" [ null ]
| Sstr s -> string s
let store (s : Store.t) =
let block = function
| String s -> tagged "str" [ string s ]
| Named (n, t) -> tagged "named" [ string n; value t ]
| Pair (x, y) -> tagged "pair" [ value x; value y ]
| Root root -> tagged "root" [ value root ]
| String s -> tagged "str" [ string s ]
| Named (n, t) -> tagged "named" [ string n; value t ]
| Bottom (n, a) -> tagged "bottom" [ int n; array value a ]
| Intern (n, a) -> tagged "intern" [ int n; array ptr a ]
| Root root -> tagged "root" [ value root ]
in
Core.Hashtbl.to_alist (Store.map s ~f:block)
|> Core.List.map ~f:(fun (k, v) -> H.to_string k, v)
......@@ -296,17 +323,18 @@ module Make (H : Hash.S) = struct
let value =
let simple =
of_of_string ~msg:"simple value" (function
| "empty" -> Some Empty
| "null" -> Some Null
| _ -> None) in
one_of
[ "bool", bool >|= (fun b -> Bool b)
; "int", int >|= (fun i -> Int i)
; "float", float >|= (fun f -> Float f)
(*; "ptr", ptr >|= (fun p -> Ptr p)*)
; "null", null >|= (fun () -> Null)
; "sstr", string >|= (fun s -> Sstr s)
] in
let compound =
let* tag = index 0 string in
match tag with
| "bool" -> map (fun b -> Bool b) (index 1 bool)
| "int" -> map (fun i -> Int i) (index 1 int)
| "float" -> map (fun f -> Float f) (index 1 float)
| "ptr" -> map (fun p -> Ptr p) (index 1 ptr)
| "ptr" -> map (fun p -> Ptr p) (index 1 ptr)
| "assoc" -> map (fun a -> Head (`A, a)) (maybe (index 1 ptr))
| "list" -> map (fun l -> Head (`L, l)) (maybe (index 1 ptr))
| _ -> fail "not a compound value" in
......@@ -325,10 +353,14 @@ module Make (H : Hash.S) = struct
let* n = index 1 string in
let* t = index 2 value in
succeed (Named (n, t))
| "pair" ->
let* x = index 1 value in
let* y = index 2 value in
succeed (Pair (x, y))
| "bottom" ->
let* n = index 1 int in
let* a = index 2 (array value) in
succeed (Bottom (n, a))
| "intern" ->
let* n = index 1 int in
let* a = index 2 (array ptr) in
succeed (Intern (n, a))
| "root" ->
let* root = index 1 value in
succeed (Root root)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment