Commit 9b881fdf authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

code compiles, but at what cost? (part II)

parent cc60f700
open Core
let src = Logs.Src.create "action" ~doc:"actions"
module Log = (val Logs.src_log src : Logs.LOG)
......@@ -20,8 +20,8 @@ let store_textgrid ~db ?author ?comment ?date ~tg_path ~key () =
in
match Annotation.Textgrid.Read.of_string contents with
| Ok tg ->
Ok (List.map ~f:(fun tier ->
let doc = Speechcake.document ~key tier in
Ok (Base.List.map ~f:(fun tier ->
let doc = Speechcake.Document.v ~key tier in
let uuid = Uuidm.v `V4 in
Speechcake.put db ?author ?comment ?date (Uuidm.to_string uuid) doc) tg)
| Error e ->
......@@ -32,15 +32,16 @@ let get_textgrid ~db ~tiers =
Speechcake.get_at_version db (Uuidm.to_string uuid) version_id
in
let tiers =
List.map tiers ~f:(fun (uuid, version) ->
let open Result.Monad_infix in
Base.List.map tiers ~f:(fun (uuid, version) ->
let open Base.Result.Monad_infix in
get_tier (uuid, version)
>>| fun doc ->
let name = List.last_exn doc.key in
let name = Base.List.last_exn doc.key in
let version = Speechcake.Database.VS.Hash.to_string version in
let info = Speechcake.Stamp.known ~uuid ~parents:[version] name in
let tier = Speechcake.stamp info doc.data in
let tier = Speechcake.Document.stamp info doc.data in
None, tier)
|> Result.combine_errors in
|> Base.Result.combine_errors in
match tiers with
| Ok tiers ->
Ok (Annotation.Textgrid.Write.to_string tiers)
......@@ -70,23 +71,23 @@ let info tg_path =
let versions ~db ~uuid =
let open Result.Monad_infix in
let open Base.Result.Monad_infix in
Speechcake.bucket db uuid
>>| Speechcake.Storage.versions
>>| Speechcake.Database.VS.versions
let add ~db ~tg_path ~key =
let name, _ = Filename.(split_extension (basename tg_path)) in
let name, _ = Core.Filename.(split_extension (basename tg_path)) in
let key = key @ [name] in
store_textgrid ~db ~tg_path ~key
let identify_textgrid ~db ~textgrid =
List.map textgrid ~f:(fun tier ->
Base.List.map textgrid ~f:(fun tier ->
let name = Annotation.Tier.name tier in
match Speechcake.unstamp tier with
match Speechcake.Document.unstamp tier with
| Ok Speechcake.Stamp.(Known { uuid; parents; _ }, tier) ->
if Annotation.Tier.has_conflict_markers tier then
name, Error (`Has_conflict_markers)
......@@ -95,82 +96,88 @@ let identify_textgrid ~db ~textgrid =
| [] ->
name, Error (`Missing_parent_info)
| [parent] ->
let parent = Base.Option.value_exn (Speechcake.Database.VS.Hash.of_string parent) in
let doc = Speechcake.get_at_version db (Uuidm.to_string uuid) parent in
let forbidden_branches =
Option.value_exn (Speechcake.Database.of_key db.db (Uuidm.to_string uuid))
|> Speechcake.Storage.tags
|> Hashtbl.keys in
name, Result.map doc ~f:(fun doc -> `Known (uuid, doc.key, parent, forbidden_branches))
Base.Option.value_exn (Speechcake.Database.of_key db.db (Uuidm.to_string uuid))
|> Speechcake.Database.VS.tags
|> Core.Hashtbl.keys in
name, Base.Result.map doc ~f:(fun doc -> `Known (uuid, doc.key, parent, forbidden_branches))
| parents -> (* multiple parents means we're in a merging process *)
name, Ok (`Conflict_resolution (uuid, parents))
name, Ok (`Conflict_resolution (uuid, Base.List.filter_map ~f:Speechcake.Database.VS.Hash.of_string parents))
end
| Ok (Fresh _, tier) ->
name, Ok (`Fresh (Speechcake.identify db tier))
| Error e ->
name, Error e)
name, Error (`Stamp_decoding_error e))
let put ~db ~tiers ~tier_name ~key =
Log.info (fun m -> m "put %s -> %s" tier_name (String.concat ~sep:"/" key)) ;
Log.info (fun m -> m "put %s -> %s" tier_name (Base.String.concat ~sep:"/" key)) ;
let tier =
List.find tiers
Base.List.find tiers
~f:(fun t -> String.equal tier_name (Annotation.Tier.name t)) in
match tier with
| Some tier ->
let uuid = Uuidm.v `V4 in
let doc = Speechcake.document ~key tier in
let doc = Speechcake.Document.v ~key tier in
Ok (uuid, Speechcake.put db ~parents:[] (Uuidm.to_string uuid) doc)
| None ->
Error (`Unknown_tier tier_name)
let most_recent_version bkt versions =
List.map versions ~f:(fun v -> Result.map (Speechcake.Storage.get bkt v) ~f:(fun d -> v, d))
|> List.filter_map ~f:Result.ok
|> List.dedup_and_sort ~compare:(fun (_, (_, x)) (_, (_, y)) ->
let x = ISO8601.Permissive.datetime x.Storage.Metadata.date in
let y = ISO8601.Permissive.datetime y.Storage.Metadata.date in
Float.compare x y)
|> List.rev
|> List.hd_exn
|> fun (hash, (json, meta)) ->
let doc = Speechcake.document_of_json json in
Result.map doc ~f:(fun doc -> hash, doc, meta)
Base.List.map versions ~f:(fun v -> Base.Result.map (Speechcake.Database.VS.get bkt v) ~f:(fun d -> v, d))
|> Base.List.filter_map ~f:Base.Result.ok
|> Base.List.dedup_and_sort ~compare:(fun (_, (_, x)) (_, (_, y)) ->
let open Speechcake.Database.VS.Metadata in
String.compare (date x) (date y))
|> 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 =
List.find tiers
Base.List.find tiers
~f:(fun t -> String.equal tier_name (Annotation.Tier.name t)) in
match tier with
| Some tier ->
let open Result.Monad_infix in
Speechcake.unstamp 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
~key:latest.Speechcake.key ~tags:latest.tags tier in
let doc = Speechcake.Document.v
~key:latest.Speechcake.Document.key ~tags:latest.tags tier in
Speechcake.put db key ~parents:[] ~tag: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
~key:most_recent_doc.Speechcake.key ~tags:most_recent_doc.tags tier in
Speechcake.put ~parents ~tag:branch db key doc
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 ~tags:most_recent_doc.tags tier in
Speechcake.put ~parents:parents' ~tag: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.stamp (info (Fmt.str "%s(1)" name)) tx in
let ty = Speechcake.stamp (info (Fmt.str "%s(2)" name)) ty 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)
| other -> other)
| 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)
......@@ -205,19 +212,19 @@ let rec has_prefix ~prefix key =
let has_one_of_tags ?tags doc_tags =
match tags with
| Some tags -> not (Set.are_disjoint tags doc_tags)
| Some tags -> not (Base.Set.are_disjoint tags doc_tags)
| None -> true
let list_tiers ?prefix ?tags db =
Log.info (fun m ->
m "list_tiers prefix=%a tags=%a"
Fmt.(option ~none:(any "(none)") (list ~sep:(any "/") string)) prefix
Fmt.(option ~none:(any "(none)") (list ~sep:(any ",@ ") string)) (Option.map ~f:Set.to_list tags)) ;
Fmt.(option ~none:(any "(none)") (list ~sep:(any ",@ ") string)) (Base.Option.map ~f:Base.Set.to_list tags)) ;
let key_index =
Speechcake.Database.list db.Speechcake.db
|> List.map ~f:(fun uuid ->
Result.map (Speechcake.get_latest db uuid) ~f:(fun doc -> uuid, doc))
|> List.bind ~f:(function
|> Base.List.map ~f:(fun uuid ->
Base.Result.map (Speechcake.get_latest db uuid) ~f:(fun doc -> uuid, doc))
|> Base.List.bind ~f:(function
| Ok doc ->
[ doc ]
| Error (`Decoding_error e) ->
......@@ -231,21 +238,21 @@ let list_tiers ?prefix ?tags db =
| Error (`Tag_not_found t) ->
Log.err (fun m -> m "tag not found: %s" t) ;
[]
| Error (`Not_a_version_block h) ->
Log.err (fun m -> m "not a version block: %08Lx" h) ;
| 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 (`Block_not_found b) ->
Log.err (fun m -> m "block not found: %08Lx" b) ;
| 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
|> List.filter ~f:(fun (_, (_, _, doc)) -> has_prefix ~prefix doc.Speechcake.key)
|> List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_tags ?tags doc.Speechcake.tags)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_prefix ~prefix doc.Speechcake.Document.key)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_tags ?tags doc.Speechcake.Document.tags)
| None ->
key_index
|> List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_tags ?tags doc.Speechcake.tags)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_tags ?tags doc.Speechcake.Document.tags)
(*
......
......@@ -20,35 +20,37 @@ let encode_tier_listing : (string * string list * (string, String.comparator_wit
])
|> fun tier_listing -> `List tier_listing
let encode_version_info { Speechcake.Storage.Metadata.author; comment; date; parents } =
let encode_version_info metadata =
let open Speechcake.Database.VS.Metadata in
`Assoc
[ "author", `String author
; "comment", `String comment
; "date", `String date
; "parents", `List (List.map parents ~f:(fun p -> `String (Fmt.str "%08Lx" p)))
[ "author", `String (author metadata)
; "comment", `String (comment metadata)
; "date", `String (date metadata)
; "parents", `List (Base.List.map (parents metadata) ~f:(fun p -> `String (string_of_hash p)))
]
let encode_version (hash, (info, branch_head)) =
match branch_head with
| Some branch_head ->
`Assoc
[ "id", `String (Fmt.str "%08Lx" hash)
[ "id", `String (Speechcake.Database.VS.Metadata.string_of_hash hash)
; "info", encode_version_info info
; "head", `String branch_head
]
| None ->
`Assoc
[ "id", `String (Fmt.str "%08Lx" hash)
[ "id", `String (Speechcake.Database.VS.Metadata.string_of_hash hash)
; "info", encode_version_info info
]
let encode_version_listing : (int64, (Speechcake.Storage.Metadata.t * string option)) Hashtbl.t encoder =
let encode_version_listing : (Speechcake.Database.VS.Metadata.hash, (Speechcake.Database.VS.Metadata.t * string option)) Hashtbl.t encoder =
fun versions ->
Hashtbl.to_alist versions
|> List.dedup_and_sort ~compare:(fun (_, (x, _)) (_, (y, _)) ->
Storage.Metadata.compare_date x y)
|> List.rev
|> List.map ~f:encode_version
Core.Hashtbl.to_alist versions
|> Base.List.dedup_and_sort ~compare:(fun (_, (x, _)) (_, (y, _)) ->
let dx, dy = Speechcake.Database.VS.Metadata.(date x, date y) in
String.compare dx dy)
|> Base.List.rev
|> Base.List.map ~f:encode_version
|> fun versions -> `List versions
......@@ -65,19 +67,24 @@ let encode_read_error =
type tier_info =
string * ([ `Fresh of
[ `Possibly_one_of of (string list * Uuidm.t * int * string list) list
| `Exactly of (Uuidm.t * int64 * string option) * (Storage.Metadata.t * Speechcake.document)
| `Exactly of (Uuidm.t * Speechcake.Database.VS.hash * string option) * (Speechcake.Database.VS.Metadata.t * Speechcake.Document.t)
]
| `Known of Uuidm.t * string list * int64 * string list
| `Conflict_resolution of Uuidm.t * int64 list
| `Known of Uuidm.t * string list * Speechcake.Database.VS.hash * string list
| `Conflict_resolution of Uuidm.t * Speechcake.Database.VS.hash list
],
[ `Invalid_UUID of string
| `Decoding_error of Decoders_yojson.Basic.Decode.error
| `Missing_block of int64
| `Not_a_version_block
| `Persistent_store_error of
[ `Block_not_found of Speechcake.Database.VS.hash
| `Not_a_root_block of Speechcake.Database.VS.hash
]
| `Missing_parent_info
| `Has_conflict_markers
| `Stamp_decoding_error of Speechcake.Stamp.error
]) Result.t
let encode_tier_info =
let encode_tier_match : (string list * Uuidm.t * int * string list) encoder =
let encode_tier_info : tier_info -> string * Yojson.Basic.t =
let encode_tier_match : (string list * Uuidm.t * int * string list) -> Yojson.Basic.t =
fun (key, uuid, percent, forbidden_branches) ->
`Assoc
[ "key", `List (List.map ~f:(fun part -> `String part) key)
......@@ -89,15 +96,15 @@ let encode_tier_info =
| name, Ok (`Fresh (`Possibly_one_of matches)) ->
name, `Assoc
[ "type", `String "fresh"
; "matches", `List (List.map matches ~f:encode_tier_match)
; "matches", `List (Base.List.map matches ~f:encode_tier_match)
]
| name, Ok (`Fresh (`Exactly ((uuid, version, branch), (meta, doc)))) ->
name, `Assoc
([ "type", `String "exactly"
; "uuid", `String (Uuidm.to_string uuid)
; "key", `List (List.map doc.Speechcake.key ~f:(fun part -> `String part))
; "key", `List (List.map doc.Speechcake.Document.key ~f:(fun part -> `String part))
; "version", `Assoc
[ "id", `String (Fmt.str "%08Lx" version)
[ "id", `String (Speechcake.Database.VS.Hash.to_string version)
; "meta", encode_version_info meta
]
] @ (Option.to_list (Option.map branch ~f:(fun b -> "branch", `String b))))
......@@ -106,14 +113,14 @@ let encode_tier_info =
[ "type", `String "known"
; "uuid", `String (Uuidm.to_string uuid)
; "key", `List (List.map key ~f:(fun part -> `String part))
; "version", `String (Fmt.str "%08Lx" version)
; "version", `String (Speechcake.Database.VS.Hash.to_string version)
; "forbiddenBranches", `List (List.map forbidden_branches ~f:(fun name -> `String name))
]
| name, Ok (`Conflict_resolution (uuid, versions)) ->
name, `Assoc
[ "type", `String "conflict-resolution"
; "uuid", `String (Uuidm.to_string uuid)
; "versions", `List (List.map ~f:(fun v -> `String (Fmt.str "%08Lx" v)) versions)
; "versions", `List (List.map ~f:(fun v -> `String (Speechcake.Database.VS.Hash.to_string v)) versions)
]
| name, Error (`Invalid_UUID uuid) ->
name, `Assoc
......@@ -125,15 +132,15 @@ let encode_tier_info =
[ "type", `String "error"
; "reason", `String (Fmt.str "decoding error: %s" (Decoders_yojson.Basic.Decode.string_of_error e))
]
| name, Error (`Block_not_found h) ->
| name, Error (`Persistent_store_error (`Block_not_found h)) ->
name, `Assoc
[ "type", `String "error"
; "reason", `String (Fmt.str "missing block: %08Lx" h)
; "reason", `String (Fmt.str "missing block: %a" Speechcake.Database.VS.Hash.pp h)
]
| name, Error (`Not_a_version_block h) ->
| name, Error (`Persistent_store_error (`Not_a_root_block h)) ->
name, `Assoc
[ "type", `String "error"
; "reason", `String (Fmt.str "not a version block: %08Lx" h)
; "reason", `String (Fmt.str "not a version block: %a" Speechcake.Database.VS.Hash.pp h)
]
| name, Error (`Missing_parent_info) ->
name, `Assoc
......@@ -145,6 +152,11 @@ let encode_tier_info =
[ "type", `String "error"
; "reason", `String "has conflict markers"
]
| name, Error (`Stamp_decoding_error _) ->
name, `Assoc
[ "type", `String "error"
; "reason", `String "stamp decoding failed"
]
......@@ -191,7 +203,7 @@ let decode_store_request : store_request decoder =
type tier_request =
{ name : string
; uuid : Uuidm.t
; version : int64
; version : Speechcake.Database.VS.hash
}
type textgrid_request = tier_request list
......@@ -200,9 +212,8 @@ let decode_uuid : Uuidm.t decoder =
let uuid_of_string s = Option.value_exn (Uuidm.of_string s) in
D.map uuid_of_string D.string
let decode_version : int64 decoder =
let int64_hex_of_string s = Int64.of_string ("0x" ^ s) in
D.map int64_hex_of_string D.string
let decode_version : Speechcake.Database.VS.hash decoder =
D.of_of_string ~msg:"pointer" Speechcake.Database.VS.Hash.of_string
let decode_tier_request : tier_request decoder =
let open D in
......
......@@ -33,7 +33,7 @@ let get_tiers db ?prefix request =
let tiers = Action.list_tiers ?prefix ?tags db in
let body =
tiers
|> List.map ~f:(fun (uuid, (_, _, doc)) -> uuid, doc.Speechcake.key, doc.Speechcake.tags)
|> List.map ~f:(fun (uuid, (_, _, doc)) -> uuid, doc.Speechcake.Document.key, doc.Speechcake.Document.tags)
|> C.encode_tier_listing
|> Yojson.Safe.to_string in
Dream.json body
......@@ -54,23 +54,23 @@ let get_versions db request =
| Error (`Invalid_UUID _) ->
Dream.respond ~status:`Not_Found ""
let get_history db _ =
(*let get_history db _ =
let history = Speechcake.history db in
let json = List.map history ~f:C.encode_version_info in
Dream.json (Yojson.Basic.to_string (`List json))
Dream.json (Yojson.Basic.to_string (`List json))*)
let list_branches db request =
let result =
let open Result.Monad_infix in
let uuid = Dream.param "uuid" request in
Speechcake.bucket db uuid
>>| Speechcake.Storage.tags in
>>| Speechcake.Database.VS.tags in
match result with
| Ok branches ->
let body =
Hashtbl.to_alist branches
|> List.map ~f:(fun (name, hash) ->
name, `String (Fmt.str "%08Lx" hash))
name, `String (Speechcake.Store.Hash.SHA256.to_string hash))
|> fun pairs -> `Assoc pairs
|> Yojson.Basic.to_string in
Dream.json body
......@@ -84,18 +84,20 @@ let get_tier db request =
let tag = Dream.param "tag" request in
Speechcake.bucket db uuid
>>= fun bucket ->
Ok (Hashtbl.to_alist (Speechcake.Storage.versions bucket))
>>= fun versions ->
Ok (Hashtbl.to_alist (Speechcake.Database.VS.tags bucket))
>>= fun branches ->
Speechcake.get_tagged db uuid ~tag
>>| fun tagged -> uuid, versions, tagged in
>>| fun tagged -> uuid, branches, tagged in
match result with
| Ok (uuid, versions, (_, _, tagged)) ->
| Ok (uuid, branches, (_, _, doc)) ->
let body =
`Assoc
[ "key", `List (List.map tagged.Speechcake.key ~f:(fun part -> `String part))
[ "key", `List (List.map doc.Speechcake.Document.key ~f:(fun part -> `String part))
; "uuid", `String uuid
; "tags", `List (List.map (Set.to_list tagged.tags) ~f:(fun tag -> `String tag))
; "versions", C.encode_version_listing (Hashtbl.of_alist_exn (module Int64) versions)
; "tags", `List (List.map (Set.to_list doc.tags) ~f:(fun tag -> `String tag))
(*; "versions", C.encode_version_listing (Core.Hashtbl.of_alist_exn (module Speechcake.Database.VS.Metadata.Hash) branches)*)
; "branches", `List (Base.List.map branches ~f:(fun (name, ptr) ->
`List [ `String name; `String (Speechcake.Database.VS.Metadata.string_of_hash ptr)]))
]
|> Yojson.Safe.to_string in
Dream.json body
......@@ -104,10 +106,10 @@ let get_tier db request =
Dream.respond ~status:`Not_Found ("document " ^ name)
| Error (`Tag_not_found tag) ->
Dream.respond ~status:`Not_Found ("tag " ^ tag)
| Error (`Block_not_found h) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "block not found: %08Lx" h)
| Error (`Not_a_version_block h) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "not a version block: %08Lx" h)
| Error (`Persistent_store_error (`Block_not_found h)) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "block not found: %a" Speechcake.Database.VS.Hash.pp h)
| Error (`Persistent_store_error (`Not_a_root_block h)) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "not a root block: %a" Speechcake.Database.VS.Hash.pp h)
| Error (`Decoding_error e) ->
Dream.respond ~status:`Bad_Request (Decoders_yojson.Basic.Decode.string_of_error e)
......@@ -130,7 +132,7 @@ let put_textgrid db request =
[ "tiers", `Assoc (List.map ~f:C.encode_tier_info tiers)
; "digest", `String hash
]
|> Yojson.Safe.to_string in
|> Yojson.Basic.to_string in
Dream.json body
| Error (`Parsing_error e) ->
Dream.respond ~status:`Bad_Request e
......@@ -157,6 +159,7 @@ let string_of_error = function
| `Conflict_textgrid _ -> Fmt.str "conflict (textgrid)"
| `Cannot_diff -> "cannot diff"
| `Diffing_points_and_intervals -> "diffing points and intervals"
| `Persistent_store_error _ -> "persistent store error"
let json_of_error =
let open Decoders_yojson.Basic.Encode in
......@@ -168,24 +171,20 @@ let json_of_error =
| `Unknown_version v -> obj [ "name", string "unknown version"; "which", string (Fmt.str "%016Lx" v) ]
| `Document_not_found u -> obj [ "name", string "document not found"; "which", string u ]
| `Decoding_error e -> obj [ "name", string "decoding error"; "reason", string (Decoders_yojson.Basic.Decode.string_of_error e) ]
| `Not_a_version_block h -> obj [ "name", string (Fmt.str "not a version block: %08Lx" h) ]
| `Stamp_decoding_error (`Invalid_UUID u) -> obj [ "name", string "stamp decoding error"; "reason", string ("invalid UUID: " ^ u) ]
| `Persistent_store_error (`Not_a_root_block h) ->
obj [ "name", string (Fmt.str "not a version block: %a" Speechcake.Database.VS.Hash.pp h) ]
| `Tag_not_found t -> obj [ "name", string "tag not found"; "which", string t ]
| `Block_not_found h -> obj [ "name", string "block not found"; "which", string (Fmt.str "%08Lx" h) ]
| `Persistent_store_error (`Block_not_found h) ->
obj [ "name", string "block not found"; "which", string (Speechcake.Database.VS.Hash.to_string h) ]
| `Conflict c -> obj [ "name", string "conflict"; "reason", string c ]
| `Intervals_overlap (x, y) ->
obj [ "name", string "intervals overlap"
; "x", Annotation.Interval.to_json x
; "y", Annotation.Interval.to_json y
]
| `Points_overlap (x, y) ->
obj [ "name", string "points overlap"
; "x", Annotation.Point.to_json x
; "y", Annotation.Point.to_json y
]
| `Merging_points_and_intervals -> obj [ "name", string "merging points and intervals" ]
| `Unimplemented u -> obj [ "name", string "unimplemented"; "what", string u ]
| `Invalid_UUID u -> obj [ "name", string "invalid UUID"; "which", string u ]
| `Conflict_set (tx, ty) ->
| `Merge_error (`Conflict field) ->
obj [ "name", string ("conflicting field: " ^ field) ]
| `Merge_error (`Merging_points_and_intervals) ->
obj [ "name", string "merging points and intervals" ]
| `Merge_error (`Conflict_set (tx, ty)) ->
obj [ "name", string "conflict set"
; "tx", Annotation.Tier.to_json tx
; "ty", Annotation.Tier.to_json ty
......@@ -233,7 +232,7 @@ let set_key db request =
let* key = Dream.body request in
match perform ~uuid ~tag (String.split ~on:'/' key) with
| Ok ver ->
Dream.respond ~status:`Created (Fmt.str "%08Lx" ver)
Dream.respond ~status:`Created (Speechcake.Database.VS.Hash.to_string ver)
| Error e ->
Dream.json ~status:`Internal_Server_Error (json_of_error e |> Yojson.Basic.to_string)
......@@ -262,7 +261,7 @@ let set_tags db request =
let result = Result.bind tags ~f:(perform ~uuid ~tag) in
match result with
| Ok ver ->
Dream.respond ~status:`Created (Fmt.str "%08Lx" ver)
Dream.respond ~status:`Created (Speechcake.Database.VS.Hash.to_string ver)
| Error e ->
Dream.json ~status:`Internal_Server_Error (json_of_error e |> Yojson.Basic.to_string)
......@@ -294,8 +293,8 @@ let store_tiers db request =
let* tiers = Action.read_textgrid ("/tmp/tg-" ^ hash) in
begin match tiers with
| Ok tiers ->
List.map ~f:(store_tier db ~tiers) actions
|> List.map ~f:(fun (name, res) ->
Base.List.map ~f:(store_tier db ~tiers) actions
|> Base.List.map ~f:(fun (name, res) ->
match res with
| Ok uuid -> name, `List [ `String "ok"; `String (Uuidm.to_string uuid) ]
| Error e -> name, `List [ `String "err"; json_of_error e ])
......@@ -335,7 +334,7 @@ let export_tier db request =
let tag = Dream.param "tag" request in
Speechcake.bucket db uuid
>>= fun bucket ->
Ok (Hashtbl.to_alist (Speechcake.Storage.versions bucket))