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

simplify internal persistent structure; bring back tort to a working state

parent b5878143
......@@ -3,7 +3,7 @@
(flags (:standard -cclib -static -cclib -no-pie))))
(executables
(names konditorei)
(names konditorei tort)
(libraries
core
dream
......
......@@ -49,8 +49,12 @@ let setup =
let bucket_of_file path =
match Sys.file_exists path with
| `Yes -> Yojson.Basic.from_file path |> Speechcake.Storage.load
| _ -> Ok (Speechcake.Storage.init ())
| `Yes ->
Yojson.Basic.from_file path
|> Speechcake.Database.VS.Decode.load
|> Result.map_error ~f:(fun e -> `Decoding_error e)
| _ ->
Ok (Speechcake.Database.VS.init ())
let tiers () path =
let contents = In_channel.read_all path in
......@@ -97,44 +101,49 @@ let wrap () key tags =
|> Decoders_yojson.Basic.Decode.decode_value Annotation.Tier.of_json in
match contents with
| Ok tier ->
let doc = Speechcake.document ~key ~tags tier in
Fmt.pr "%s@." (Yojson.Basic.to_string (Speechcake.document_to_json doc))
let doc = Speechcake.Document.v ~key ~tags tier in
Fmt.pr "%s@." (Yojson.Basic.to_string (Speechcake.Document.encoder doc))
| Error e ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
let persist () root key =
let data = In_channel.input_all In_channel.stdin in
match bucket_of_file (root ^ "/" ^ key) with
| Ok bucket ->
let value = Speechcake.Storage.Persistent_store.of_json bucket (Yojson.Basic.from_string data) in
Out_channel.write_all (root ^ "/" ^ key) ~data:(Yojson.Basic.to_string (Speechcake.Storage.dump bucket)) ;
Fmt.pr "%s@." (Sexp.to_string (Speechcake.Storage.Value.to_sexp value))
| Error e ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
let commit () root key value author comment =
let date = ISO8601.Permissive.string_of_datetime (Unix.gettimeofday ()) in
let info = Speechcake.Storage.Metadata.v ~author ~date ~comment () in
let value =
Sexp.of_string value
|> Speechcake.Storage.Bucket.value_of_sexp in
match bucket_of_file (root ^ "/" ^ key) with
| Ok bucket ->
let hash = Speechcake.Storage.Bucket.commit bucket value ~info in
Out_channel.write_all (root ^ "/" ^ key) ~data:(Yojson.Basic.to_string (Speechcake.Storage.Bucket.dump bucket)) ;
Fmt.pr "%08Lx@." hash
| Error e ->
let commit () root key author comment =
let result =
let open Result.Monad_infix in
In_channel.input_all In_channel.stdin
|> Decoders_yojson.Basic.Decode.decode_string Speechcake.Document.decoder
|> Result.map_error ~f:(fun e -> `Decoding_error e)
>>= fun document -> bucket_of_file (root ^ "/" ^ key)
>>= fun store ->
let date = ISO8601.Permissive.string_of_datetime (Unix.gettimeofday ()) in
let meta = Speechcake.Database.VS.Metadata.v ~author ~date ~comment () in
let store', hash = Speechcake.Database.VS.put store document ~meta in
Out_channel.write_all (root ^ "/" ^ key)
~data:(Yojson.Basic.to_string (Speechcake.Database.VS.Encode.dump store')) ;
Ok hash
in
match result with
| Ok hash ->
Fmt.pr "%a@." Speechcake.Database.VS.Hash.pp hash
| Error (`Decoding_error e) ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
let tag () root key name hash =
let hash = Int64.of_string ("0x" ^ hash) in
match bucket_of_file (root ^ "/" ^ key) with
| Ok bucket ->
Speechcake.Storage.Bucket.tag bucket name hash ;
Out_channel.write_all (root ^ "/" ^ key) ~data:(Yojson.Basic.to_string (Speechcake.Storage.Bucket.dump bucket))
| Error e ->
let result =
let open Result.Monad_infix in
Speechcake.Database.VS.Hash.of_string hash
|> Result.of_option ~error:(`Invalid_hash hash)
>>= fun hash -> bucket_of_file (root ^ "/" ^ key)
>>| fun store ->
Speechcake.Database.VS.tag store name hash ;
Out_channel.write_all (root ^ "/" ^ key)
~data:(Yojson.Basic.to_string (Speechcake.Database.VS.Encode.dump store))
in
match result with
| Ok () -> ()
| Error (`Decoding_error e) ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
| Error (`Invalid_hash h) ->
Fmt.epr "invalid hash: %s@." h
let default_t =
......@@ -189,21 +198,6 @@ let wrap_t =
, info ~doc "wrap"
)
let persist_t =
let open Term in
let root =
let doc = "The location of the Speechcake repository" in
let env = Arg.env_var "DB_ROOT" ~doc in
Arg.(value & opt string "/tmp" & info ["root"] ~env ~docv:"ROOT" ~doc) in
let key =
let doc = "Key of the destination bucket" in
Arg.(value & pos 0 string "" & info [] ~docv:"KEY" ~doc) in
let doc = "List the versions of a tier that are stored in the repository"
in
( const persist $ setup $ root $ key
, info ~doc "persist"
)
let commit_t =
let open Term in
let root =
......@@ -213,9 +207,6 @@ let commit_t =
let key =
let doc = "Key of the destination bucket" in
Arg.(value & pos 0 string "" & info [] ~docv:"KEY" ~doc) in
let value =
let doc = "Value to commit" in
Arg.(required & pos 1 (some string) None & info [] ~docv:"VALUE" ~doc) in
let author =
let doc = "Name of the author" in
Arg.(value & opt string "Anonymous" & info [ "a"; "author" ] ~docv:"AUTHOR" ~doc) in
......@@ -223,7 +214,7 @@ let commit_t =
let doc = "Description of this version" in
Arg.(value & opt string "" & info [ "c"; "comment" ] ~docv:"COMMENT" ~doc) in
let doc = "Commit a value to the store" in
( const commit $ setup $ root $ key $ value $ author $ comment
( const commit $ setup $ root $ key $ author $ comment
, info ~doc "commit"
)
......@@ -291,7 +282,6 @@ let () =
[ uuid_t
; tiers_t; extract_t
; wrap_t
; persist_t
; commit_t
; tag_t
]
......@@ -180,22 +180,16 @@ module Data = struct
let open Decoders_yojson.Basic.Encode in
match t with
| Intervals is ->
obj
[ "type", string "intervals"
; "data", list Interval.to_json is
]
list value [ string "intervals" ; list Interval.to_json is ]
| Points ps ->
obj
[ "type", string "points"
; "data", list Point.to_json ps
]
list value [ string "points" ; list Point.to_json ps ]
let of_json =
let open Decoders_yojson.Basic.Decode in
let* typ = field "type" string in
match typ with
| "intervals" -> field "data" (list Interval.of_json) >|= of_intervals
| "points" -> field "data" (list Point.of_json) >|= of_points
let* tag = index 0 string in
match tag with
| "intervals" -> index 1 (list Interval.of_json) >|= of_intervals
| "points" -> index 1 (list Point.of_json) >|= of_points
| other -> fail ("invalid tag: " ^ other)
end
......@@ -322,16 +316,8 @@ let conflict_set ~old ~name_x x ~name_y y =
let to_json { name; bounds; data } =
let open Decoders_yojson.Basic.Encode in
let bounds_to_json (l, r) =
list value
[ string (Int64.to_string l)
; string (Int64.to_string r)
]
in
obj
[ "name", string name
; "bounds", bounds_to_json bounds
; "data", Data.to_json data
]
list value [ string (Int64.to_string l); string (Int64.to_string r) ] in
list value [ string name; bounds_to_json bounds; Data.to_json data ]
let of_json =
let open Decoders_yojson.Basic.Decode in
......@@ -339,9 +325,9 @@ let of_json =
let* l = index 0 string >|= Int64.of_string in
let+ r = index 1 string >|= Int64.of_string in
l, r in
let* name = field "name" string in
let* bounds = field "bounds" bounds_of_json in
let+ data = field "data" Data.of_json in
let* name = index 0 string in
let* bounds = index 1 bounds_of_json in
let+ data = index 2 Data.of_json in
of_data ~name ~bounds data
let has_conflict_markers tier =
......
......@@ -36,17 +36,17 @@ module Make (S : Stamp.S) = struct
let encoder { key; tags; data } =
let open Decoders_yojson.Basic.Encode in
obj
[ "key", list string key
; "tags", list string (Base.Set.to_list tags)
; "data", Annotation.Tier.to_json data
list value
[ list string key
; list string (Base.Set.to_list tags)
; Annotation.Tier.to_json data
]
let decoder =
let open Decoders_yojson.Basic.Decode in
let* key = field "key" (list string) in
let* tags = field "tags" (list string) >|= Base.Set.of_list (module Base.String) in
let+ data = field "data" Annotation.Tier.of_json in
let* key = index 0 (list string) in
let* tags = index 1 (list string) >|= Base.Set.of_list (module Base.String) in
let+ data = index 2 Annotation.Tier.of_json in
{ key; tags; data }
let diff ol nu =
......
......@@ -91,20 +91,20 @@ module Make (H : Hash.S) : S with module Hash = H = struct
let to_json { author; date; comment; parents } =
let open Decoders_yojson.Basic.Encode in
let ptr = fun p -> string (H.to_string p) in
obj
[ "author", string author
; "date", string date
; "comment", string comment
; "parents", list ptr parents
list value
[ string author
; string date
; string comment
; list ptr parents
]
let of_json =
let open Decoders_yojson.Basic.Decode in
let ptr = of_of_string ~msg:"pointer" H.of_string in
let* author = field "author" string in
let* date = field "date" string in
let* comment = field "comment" string in
let+ parents = field "parents" (list ptr) in
let* author = index 0 string in
let* date = index 1 string in
let* comment = index 2 string in
let+ parents = index 3 (list ptr) in
{ author; date; comment; parents }
let string_of_hash = Hash.to_string
......
......@@ -19,8 +19,8 @@ module Make (H : Hash.S) = struct
| Bool of bool
| Int of int
| Float of float
| Ptr of hash
| Head of [ `A | `L ] * hash option
| Head of hash
| Lstr of hash
| Sstr of string
[@@deriving eq]
......@@ -31,17 +31,9 @@ module Make (H : Hash.S) = struct
| Bool b -> pf ppf "b:%b" b
| Int i -> pf ppf "i:%d" i
| Float f -> pf ppf "f:%g" f
| Ptr h -> pf ppf "p:%a" H.pp h
| Head (`A, Some a) -> pf ppf "a:%a" H.pp a
| 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
| Some p -> H.feed_hash p
| None -> H.feed_string ""
| Head h -> pf ppf "l:%a" H.pp h
| Lstr h -> pf ppf "S:%a" H.pp h
| Sstr s -> pf ppf "s:%s" s
let hash_small t =
let open H in
......@@ -50,27 +42,24 @@ module Make (H : Hash.S) = struct
| 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
| Head h -> init ~tag:4L () |> feed_hash h |> finish
| Sstr s -> init ~tag:5L () |> feed_string s |> finish
| Lstr h -> init ~tag:6L () |> feed_hash h |> finish
type large =
| String of string
| Named of string * small
| Bottom of int * small array
| Intern of int * hash array
| Bottom of small array
| Intern of hash array
| Root of small
[@@deriving eq]
let pp_large ppf =
let open Fmt in
function
| String s -> pf ppf "s:%s" s
| Named (n, t) -> pf ppf "n:(%s, %a)" n pp_small t
| 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
| String s -> pf ppf "s:%s" s
| Bottom xs -> pf ppf "b:(%a)" (array pp_small) xs
| Intern xs -> pf ppf "i:(%a)" (array pp_hash) xs
| Root r -> pf ppf "r:%a" pp_small r
let hash_large b =
let open H in
......@@ -79,20 +68,13 @@ module Make (H : Hash.S) = struct
init ~tag:7L ()
|> feed_string s
|> finish
| Named (n, t) ->
| Bottom xs ->
init ~tag:8L ()
|> feed_string n
|> feed_hash (hash_small t)
|> feed_list feed_hash (Array.to_list xs |> Base.List.map ~f:hash_small)
|> finish
| Bottom (n, a) ->
| Intern xs ->
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)
|> feed_list feed_hash (Array.to_list xs)
|> finish
| Root root ->
hash_small root
......@@ -135,36 +117,20 @@ module Make (H : Hash.S) = struct
|> Base.List.filter_map ~f
let of_list (store : Store.t) (elts : small list) =
let bottom =
Base.List.chunks_of ~length:32 elts
let layer ~f xs =
Base.List.chunks_of ~length:32 xs
|> Base.List.map ~f:Array.of_list
|> Base.List.map ~f:(fun a -> Bottom (Array.length a, a))
|> Base.List.map ~f:(fun a -> f a)
|> Base.List.map ~f:(fun b -> Store.put store b)
in
let rec upper' xs =
let rec loop 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'
| [] -> Store.put store (Bottom [||])
| x :: [] -> x
| xs -> loop (layer xs ~f:(fun xs -> Intern xs))
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 elts =
if (List.length elts mod 2) = 1
then elts @ [ Empty ]
else elts in*)
let root = upper' bottom in
let bottom = layer elts ~f:(fun xs -> Bottom xs) in
let root = loop bottom in
root
let of_json (t : Store.t) (json : Yojson.Basic.t) =
......@@ -175,28 +141,27 @@ module Make (H : Hash.S) = struct
| `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
| `String s -> Lstr (Store.put t (String s))
| `Assoc _ ->
(*Base.List.sort kvs
~compare:(fun (k0, _) (k1, _) -> String.compare k0 k1)
|> Base.List.map ~f:(fun (k, v) ->
Ptr (Store.put t (Named (k, loop v))))
|> of_list t
|> (function
| Some hash -> Head (`A, Some hash)
| None -> Head (`A, None))
| None -> Head (`A, None))*)
failwith "key-value pairs not supported; use lists of pairs instead"
| `List xs ->
Base.List.map xs ~f:loop
|> of_list t
|> (function
| Some hash -> Head (`L, Some hash)
| None -> Head (`L, None))
|> fun h -> Head h
in
loop json
let rec hydrate_assoc (t : Store.t) root =
(*let rec hydrate_assoc (t : Store.t) root =
let rec loop root =
match Store.get t root with
| Some (Intern (_, a)) ->
......@@ -213,17 +178,17 @@ module Make (H : Hash.S) = struct
| None ->
failwith (Fmt.str "hydrate_assoc: nonexistent root")
in
loop root
loop root*)
and hydrate_list (t : Store.t) root =
let rec hydrate_list (t : Store.t) root =
let rec loop root =
match Store.get t root with
| Some (Intern (_, a)) ->
Array.to_list a
| Some (Intern xs) ->
Array.to_list xs
|> Base.List.map ~f:loop
|> Base.List.concat
| Some (Bottom (_, a)) ->
Array.to_list a
| Some (Bottom xs) ->
Array.to_list xs
|> Base.List.map ~f:(to_json t)
| Some (String s) -> [ `String s ]
| Some other ->
......@@ -238,23 +203,15 @@ module Make (H : Hash.S) = struct
| Bool b -> `Bool b
| Int i -> `Int i
| Float f -> `Float f
| Ptr p ->
Base.Option.value_exn ~message:"broken ptr" (Store.get t p)
|> block_to_json t
| Head (`A, Some root) -> `Assoc (hydrate_assoc t root)
| Head (`A, None) -> `Assoc []
| Head (`L, Some root) -> `List (hydrate_list t root)
| Head (`L, None) -> `List []
| Head root -> `List (hydrate_list t root)
| Lstr s ->
let l = Base.Option.value_exn (Store.get t s) in
begin match l with
| String s -> `String s
| _ -> failwith (Fmt.str "broken string pointer: %a" Hash.pp s)
end
| Sstr s -> `String s
and block_to_json (t : Store.t) blk =
match blk with
| String s -> `String s
| Named _ -> failwith "cannot encode named"
| Bottom _ -> failwith "cannot encode bottom"
| Intern _ -> failwith "cannot encode intern"
| Root r -> to_json t r
let get t k =
......@@ -279,7 +236,7 @@ module Make (H : Hash.S) = struct
open Decoders_yojson.Basic.Encode
let tagged tag elts =
list value (string tag :: elts)
list value (int tag :: elts)
let atom name =
string name
......@@ -293,20 +250,16 @@ module Make (H : Hash.S) = struct
| 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
| Head h -> tagged 1 [ ptr h ]
| Sstr s -> string s
| Lstr s -> tagged 2 [ ptr s ]
let store (s : Store.t) =
let block = function
| 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 ]
| String s -> tagged 1 [ string s ]
| Bottom xs -> tagged 2 [ array value xs ]
| Intern xs -> tagged 3 [ array ptr xs ]
| Root root -> tagged 4 [ value root ]
in
Core.Hashtbl.to_alist (Store.map s ~f:block)
|> Core.List.map ~f:(fun (k, v) -> H.to_string k, v)
......@@ -324,20 +277,18 @@ module Make (H : Hash.S) = struct
let value =
let simple =
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)
[ "bool", bool >|= (fun b -> Bool b)
; "int", int >|= (fun i -> Int i)
; "float", float >|= (fun f -> Float f)
; "null", null >|= (fun () -> Null)
; "sstr", string >|= (fun s -> Sstr s)
] in
let compound =
let* tag = index 0 string in
let* tag = index 0 int in
match tag with
| "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
| 1 -> map (fun l -> Head l) (index 1 ptr)
| 2 -> map (fun p -> Lstr p) (index 1 ptr)
| _ -> fail "not a known compound value" in
one_of
[ "simple", simple
; "compound", compound
......@@ -345,27 +296,13 @@ module Make (H : Hash.S) = struct
let store =
let block =
let* tag = index 0 string in
let* tag = index 0 int in
match tag with
| "str" ->
map (fun s -> String s) (index 1 string)
| "named" ->
let* n = index 1 string in
let* t = index 2 value in
succeed (Named (n, t))
| "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)
| _ ->
fail "not a block" in
| 1 -> index 1 string >|= fun s -> String s
| 2 -> index 1 (array value) >|= fun xs -> Bottom xs
| 3 -> index 1 (array ptr) >|= fun xs -> Intern xs
| 4 -> index 1 value >|= fun r -> Root r