Commit 4cac190d authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

one last commit this year?

parent 846d4ab1
Pipeline #6302 canceled with stages
in 12 seconds
let src = Logs.Src.create "action" ~doc:"actions"
module Log = (val Logs.src_log src : Logs.LOG)
......@@ -13,7 +12,7 @@ let read_textgrid path =
let store_textgrid ~db ?author ?comment ?date ~tg_path ~key () =
let store_textgrid ~db ~info ~tg_path ~key () =
let open Lwt.Syntax in
let* in_channel = Lwt_io.(open_file ~mode:Input tg_path) in
let+ contents = Lwt_io.read in_channel
......@@ -21,10 +20,10 @@ let store_textgrid ~db ?author ?comment ?date ~tg_path ~key () =
match Annotation.Textgrid.Read.of_string contents with
| Ok tg ->
Ok (Base.List.map ~f:(fun tier ->
let data = Annotation.Tier.data tier in
let name, data = Annotation.Tier.(name tier, data tier) in
let doc = Speechcake.Document.v ~key:(key, name) data in
let uuid = Uuidm.v `V4 in
let info = Speechcake.Store.Info.v ?author ?comment ?date () in
Speechcake.put db ~info ~key uuid data) tg)
Speechcake.put db ~info ~parents:[] uuid doc) tg)
| Error e ->
Error [ e ]
......@@ -79,7 +78,7 @@ let identify_textgrid ~db ~textgrid =
let put ~db ~tiers ~tier_name ~key ~info ~branch =
(*let put ~db ~tiers ~tier_name ~key ~info ~branch =
Log.info (fun m -> m "put %s -> %s" tier_name (Base.String.concat ~sep:"/" key)) ;
let tier =
Base.List.find tiers
......@@ -91,63 +90,62 @@ let put ~db ~tiers ~tier_name ~key ~info ~branch =
Base.Result.map (Speechcake.put db ~info ~branch ~parents:[] uuid data)
~f:(fun hash -> uuid, hash)
| None ->
Error (`Unknown_tier tier_name)
(*let most_recent_version bkt versions =
Base.List.map versions ~f:(fun v -> Speechcake.Bucket.get bkt (`Version v))
|> Base.List.filter_map ~f:Base.Result.ok
|> Base.List.dedup_and_sort ~compare:(fun (_, x, _) (_, y, _) ->
String.compare (Info.date (Commit.info x)) (date y.info))
|> Base.List.rev
|> Base.List.hd_exn
|> fun (hash, (doc, meta)) ->
hash, doc, meta*)
let update ~db ~tiers ~tier_name ~uuid ~branch =
Log.info (fun m -> m "update %s -> %s" tier_name (Uuidm.to_string uuid)) ;
let tier =
Base.List.find tiers
~f:(fun t -> String.equal tier_name (Annotation.Tier.name t)) in
match tier with
| Some tier ->
let open Base.Result.Monad_infix in
Speechcake.Document.unstamp tier
|> Base.Result.map_error ~f:(fun e -> `Stamp_decoding_error e)
>>= fun (info, tier) ->
let key = Uuidm.to_string uuid in
begin match info with
| Fresh _name ->
Speechcake.get_latest db key
>>= fun (_, _, latest) ->
let doc = Speechcake.Document.v
~key:latest.Speechcake.Document.key ~labels:latest.labels tier in
Speechcake.put db key ~parents:[] ~branch doc
| Known { uuid; parents; name } ->
let parents' = Base.List.filter_map parents ~f:Speechcake.Database.VS.Hash.of_string in
Speechcake.bucket db (Uuidm.to_string uuid)
>>= fun bucket ->
most_recent_version bucket parents'
|> fun (_most_recent_version, most_recent_doc, _most_recent_meta) ->
let doc = Speechcake.Document.v
~key:most_recent_doc.Speechcake.Document.key ~labels:most_recent_doc.labels tier in
Speechcake.put ~parents:parents' ~branch db key doc
|> (function
| Ok hash -> Ok hash
| Error (`Conflict_set (tx, ty)) ->
let info = Speechcake.Stamp.known ~uuid ~parents in
let tx = Speechcake.Document.stamp (info (Fmt.str "%s(1)" name)) tx in
let ty = Speechcake.Document.stamp (info (Fmt.str "%s(2)" name)) ty in
let tg = Annotation.Textgrid.Write.to_string [ None, tx; None, ty ] in
Error (`Conflict_textgrid tg)
| Error `Illegal_move -> Error `Illegal_move
| Error (`Decoding_error e) -> Error (`Decoding_error e)
| Error (`Merge_error e) -> Error (`Merge_error e)
| Error (`Persistent_store_error e) -> Error (`Persistent_store_error e)
| Error (`Unimplemented e) -> Error (`Unimplemented e)
)
end
| None ->
Error (`Unknown_tier tier_name)
Error (`Unknown_tier tier_name)*)
module Result_syntax = struct
let ( let* ) x f = Base.Result.bind x ~f
let ( >>= ) x f = Base.Result.bind x ~f
let ( let+ ) x f = Base.Result.map x ~f
let ( >|= ) x f = Base.Result.map x ~f
end
let update ~info ~db ~tier ~uuid ~branch =
let open Result_syntax in
Log.info (fun m -> m "update %s" (Uuidm.to_string uuid)) ;
let* stamp, tier =
Speechcake.unstamp tier
|> Base.Result.map_error ~f:(fun e -> `Stamp_decoding_error e)
in
begin match stamp with
| Fresh _name ->
let* _, _, latest = Speechcake.get db uuid (`Head "latest") in
let doc =
Speechcake.Document.v
~labels:(Speechcake.Document.labels latest)
~key:(Speechcake.Document.key latest)
tier
in
begin match Speechcake.put db uuid ~info ~parents:[] ~branch doc with
| `Ok hash -> Ok (`Updated hash)
| `Key_conflict (x, y) -> Ok (`Key_conflict (x, y))
| `Manual_merge (x, y) -> Ok (`Manual_merge (x, y))
| `Error e -> Error e
end
| Known { uuid; parents; name } ->
let parents' =
Base.List.filter_map parents ~f:Speechcake.Hash.of_string in
let* _, _, doc =
Speechcake.get db uuid (`Version (Base.List.hd_exn parents')) in
let doc' =
Speechcake.Document.v
~labels:(Speechcake.Document.labels doc)
~key:(Speechcake.Document.key doc)
tier
in
begin match Speechcake.put db uuid ~info ~parents:parents' ~branch doc' with
| `Ok hash -> Ok (`Updated hash)
| `Manual_merge (tx, ty) ->
let info = Speechcake.Stamp.known ~uuid ~parents in
let tx = Speechcake.stamp tx (info (Fmt.str "%s(1)" name)) in
let ty = Speechcake.stamp ty (info (Fmt.str "%s(2)" name)) in
let tg = Annotation.Textgrid.Write.to_string [ None, tx; None, ty ] in
Error (`Conflict_textgrid tg)
| `Key_conflict (kx, ky) ->
Error (`Conflict_key (kx, ky))
| `Error e -> Error e
end
end
(*
let update_key ~repo_path ~tg_path ~tier_name ~key =
......@@ -188,39 +186,28 @@ let list_tiers ?prefix ?labels db =
Fmt.(option ~none:(any "(none)") (list ~sep:(any "/") string)) prefix
Fmt.(option ~none:(any "(none)") (list ~sep:(any ",@ ") string)) (Base.Option.map ~f:Base.Set.to_list labels)) ;
let key_index =
Speechcake.Database.list db.Speechcake.db
Speechcake.Database.list db
|> Base.List.map ~f:(fun uuid ->
Base.Result.map (Speechcake.get_latest db uuid) ~f:(fun doc -> uuid, doc))
Base.Result.map (Speechcake.get db uuid (`Head "main")) ~f:(fun doc -> uuid, doc))
|> Base.List.bind ~f:(function
| Ok doc ->
[ doc ]
| Error (`Decoding_error e)
| Error (`Persistent_store_error (`Decoding_error e))->
Log.err (fun m ->
m "decoding error: %s"
(Decoders_yojson.Basic.Decode.string_of_error e)) ;
[]
| Error (`Document_not_found n) ->
Log.err (fun m -> m "document not found: %s" n) ;
[]
| Error (`Tag_not_found t) ->
Log.err (fun m -> m "tag not found: %s" t) ;
[]
| Error (`Persistent_store_error (`Not_a_root_block h)) ->
Log.err (fun m -> m "not a root block: %a" Speechcake.Database.VS.Hash.pp h) ;
| Error e ->
Log.err (fun m -> m "%a" Speechcake.pp_error e);
[]
| Error (`Persistent_store_error (`Block_not_found b)) ->
Log.err (fun m -> m "block not found: %a" Speechcake.Database.VS.Hash.pp b) ;
[])
)
in
match prefix with
| Some prefix ->
key_index
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_prefix ~prefix doc.Speechcake.Document.key)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_labels ?labels doc.Speechcake.Document.labels)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) ->
has_prefix ~prefix (fst (Speechcake.Document.key doc)))
|> Base.List.filter ~f:(fun (_, (_, _, doc)) ->
has_one_of_labels ?labels (Speechcake.Document.labels doc))
| None ->
key_index
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_labels ?labels doc.Speechcake.Document.labels)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) ->
has_one_of_labels ?labels (Speechcake.Document.labels doc))
(*
......
......@@ -86,7 +86,7 @@ let wrap () key labels =
|> Decoders_yojson.Basic.Decode.decode_value Annotation.Tier.decoder in
match contents with
| Ok tier ->
let doc = Speechcake.Document.v ~key ~labels tier in
let doc = Speechcake.Document.v ~labels ~key 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)
......
......@@ -211,25 +211,28 @@ module Data = struct
Result.bind (intersperse' (module E) xs' ys')
~f:(intersperse' (module E) old')
(* TODO: separate in conflict and error -- errors are not recoverable! *)
type merge_error =
[ `Intervals_overlap of Interval.t * Interval.t
| `Points_overlap of Point.t * Point.t
| `Merging_points_and_intervals
[ `Merging_points_and_intervals
]
type conflict =
[ `Intervals of Interval.t * Interval.t
| `Points of Point.t * Point.t
]
let merge ~old x y =
let open Result.Monad_infix in
match old, x, y with
| Points old, Points px, Points py ->
merge' (module Point) ~old px py
|> Result.map_error
~f:(function `Overlap (a, b) -> `Points_overlap (a, b))
>>| fun points -> of_points points
begin match merge' (module Point) ~old px py with
| Ok merged -> Ok (Either.First (of_points merged))
| Error (`Overlap (a, b)) -> Ok (Either.Second (`Points (a, b)))
end
| Intervals old, Intervals ix, Intervals iy ->
merge' ~old (module Interval) ix iy
|> Result.map_error
~f:(function `Overlap (a, b) -> `Intervals_overlap (a, b))
>>| fun intervals -> of_intervals intervals
begin match merge' (module Interval) ~old ix iy with
| Ok merged -> Ok (Either.First (of_intervals merged))
| Error (`Overlap (a, b)) -> Ok (Either.Second (`Intervals (a, b)))
end
| _, _, _ ->
Error `Merging_points_and_intervals
......@@ -306,7 +309,11 @@ let pp =
; field "data" data Data.pp
]
type 'el error = [ `Overlap of 'el * 'el ]
type conflict =
[ `Intervals of Interval.t * Interval.t
| `Points of Point.t * Point.t
| `Name of string * string
]
......@@ -354,8 +361,32 @@ let diff_split x y =
let diff_seq x y =
Data.diff_seq x.data y.data
let merge ~name ~old x y =
Result.map (Data.merge ~old:old.data x.data y.data) ~f:(of_data ~name)
let merge ~old x y =
let data =
match Data.merge ~old:old.data x.data y.data with
| Ok (Either.First data) -> Ok (Either.First data)
| Ok (Second conflict) -> Ok (Second conflict)
| Error e -> Error e in
let name_x = Option.some_if (not (String.equal x.name old.name)) x.name in
let name_y = Option.some_if (not (String.equal y.name old.name)) y.name in
let name =
match name_x, name_y with
| Some name_x, Some name_y ->
Ok (Either.Second (`Name (name_x, name_y)))
| Some name_x, None ->
Ok (Either.First name_x)
| None, Some name_y ->
Ok (Either.First name_y)
| None, None ->
Ok (Either.First old.name) in
match name, data with
| Ok (Either.First name), Ok (Either.First data) ->
Ok (Either.First (of_data ~name data))
| Ok (Either.Second conflict), _ | _, Ok (Either.Second conflict) ->
Ok (Either.Second conflict)
| Error e, _ | _, Error e ->
Error e
let conflict_set ~old ~name_x x ~name_y y =
Result.map (Data.conflict_set ~old:old.data x.data y.data)
......
......@@ -42,19 +42,22 @@ module Data : sig
| `Interspersing_points_and_intervals
]) Result.t
type conflict =
[ `Intervals of Interval.t * Interval.t
| `Points of Point.t * Point.t
]
type merge_error =
[ `Intervals_overlap of Interval.t * Interval.t
| `Points_overlap of Point.t * Point.t
| `Merging_points_and_intervals
[ `Merging_points_and_intervals
]
val merge
: old:t -> t -> t
-> (t, [> merge_error ]) Result.t
-> ((t, conflict) Base.Either.t, [> merge_error ]) Result.t
val conflict_set
: old:t -> t -> t
-> (t * t, [> `Merging_points_and_intervals]) Result.t
-> (t * t, [> merge_error ]) Result.t
val has_conflict_markers : t -> bool
......@@ -66,7 +69,11 @@ end
type t
type 'el error = [ `Overlap of 'el * 'el ]
type conflict =
[ `Intervals of Interval.t * Interval.t
| `Points of Point.t * Point.t
| `Name of string * string
]
val name : t -> string
......@@ -125,8 +132,8 @@ val diff_seq
[> `Diffing_points_and_intervals ]) Result.t
val merge
: name:string -> old:t -> t -> t
-> (t, [> Data.merge_error ]) Result.t
: old:t -> t -> t
-> ((t, conflict) Base.Either.t, [> `Merging_points_and_intervals ]) Result.t
val conflict_set
: old:t
......
module Array = Base.Array
module Either = Base.Either
module Hashtbl = Base.Hashtbl
module List = Base.List
module Option = Base.Option
module Result = Base.Result
module Set = Base.Set
module Sexp = Base.Sexp
module String = Base.String
module Comparable = Base.Comparable
module Equal = Base.Equal
module Pretty_printer = Base.Pretty_printer
module Result_syntax = struct
let ( let* ) x f = Result.bind ~f x
let ( >>= ) x f = Result.bind ~f x
let ( let+ ) x f = Result.map ~f x
let ( >|= ) x f = Result.map ~f x
end
module Json = struct
module Decode = Decoders_yojson.Basic.Decode
module Encode = Decoders_yojson.Basic.Encode
type t = Yojson.Basic.t
type 'a decoder = 'a Decode.decoder
type 'a encoder = 'a Encode.encoder
let of_string = Yojson.Basic.from_string
let to_string = Yojson.Basic.to_string
let decode_string = Decode.decode_string
let decode_value = Decode.decode_value
end
module Jsonable = struct
module type S = sig
type t
val of_json : t Json.decoder
val to_json : t Json.encoder
end
end
(library
(name common)
(libraries base yojson decoders-yojson))
......@@ -3,10 +3,13 @@ module type S = sig
type t
type merge_error
val conflict_set : old:t -> t -> t -> (t * t, merge_error) Result.t
val conflict_set
: old:t -> t -> t
-> (t * t, merge_error) Result.t
include Store.Contents.S
with type t := t and type merge_error := merge_error
with type t := t
and type merge_error := merge_error
include Fingerprintable.S
with type t := t
......
open Common
include Database_intf
(* exported modules and module types *)
module type CONFIG = CONFIG
module Stamp = Stamp
module Contents = Contents
module Document = Document
module Info = Info
module Stamp = Stamp
let src = Logs.Src.create "storage" ~doc:"logs storage events"
......@@ -17,17 +22,17 @@ module Uuid = struct
include Uuidm
let sexp_of_t t =
Base.Sexp.Atom (Uuidm.to_string t)
Sexp.Atom (Uuidm.to_string t)
(*let t_of_sexp = function
| Base.Sexp.Atom a -> Base.Option.value_exn (Uuidm.of_string a)
| Base.Sexp.List _ -> failwith "not a Uuid"*)
let hash = Core.Hashtbl.hash
let hash = Hashtbl.hash
end
include T
include Base.Comparable.Make (T)
include Comparable.Make (T)
end
......@@ -45,7 +50,7 @@ module Make (C : Contents.S) (CFG : CONFIG) (H : Store.Hash.S) = struct
module Stamp = Stamp
module Document = Document.Make (C)
module Version_store = Store.Version_store.Make (Document) (H)
module Version_store = Store.Make (Document) (Info) (H)
type store = Version_store.t
type document = Document.t
......@@ -56,15 +61,15 @@ module Make (C : Contents.S) (CFG : CONFIG) (H : Store.Hash.S) = struct
type merge_error = Contents.merge_error
type t =
{ stores : (Uuid.t, store) Core.Hashtbl.t
; fingerprints : (Fingerprint.t, Uuid.t) Core.Hashtbl.t
{ stores : (Uuid.t, store) Hashtbl.t
; fingerprints : (Fingerprint.t, Uuid.t) Hashtbl.t
}
type error =
[ `Bucket_not_found of Uuidm.t
| `Commit_not_found of hash
| `Data_store_error of data_store_error
| `Decoding_error of Decoders_yojson.Basic.Decode.error
| `Decoding_error of Json.Decode.error
| `Head_not_found of string
| `Tag_not_found of string
]
......@@ -81,57 +86,76 @@ module Make (C : Contents.S) (CFG : CONFIG) (H : Store.Hash.S) = struct
(*let key b = Bucket.key b
let labels b = Bucket.labels b*)
let pp_error : error Fmt.t =
fun ppf -> function
| `Bucket_not_found uuid ->
Fmt.pf ppf "bucket not found: %a" Uuidm.pp uuid
| `Commit_not_found hash ->
Fmt.pf ppf "commit not found: %a" Hash.pp hash
| `Data_store_error err ->
Fmt.pf ppf "data store error: %s"
(Version_store.Data_store.string_of_error err)
| `Decoding_error err ->
Fmt.pf ppf "JSON decoding error: %s"
(Json.Decode.string_of_error err)
| `Head_not_found name ->
Fmt.pf ppf "head not found: %s" name
| `Tag_not_found name ->
Fmt.pf ppf "tag not found: %s" name
let string_of_error = Fmt.to_to_string pp_error
let pp : t Fmt.t =
fun ppf db ->
Core.Hashtbl.to_alist db.stores
Hashtbl.to_alist db.stores
|> Fmt.(list (pair ~sep:(any " -> ") Uuid.pp Version_store.pp) ppf)
let init () =
{ stores = Core.Hashtbl.create (module Uuid)
; fingerprints = Core.Hashtbl.create (module Fingerprint)
{ stores = Hashtbl.create (module Uuid)
; fingerprints = Hashtbl.create (module Fingerprint)
}
let keys t =
Core.Hashtbl.keys t.stores
let list t =
Hashtbl.keys t.stores
let of_uuid db u =
Core.Hashtbl.find (stores db) u
Hashtbl.find (stores db) u
|> Base.Result.of_option ~error:(`Bucket_not_found u)
let versions db u =
Base.Result.map (of_uuid db u) ~f:Version_store.versions
Result.map (of_uuid db u) ~f:Version_store.versions
let heads db u =
Base.Result.map (of_uuid db u) ~f:Version_store.heads
Result.map (of_uuid db u) ~f:Version_store.heads
let tags db u =
Base.Result.map (of_uuid db u) ~f:Version_store.tags
Result.map (of_uuid db u) ~f:Version_store.tags
let get (db : t) (u : Uuid.t) (v : pointer) : (hash * commit * document, [> error ]) Result.t =
let open Base.Result.Monad_infix in
of_uuid db u >>= fun store ->
let get db u v =
let open Result_syntax in
let* store = of_uuid db u in
match v with
| `Version hash ->
Version_store.version store hash
>>| fun (doc, commit) -> (hash, commit, doc)
>|= fun (doc, commit) -> (hash, commit, doc)
| `Head branch ->
Version_store.head store branch
>>= fun hash -> Version_store.version store hash
>>| fun (doc, commit) -> (hash, commit, doc)
>|= fun (doc, commit) -> (hash, commit, doc)
| `Tag name ->
Version_store.tag store name
>>= fun hash -> Version_store.version store hash
>>| fun (doc, commit) -> (hash, commit, doc)
>|= fun (doc, commit) -> (hash, commit, doc)
let checkout (db : t) tiers =
Base.List.map tiers
~f:(fun (uuid, req) ->
Base.Result.map (get db uuid req) ~f:(fun (hash, _, doc) ->
let stamp =
Stamp.known (Base.List.last_exn (Document.key doc))
~uuid ~parents:[ H.to_string hash ] in
C.stamp (Document.data doc) stamp))
let make_stamp uuid doc parents =
Stamp.known (snd (Document.key doc)) ~uuid ~parents in
let checkout_tier (uuid, req) =