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

stated cleanup; doesn't compile yet

parent 737c8aac
......@@ -37,7 +37,7 @@ let get_textgrid ~db ~tiers =
get_tier (uuid, version)
>>| fun doc ->
let name = List.last_exn doc.key in
let info = Speechcake.Info.known ~uuid ~parents:[version] name in
let info = Speechcake.Stamp.known ~uuid ~parents:[version] name in
let tier = Speechcake.stamp info doc.data in
None, tier)
|> Result.combine_errors in
......@@ -87,7 +87,7 @@ let identify_textgrid ~db ~textgrid =
List.map textgrid ~f:(fun tier ->
let name = Annotation.Tier.name tier in
match Speechcake.unstamp tier with
| Ok Speechcake.Info.(Known { uuid; parents; _ }, tier) ->
| Ok Speechcake.Stamp.(Known { uuid; parents; _ }, tier) ->
if Annotation.Tier.has_conflict_markers tier then
name, Error (`Has_conflict_markers)
else begin
......@@ -166,7 +166,7 @@ let update ~db ~tiers ~tier_name ~uuid ~branch =
Speechcake.put ~parents ~tag:branch db key doc
|> (function
| Error (`Conflict_set (tx, ty)) ->
let info = Speechcake.Info.known ~uuid ~parents in
let info = Speechcake.Stamp.known ~uuid ~parents in
let tx = Speechcake.stamp (info (Fmt.str "%s(1)" name)) tx in
let ty = Speechcake.stamp (info (Fmt.str "%s(2)" name)) ty in
let tg = Annotation.Textgrid.Write.to_string [ None, tx; None, ty ] in
......
(executables
(names konditorei tort)
(libraries
core
dream
ISO8601
yojson decoders-yojson
cmdliner
lwt lwt.unix
fpath digestif uuidm
logs logs.cli logs.fmt
fmt fmt.cli fmt.tty
speechcake)
(flags (:standards -cclib -static-pie)))
......@@ -353,7 +353,7 @@ let export_tier db request =
match result with
| Ok (uuid, _versions, (parent, latest)) ->
let info =
Speechcake.Info.known
Speechcake.Stamp.known
~uuid:(Option.value_exn (Uuidm.of_string uuid))
~parents:[parent]
(Annotation.Tier.name latest.data) in
......
open Core
let src = Logs.Src.create "storage" ~doc:"logs storage events"
module Log = (val Logs.src_log src : Logs.LOG)
type t = (string, Storage.t) Hashtbl.t
let pp : t Fmt.t =
fun ppf db ->
Hashtbl.to_alist db
|> Fmt.(list (pair ~sep:(any " -> ") string Storage.pp) ppf)
let init () =
Hashtbl.create (module String)
let list : t -> string list =
Hashtbl.keys
let of_key : t -> string -> Storage.t option =
fun db k ->
Hashtbl.find db k
let value : t -> string -> Storage.value -> Yojson.Basic.t option =
fun db k v ->
Option.map (of_key db k) ~f:(fun bkt -> Storage.Persistent_store.to_json (Storage.store bkt) v)
let version
: t -> string -> Storage.Persistent_store.hash
-> (Yojson.Basic.t,
[> `Persistent_store_not_found of string
| `Missing_block of Storage.Persistent_store.hash
| `Not_a_version_block
]
) Result.t
=
fun db k v ->
Log.info (fun m -> m "version %s %08Lx" k v) ;
match of_key db k with
| Some bkt ->
let open Result.Monad_infix in
Storage.version bkt v
>>| fun (root, _) -> Storage.Persistent_store.to_json (Storage.store bkt) root
| None ->
Error (`Persistent_store_not_found k)
let put ?author ?comment ?date ~parents ~tag ~merge db k v =
let open Result.Monad_infix in
let bkt = match of_key db k with
| Some b -> b
| None -> Storage.init () in
let data = Storage.Persistent_store.of_json (Storage.store bkt) v in
match parents, Storage.head bkt tag with
| _, None ->
(* fresh data / seeding *)
let info = Storage.Metadata.v ?author ?comment ?date ~parents:[] () in
let ver = Storage.commit bkt data ~info in
Storage.tag bkt tag ver ;
(*Log.info (fun m -> m "put %s %a => fresh %08Lx" k Persistent_store.pp_value data ver) ;*)
Ok (ver, bkt)
| [parent], Some head when Int64.equal parent head ->
(* parent version is the same as the head *)
let info = Storage.Metadata.v ?author ?comment ?date ~parents:[parent] () in
let ver = Storage.commit bkt data ~info in
Storage.tag bkt tag ver ;
(*Log.info (fun m -> m "put %s %a => fast-forward %08Lx" k Persistent_store.pp_value data ver) ;*)
Ok (ver, bkt)
| [parent'], Some head' ->
(* parent version is not head -> merge v with head using parent as old version *)
Storage.version bkt head'
>>= fun head -> Storage.version bkt parent'
>>= fun parent ->
merge ~old:(Storage.Persistent_store.to_json (Storage.store bkt) (fst parent))
(Storage.Persistent_store.to_json (Storage.store bkt) (fst head)) v
>>= fun merged ->
let info = Storage.Metadata.v ?author ?comment ?date ~parents:[ parent'; head' ] () in
let data = Storage.Persistent_store.of_json (Storage.store bkt) merged in
let ver = Storage.commit bkt data ~info in
Storage.tag bkt tag ver ;
(*Log.info (fun m -> m "put %s %a => merge %08Lx" k Persistent_store.pp_value data ver) ;*)
Ok (ver, bkt)
| [], Some _ ->
Error (`Unimplemented "Storage.put with no parent but existent head")
| px :: py :: parents', Some head' ->
let parents = px :: py :: parents' in
(* multiple parents means we're merging *)
if List.mem parents head' ~equal:Int64.equal then
let info = Storage.Metadata.v ?author ?comment ?date ~parents () in
let ver = Storage.commit bkt data ~info in
Storage.tag bkt tag ver ;
(*Log.info (fun m -> m "put %s %a => merged %08Lx" k Persistent_store.pp_value data ver) ;*)
Ok (ver, bkt)
else
Error (`Unimplemented "cannot commit to a branch when none of the members of the merge are the head of the branch")
let dump db path =
Hashtbl.to_alist db
|> List.iter ~f:(fun (uuid, bkt) ->
let data = Storage.dump bkt |> Yojson.Basic.to_string in
Out_channel.write_all (path ^ "/" ^ Uuidm.to_string uuid) ~data)
let load path =
Log.info Fmt.(fun m -> m "load: from path %a" (styled `Cyan string) path) ;
Sys.ls_dir path
|> List.map ~f:(fun filename ->
let path = path ^ "/" ^ filename in
Log.info Fmt.(fun m -> m "load: file %a" (styled `Cyan string) path) ;
let contents = In_channel.read_all path |> Yojson.Basic.from_string
in
match Storage.load contents with
| Ok doc -> Ok (filename, doc)
| Error e -> Error (`Decoding_error (filename, e)))
|> Result.combine_errors
|> Result.bind ~f:(fun kvs ->
match Hashtbl.of_alist (module String) kvs with
| `Ok ht -> Ok ht
| `Duplicate_key k -> Error [`Duplicate_key k])
open Base
module T = struct
type t = (Int.t, Int.comparator_witness) Base.Set.t
let pp ppf t =
Set.to_list t |> Fmt.(list int ppf)
let sexp_of_t t =
Sexp.List
(List.map (Set.to_list t) ~f:(fun x -> Sexp.Atom (Int.to_string x)))
let t_of_sexp = function
| Sexp.List elts ->
List.filter_map elts ~f:(function
| Sexp.Atom a -> Some (Int.of_string a)
| Sexp.List _ -> None)
|> Set.of_list (module Int)
| Sexp.Atom _ ->
failwith "not a Fingerprint"
let hash = Hashtbl.hash
let compare x y =
let x = Set.to_list x |> List.sort ~compare:Int.compare in
let y = Set.to_list y |> List.sort ~compare:Int.compare in
List.compare Int.compare x y
end
include T
include Comparable.Make (T)
let of_tier (n : int) (tier : Annotation.Tier.t) : t =
let open Annotation.Tier in
begin match data tier with
| Points ps -> List.map ~f:Hashtbl.hash ps
| Intervals is -> List.map ~f:Hashtbl.hash is
end
|> List.sort ~compare:Int.compare
|> List.rev
|> fun l -> List.take l n
|> Base.Set.of_list (module Int)
open Base
module T = struct
type t = string list
let pp = Fmt.(list ~sep:(any "/") string)
let sexp_of_t t = Sexp.List (List.map ~f:(fun a -> Sexp.Atom a) t)
let t_of_sexp = function
| Sexp.List elts ->
List.filter_map elts ~f:(function
| Sexp.Atom a -> Some a
| Sexp.List _ -> None)
| Sexp.Atom _ ->
failwith "not a Key"
let hash = Hashtbl.hash
let compare = List.compare String.compare
end
include T
include Comparable.Make (T)
......@@ -3,139 +3,24 @@ open Core
module Annotation = Annotation
module Storage = Storage
module Info = struct
type known =
{ name : string
; uuid : Uuidm.t
; parents : int64 list
}
let equal_known x y =
String.equal x.name y.name &&
Uuidm.equal x.uuid y.uuid &&
List.equal Int64.equal x.parents y.parents
let pp_parent ppf p =
Fmt.pf ppf "%08Lx" p
let pp_known ppf { name; uuid; parents } =
Fmt.(pf ppf "known(%s, %a, %a)" name Uuidm.pp uuid (list ~sep:(any ",") pp_parent) parents)
type t =
| Fresh of string
| Known of known
let to_string = function
| Fresh name ->
name
| Known { name; uuid; parents } ->
String.concat ~sep:"@"
[ name
; Uuidm.to_string uuid
; List.map parents ~f:(Fmt.str "%08Lx") |> String.concat ~sep:","
]
let of_string s =
let parts = String.split s ~on:'@' in
match parts with
| [ name; uuid; parents ] ->
let open Result.Monad_infix in
Uuidm.of_string uuid |> Result.of_option ~error:(`Invalid_UUID uuid)
>>| fun uuid -> String.split parents ~on:',' |> List.map ~f:(fun p -> Int64.of_string ("0x" ^ p))
|> fun parents -> Known { name; uuid; parents }
| name :: _ ->
Ok (Fresh name)
| [] ->
Ok (Fresh s)
let equal x y =
match x, y with
| Fresh x, Fresh y -> String.equal x y
| Known x, Known y -> equal_known x y
| _ -> false
let pp ppf = function
| Fresh n -> Fmt.pf ppf "%s" n
| Known k -> pp_known ppf k
let fresh name = Fresh name
let known ~uuid ~parents name = Known { name; uuid; parents }
let name = function
| Fresh name -> name
| Known { name; _ } -> name
let uuid = function
| Fresh _ -> None
| Known { uuid; _ } -> Some uuid
let parents = function
| Fresh _ -> None
| Known { parents; _ } -> Some parents
let to_json t =
let open Decoders_yojson.Basic.Encode in
match t with
| Fresh name ->
list value [ string "fresh"; string name ]
| Known { name; parents; uuid } ->
list value
[ string "known"
; string name
; list string (List.map parents ~f:(fun p -> Fmt.str "%08Lx" p))
; string (Uuidm.to_string uuid)
]
let of_json =
let open Decoders_yojson.Basic.Decode in
let fresh_of_json =
let+ name = index 1 string in
Fresh name in
let known_of_json =
let* name = index 1 string in
let* parents = index 2 (list string) >|= List.map ~f:(fun s -> Int64.of_string ("0x" ^ s)) in
let* uuid = index 3 string in
match Uuidm.of_string uuid with
| Some uuid -> succeed (Known { name; parents; uuid })
| None -> fail "invalid UUID" in
let* tag = index 0 string in
match tag with
| "fresh" -> fresh_of_json
| "known" -> known_of_json
| other -> failwith ("unknown tag " ^ other)
end
let stamp : Info.t -> Annotation.tier -> Annotation.tier =
fun info tier ->
Annotation.Tier.with_name tier ~name:(Info.to_string info)
let unstamp (tier : Annotation.tier) =
let open Result.Monad_infix in
Info.of_string (Annotation.Tier.name tier)
>>| fun info ->
info, Annotation.Tier.with_name tier ~name:(Info.name info)
module Database = Database
module Stamp =
Stamp.Make (Decoders_yojson.Basic.Encode) (Decoders_yojson.Basic.Decode)
module Uuid = struct
module T = struct
include Uuidm
let sexp_of_t t = Sexp.Atom (Uuidm.to_string t)
let t_of_sexp = function
| Sexp.Atom a -> Option.value_exn (Uuidm.of_string a)
| Sexp.List _ -> failwith "not a Uuid"
let hash = Hashtbl.hash
end
let stamp : Stamp.t -> Annotation.tier -> Annotation.tier =
fun info tier ->
Annotation.Tier.with_name tier ~name:(Stamp.to_string info)
include T
include Comparable.Make (T)
end
let unstamp (tier : Annotation.tier) =
let open Result.Monad_infix in
Stamp.of_string (Annotation.Tier.name tier)
>>| fun info ->
info, Annotation.Tier.with_name tier ~name:(Stamp.name info)
......@@ -175,76 +60,9 @@ let document_of_json json =
|> Result.map_error ~f:(fun e -> `Decoding_error e)
module Key = struct
module T = struct
type t = string list
let pp = Fmt.(list ~sep:(any "/") string)
let sexp_of_t t = Sexp.List (List.map ~f:(fun a -> Sexp.Atom a) t)
let t_of_sexp = function
| Sexp.List elts ->
List.filter_map elts ~f:(function
| Sexp.Atom a -> Some a
| Sexp.List _ -> None)
| Sexp.Atom _ ->
failwith "not a Key"
let hash = Hashtbl.hash
let compare = List.compare String.compare
end
include T
include Comparable.Make (T)
end
module Fingerprint = struct
module T = struct
type t = (Int.t, Int.comparator_witness) Base.Set.t
let pp ppf t =
Set.to_list t |> Fmt.(list int ppf)
let sexp_of_t t =
Sexp.List
(List.map (Set.to_list t) ~f:(fun x -> Sexp.Atom (Int.to_string x)))
let t_of_sexp = function
| Sexp.List elts ->
List.filter_map elts ~f:(function
| Sexp.Atom a -> Some (Int.of_string a)
| Sexp.List _ -> None)
|> Set.of_list (module Int)
| Sexp.Atom _ ->
failwith "not a Fingerprint"
let hash = Hashtbl.hash
let compare x y =
let x = Set.to_list x |> List.sort ~compare:Int.compare in
let y = Set.to_list y |> List.sort ~compare:Int.compare in
List.compare Int.compare x y
end
include T
include Comparable.Make (T)
let of_tier (n : int) (tier : Annotation.Tier.t) : t =
let open Annotation.Tier in
begin match data tier with
| Points ps -> List.map ~f:Hashtbl.hash ps
| Intervals is -> List.map ~f:Hashtbl.hash is
end
|> List.sort ~compare:Int.compare
|> List.rev
|> fun l -> List.take l n
|> Base.Set.of_list (module Int)
end
type t =
{ storage : Storage.db
{ storage : Storage.t
; key_index : (Key.t, Uuid.t) Hashtbl.t
; fingerprint_index : (Fingerprint.t, Uuid.t) Hashtbl.t
; tag_index : (string, (Uuid.t, Uuid.comparator_witness) Set.t) Hashtbl.t
......@@ -254,10 +72,10 @@ type t =
let fingerprint_size = 25
let history t =
Storage.list t.storage
|> List.filter_map ~f:(Storage.bucket t.storage)
Database.list t
|> List.filter_map ~f:(Database.of_key t)
|> List.bind ~f:(fun b ->
Storage.Bucket.versions b
Storage.versions b
|> Hashtbl.to_alist
|> List.map ~f:snd)
|> List.map ~f:(fun (_, meta, _) -> meta)
......@@ -276,13 +94,13 @@ let update_tag_index ti uuid tags =
| Some uuids -> Set.add uuids uuid
| None -> Set.singleton (module Uuid) uuid))
let of_storage ?path storage =
let of_storage ?path (storage : Storage.t) =
let open Result.Monad_infix in
let keys = Storage.list storage in
let keys = Database.list storage in
let documents =
List.map keys ~f:(fun k ->
Hashtbl.find_exn storage k
|> fun bucket -> Storage.Bucket.tagged bucket "latest"
Database.of_key storage k
|> fun store -> Storage.tagged (Option.value_exn store) "latest"
>>= fun (_ver, json) -> document_of_json json
>>| fun doc -> k, doc)
|> List.filter_map ~f:Result.ok in
......@@ -304,7 +122,6 @@ let of_storage ?path storage =
|> Result.of_option ~error:(`Invalid_UUID key)
>>| fun uuid ->
update_tag_index tag_index uuid doc.tags)
in
{ storage ; key_index ; fingerprint_index ; tag_index ; path }
......@@ -335,7 +152,7 @@ let load path =
Storage.load path >>| of_storage ~path
let bucket db k =
match Storage.bucket db.storage k with
match Storage.store db.storage k with
| Some doc -> Ok doc
| None -> Error (`Document_not_found k)
......@@ -343,7 +160,7 @@ let get_tagged db (k : string) ~tag =
let open Result.Monad_infix in
Hashtbl.find db.storage k
|> Result.of_option ~error:(`Document_not_found k)
>>= fun bucket -> Storage.Bucket.tagged bucket tag
>>= fun store -> Storage.Persistent_store.tagged store tag
>>= fun (ver, json) -> document_of_json json
>>| fun doc -> ver, doc
......@@ -353,8 +170,8 @@ let get_latest db k =
let get_at_version db k ver =
let open Result.Monad_infix in
let bkt = Hashtbl.find_exn db.storage k in
Storage.Bucket.version bkt ver
>>= fun (root, _) -> Ok (Storage.Bucket.to_json bkt root)
Storage.Persistent_store.version bkt ver
>>= fun (root, _) -> Ok (Storage.Persistent_store.to_json bkt root)
>>= document_of_json
......@@ -369,7 +186,7 @@ let mem db k =
let call_if_exists db k ~tag f =
let open Result.Monad_infix in
match Storage.bucket db.storage k with
match Storage.store db.storage k with
| Some bkt ->
(Storage.Bucket.tagged bkt tag
>>= fun (_, json) -> document_of_json json
......@@ -438,7 +255,7 @@ let put ?author ?comment ?date ~parents ?(tag="latest") db k v =
let open Result.Monad_infix in
let key = v.key in
let fingerprint = Fingerprint.of_tier fingerprint_size v.data in
Storage.put ?author ?comment ?date ~parents ~tag ~merge db.storage k (document_to_json v)
Database.put ?author ?comment ?date ~parents ~tag ~merge db k (document_to_json v)
>>| fun (version, bucket) ->
Hashtbl.set db.storage ~key:k ~data:bucket ;
call_if_exists db k ~tag (fun old -> Hashtbl.remove db.key_index old.key) ;
......
open Base
module Make
(E : Decoders.Encode.S)
(D : Decoders.Decode.S with type value = E.value)
= struct
type known =
{ name : string
; uuid : Uuidm.t
; parents : int64 list
}
let equal_known x y =
String.equal x.name y.name &&
Uuidm.equal x.uuid y.uuid &&
List.equal Int64.equal x.parents y.parents
let pp_parent ppf p =
Fmt.pf ppf "%08Lx" p
let pp_known ppf { name; uuid; parents } =
Fmt.(pf ppf "known(%s, %a, %a)" name Uuidm.pp uuid (list ~sep:(any ",") pp_parent) parents)
type t =
| Fresh of string
| Known of known
let to_string = function
| Fresh name ->
name
| Known { name; uuid; parents } ->