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

merging now kinda works

parent d98aa7ea
module Data.StoreResponse exposing
( StoreResponse
( StoreResponse, StoreTierResult(..)
, decoder
)
......@@ -11,29 +11,32 @@ import Data.Uuid as Uuid exposing (Uuid)
type alias StoreResponse = Dict String (Result String Uuid)
type StoreTierResult
= Ok Uuid
| Merge String
| Err String
type alias StoreResponse = Dict String StoreTierResult
storeResultDecoder : Decoder (Result String Uuid)
storeResultDecoder =
errorDecoder : Decoder StoreTierResult
errorDecoder =
D.field "name" D.string
|> D.andThen (\name ->
case name of
"conflict textgrid" -> D.field "data" D.string |> D.map Merge
_ -> D.succeed <| Err name)
storeTierResultDecoder : Decoder StoreTierResult
storeTierResultDecoder =
D.index 0 D.string
|> D.andThen (\tag ->
case tag of
"ok" -> D.index 1 D.string |> D.map (Ok << Uuid.fromString)
"err" -> D.index 1 D.string |> D.map Err
"err" -> D.index 1 errorDecoder
other -> D.fail <| "unknown tag " ++ other)
decoder : Decoder StoreResponse
decoder =
D.dict storeResultDecoder
resultDecoder : Decoder (Result String String)
resultDecoder =
D.index 0 D.string
|> D.andThen (\tag ->
case tag of
"ok" -> D.map Ok <| D.index 1 D.string
"error" -> D.map Err <| D.index 1 D.string
other -> D.fail <| "unknown tag " ++ other)
D.dict storeTierResultDecoder
......@@ -21,7 +21,9 @@ type alias Match =
type TierInfo
= Known Uuid Key String
| Fresh (List Match)
| ConflictResolution Uuid (List String)
| Error String
| Merge String
type alias TextgridInfo =
{ tiers : Dict String TierInfo
......@@ -42,9 +44,16 @@ knownDecoder =
(D.field "key" Key.decoder)
(D.field "version" D.string)
conflictResolutionDecoder : Decoder TierInfo
conflictResolutionDecoder =
D.map2 ConflictResolution
(D.field "uuid" Uuid.decoder)
(D.field "versions" (D.list D.string))
errorDecoder : Decoder TierInfo
errorDecoder =
D.map Error (D.field "reason" D.string)
D.field "type" D.string
|> D.map Error
matchDecoder : Decoder Match
matchDecoder =
......@@ -56,7 +65,7 @@ matchDecoder =
decoder : Decoder TextgridInfo
decoder =
D.map2 TextgridInfo
(D.field "tiers" (D.map Dict.fromList tierInfoDecoder))
(D.field "tiers" (D.dict tierInfoDecoder))
(D.field "digest" D.string)
......@@ -68,4 +77,6 @@ tierInfoDecoder =
"fresh" -> freshDecoder
"known" -> knownDecoder
"error" -> errorDecoder
"conflict-resolution" -> conflictResolutionDecoder
other -> D.fail <| "unknown tag " ++ other)
......@@ -9,11 +9,12 @@ import Html.Attributes exposing (class, classList, href, placeholder, type_)
import Html.Events exposing (onClick, onInput, preventDefaultOn)
import File exposing (File)
import File.Download
import Http exposing (Progress)
import Json.Decode exposing (Decoder, at, map, oneOrMore, succeed)
import Data.Key as Key exposing (Key(..))
import Data.StoreResponse exposing (StoreResponse)
import Data.StoreResponse as StoreResponse exposing (StoreTierResult, StoreResponse)
import Data.StoreRequest exposing (StoreAction(..), StoreRequest)
import Data.TextgridInfo as TextgridInfo exposing (Match, TextgridInfo, TierInfo)
import Data.Uuid as Uuid exposing (Uuid(..))
......@@ -64,6 +65,7 @@ type Msg
| GotResult (Result Error StoreResponse)
| SetBase String
| Upload
| DownloadTextgrid String
......@@ -111,6 +113,12 @@ basesOfTierInfo tierInfo =
TextgridInfo.Error _ ->
Set.empty
TextgridInfo.ConflictResolution _ _ ->
Set.empty
TextgridInfo.Merge _ ->
Set.empty
gotTextgridInfo : TextgridInfo -> State
gotTextgridInfo { tiers, digest } =
let
......@@ -126,6 +134,11 @@ gotTextgridInfo { tiers, digest } =
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
DownloadTextgrid textgrid ->
( model
, File.Download.string "merge.stg" "text/plain" textgrid
)
GotFiles file files ->
( model
, Api.putTextgrid model.flags file GotTextgridInfo
......@@ -331,6 +344,8 @@ viewOptions bases ( name, ( tierInfo, maybeStoreAction ) ) =
div [ class "destination-selection" ]
[ div [ class "name" ] [ text name ]
, p [] [ text <| "Identified as " ++ (Key.toString key) ]
, button [ onClick <| InsertAction name (Just <| Overwrite { uuid = uuid, key = key, name = name }) ]
[ text "Store here" ]
]
TextgridInfo.Fresh matches ->
......@@ -357,6 +372,15 @@ viewOptions bases ( name, ( tierInfo, maybeStoreAction ) ) =
TextgridInfo.Error e ->
div [ class "error" ] [ text e ]
TextgridInfo.ConflictResolution uuid versions ->
div [ class "conflict-resolution" ] [ text "conflict-resolution" ]
TextgridInfo.Merge textgrid ->
div [ class "merge" ]
[ text "This tier needs manual merging."
, button [ onClick (DownloadTextgrid textgrid) ] [ text "Download" ]
]
viewProgress : Progress -> Html msg
viewProgress progress =
case progress of
......@@ -382,17 +406,23 @@ viewProgress progress =
, text <| "received: " ++ fractionReceived
]
viewStoreResult : ( String, Result String Uuid ) -> Html Msg
viewStoreResult : ( String, StoreTierResult ) -> Html Msg
viewStoreResult ( tierName, result ) =
case result of
Ok uuid ->
StoreResponse.Ok uuid ->
div [ class "result", class "successful" ]
[ text <| Uuid.toString uuid ]
Err e ->
StoreResponse.Err e ->
div [ class "result", class "failure" ]
[ text e ]
StoreResponse.Merge textgrid ->
div [ class "result", class "merge" ]
[ p [] [ text "Manual merge is needed." ]
, button [ onClick <| DownloadTextgrid textgrid ] [ text "Download" ]
]
viewHeader : Html Msg
viewHeader =
header []
......
......@@ -35,7 +35,7 @@ let get_textgrid ~db ~tiers =
get_tier (uuid, version)
>>| fun tier ->
let name = Annotation.Tier.name tier.data in
let info = Speechcake.Info.known ~uuid ~version name in
let info = Speechcake.Info.known ~uuid ~parents:[version] name in
let tier = Speechcake.stamp info tier.data in
None, tier)
|> Result.combine_errors in
......@@ -85,9 +85,19 @@ 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; version; _ }, _) ->
let doc = Speechcake.get_at_version db (Uuidm.to_string uuid) version in
name, Result.map doc ~f:(fun doc -> `Known (uuid, doc.key, version))
| Ok Speechcake.Info.(Known { uuid; parents; _ }, tier) ->
if Annotation.Tier.has_conflict_markers tier then
name, Error (`Has_conflict_markers)
else begin
match parents with
| [] ->
name, Error (`Missing_parent_info)
| [parent] ->
let doc = Speechcake.get_at_version db (Uuidm.to_string uuid) parent in
name, Result.map doc ~f:(fun doc -> `Known (uuid, doc.key, parent))
| parents -> (* multiple parents means we're in a merging process *)
name, Ok (`Conflict_resolution (uuid, parents))
end
| Ok (Fresh _, tier) ->
name, Ok (`Fresh (Speechcake.identify db tier))
| Error e ->
......@@ -103,10 +113,24 @@ let put ~db ~tiers ~tier_name ~key =
| Some tier ->
let uuid = Uuidm.v `V4 in
let doc = Speechcake.document ~key tier in
Ok (uuid, Speechcake.put db (Uuidm.to_string uuid) doc)
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.Bucket.version 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, (root, meta)) ->
let json = Speechcake.Storage.Bucket.to_json bkt root in
let doc = Speechcake.document_of_json json in
Result.map doc ~f:(fun doc -> hash, doc, meta)
let update ~db ~tiers ~tier_name ~uuid =
let tier =
List.find tiers
......@@ -114,16 +138,33 @@ let update ~db ~tiers ~tier_name ~uuid =
match tier with
| Some tier ->
let open Result.Monad_infix in
let key = Uuidm.to_string uuid in
Speechcake.get_latest db key
>>| fun (_, latest) ->
let doc =
Speechcake.document
~key:latest.Speechcake.key
~tags:latest.tags
tier
in
Speechcake.put db key doc
Speechcake.unstamp tier
>>= 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
Speechcake.put db key ~parents:[] doc
| Known { uuid; parents; name } ->
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 db key doc
|> (function
| Error (`Conflict_set (tx, ty)) ->
let info = Speechcake.Info.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
Error (`Conflict_textgrid tg)
| other -> other)
end
| None ->
Error (`Unknown_tier tier_name)
......@@ -161,7 +202,7 @@ let list_tiers ?prefix db =
|> List.map ~f:(fun uuid ->
Result.map (Speechcake.get_latest db uuid) ~f:(fun doc -> uuid, doc))
|> List.bind ~f:(function
| Ok doc -> Fmt.epr "ok %s@." (fst doc); [doc]
| Ok doc -> [doc]
| Error (`Decoding_error e) -> Fmt.epr "%s@." (Decoders_yojson.Basic.Decode.string_of_error e); []
| Error (`Document_not_found n) -> Fmt.epr "document not found: %s@." n; []
| Error (`Tag_not_found t) -> Fmt.epr "tag not found: %s@." t; []
......
......@@ -54,6 +54,7 @@ let encode_read_error =
type tier_info =
string * ([ `Fresh of (string list * Uuidm.t * int) list
| `Known of Uuidm.t * string list * int64
| `Conflict_resolution of Uuidm.t * int64 list
],
[ `Invalid_UUID of string
| `Decoding_error of Decoders_yojson.Basic.Decode.error
......@@ -82,6 +83,12 @@ let encode_tier_info =
; "key", `List (List.map key ~f:(fun part -> `String part))
; "version", `String (Fmt.str "%08Lx" version)
]
| 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)
]
| name, Error (`Invalid_UUID uuid) ->
name, `Assoc
[ "type", `String "error"
......@@ -102,6 +109,16 @@ let encode_tier_info =
[ "type", `String "error"
; "reason", `String (Fmt.str "not a version block")
]
| name, Error (`Missing_parent_info) ->
name, `Assoc
[ "type", `String "error"
; "reason", `String "missing parent info"
]
| name, Error (`Has_conflict_markers) ->
name, `Assoc
[ "type", `String "error"
; "reason", `String "has conflict markers"
]
......
......@@ -149,6 +149,52 @@ let string_of_error = function
| `Not_a_version_block -> Fmt.str "not a version block"
| `Tag_not_found t -> Fmt.str "tag not found: %s" t
| `Block_not_found h -> Fmt.str "block not found: %08Lx" h
| `Conflict c -> Fmt.str "conflict: %s" c
| `Intervals_overlap (x, y) -> Fmt.str "intervals overlap: %a, %a" Annotation.Interval.pp x Annotation.Interval.pp y
| `Points_overlap (x, y) -> Fmt.str "points overlap: %a, %a" Annotation.Point.pp x Annotation.Point.pp y
| `Merging_points_and_intervals -> Fmt.str "merging points and intervals"
| `Unimplemented u -> Fmt.str "unimplemented: %s" u
| `Invalid_UUID u -> Fmt.str "invalid UUID: %s" u
| `Conflict_set (_, _) -> Fmt.str "conflict (set)"
| `Conflict_textgrid _ -> Fmt.str "conflict (textgrid)"
let json_of_error =
let open Decoders_yojson.Basic.Encode in
function
| `Parsing_error e -> obj [ "name", string "parsing error"; "reason", string e ]
| `Empty_bucket u -> obj [ "name", string "empty bucket"; "which", string (Uuidm.to_string u) ]
| `Empty_tier -> obj [ "name", string "empty tier" ]
| `Unknown_tier n -> obj [ "name", string "unknown tier"; "which", string n ]
| `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) ]
| `Missing_block h -> obj [ "name", string "missing block"; "which", string (Fmt.str "%08Lx" h) ]
| `Not_a_version_block -> obj [ "name", string "not a version block" ]
| `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) ]
| `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) ->
obj [ "name", string "conflict set"
; "tx", Annotation.Tier.to_json tx
; "ty", Annotation.Tier.to_json ty
]
| `Conflict_textgrid tg ->
obj [ "name", string "conflict textgrid"
; "data", string tg
]
let store_tier db ~tiers request =
match request with
......@@ -175,7 +221,7 @@ let set_key db ~uuid ?(tag="latest") key =
let doc' = { doc with key } in
let comment =
Fmt.(str "move from `%a`" (list ~sep:(any "/") string) doc.key) in
Speechcake.put ~parent ~comment ~tag db uuid doc'
Speechcake.put ~parents:[parent] ~comment ~tag db uuid doc'
let combine_named_results l =
......@@ -193,7 +239,7 @@ let encode_action_result = function
| name, Error e ->
`Assoc
[ "name", `String name
; "result", `List [ `String "error"; `String (string_of_error e) ]
; "result", `List [ `String "error"; json_of_error e ]
]
let store_tiers db request =
......@@ -209,9 +255,9 @@ let store_tiers db request =
|> 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"; `String (string_of_error e) ])
| Error e -> name, `List [ `String "err"; json_of_error e ])
|> fun results -> `Assoc results
|> Yojson.Safe.to_string
|> Yojson.Basic.to_string
|> Dream.json ~status:(`Status 207)
| Error e ->
Dream.respond ~status:`Bad_Request (string_of_error e)
......
......@@ -29,6 +29,8 @@ module Interval = struct
let v ~l ~r text = (l, r), text
let with_text ((l, r), t) f = (l, r), f t
let pp =
let open Fmt in
pair ~sep:(any ": ")
......@@ -86,6 +88,8 @@ module Point = struct
let v ~off text = off, text
let with_text (o, t) f = o, f t
let pp = Fmt.(
pair ~sep:(any ":@ ") int64 (box string))
......
......@@ -9,6 +9,8 @@ module type S = sig
val to_json : t Decoders_yojson.Basic.Encode.encoder
val of_json : t Decoders_yojson.Basic.Decode.decoder
val with_text : t -> (string -> string) -> t
include Equal.S with type t := t
include Comparable.S with type t := t
include Pretty_printer.S with type t := t
......
......@@ -116,6 +116,25 @@ module Data = struct
in
loop xs ys []
let intersperse_conflict (type t) (module E : Element.S with type t = t) xs ys =
let mark_conflict elt =
E.with_text elt (fun s -> "###" ^ s ^ "###") in
let rec loop xs ys acc_x acc_y =
match xs, ys with
| [], [] -> List.rev acc_x, List.rev acc_y
| xs, [] -> List.rev_append acc_x xs, List.rev acc_y
| [], ys -> List.rev acc_x, List.rev_append acc_y ys
| x :: xs', y :: ys' when E.equal x y ->
loop xs' ys' (x :: acc_x) (y :: acc_y)
| x :: xs', y :: ys' when E.overlap x y ->
loop xs' ys' (mark_conflict x :: acc_x) (mark_conflict y :: acc_y)
| x :: xs', y :: ys' ->
if E.compare x y < 0
then loop xs' ys (x :: acc_x) acc_y
else loop xs ys' acc_x (y :: acc_y)
in
loop xs ys [] []
let merge (type t) (module E : Element.S with type t = t) ~old xs ys =
let xs', _, oldx = diff (module E) xs old in
let ys', _, oldy = diff (module E) ys old in
......@@ -124,6 +143,20 @@ module Data = struct
Result.bind (intersperse (module E) xs' ys')
~f:(intersperse (module E) old')
let intersperse_exn (type t) (module E : Element.S with type t = t) x y =
match intersperse (module E) x y with
| Ok xs -> xs
| Error _ -> failwith "intersperse_exn"
let conflict_set (type t) (module E : Element.S with type t = t) ~old xs ys =
let xs', _, oldx = diff (module E) xs old in
let ys', _, oldy = diff (module E) ys old in
let old' = intersect (module E) oldx oldy in
let xs', ys' = intersperse_conflict (module E) xs' ys' in
let xs' = intersperse_exn (module E) xs' old' in
let ys' = intersperse_exn (module E) ys' old' in
xs', ys'
let to_json t =
let open Decoders_yojson.Basic.Encode in
match t with
......@@ -250,6 +283,21 @@ let merge ~name ~old x y =
| _, _, _ ->
Error `Merging_points_and_intervals
let conflict_set ~old ~name_x x ~name_y y =
match old.data, x.data, y.data with
| Data.Points old, Data.Points px, Data.Points py ->
let px, py = Data.conflict_set (module Point) ~old px py in
let tx = of_points ~name:name_x px in
let ty = of_points ~name:name_y py in
Ok (tx, ty)
| Data.Intervals old, Data.Intervals ix, Data.Intervals iy ->
let ix, iy = Data.conflict_set ~old (module Interval) ix iy in
let tx = of_intervals ~name:name_x ix in
let ty = of_intervals ~name:name_y iy in
Ok (tx, ty)
| _, _, _ ->
Error `Merging_points_and_intervals
let to_json { name; bounds; data } =
let open Decoders_yojson.Basic.Encode in
let bounds_to_json (l, r) =
......@@ -275,3 +323,9 @@ let of_json =
let+ data = field "data" Data.of_json in
of_data ~name ~bounds data
let has_conflict_markers tier =
let texts = match data tier with
| Data.Intervals is -> List.map ~f:Interval.text is
| Data.Points ps -> List.map ~f:Point.text ps
in
List.exists texts ~f:(String.is_prefix ~prefix:"###")
......@@ -38,6 +38,11 @@ module Data : sig
-> old:'el list -> 'el list -> 'el list
-> ('el list, [ `Overlap of 'el * 'el ]) Result.t
val conflict_set
: (module Element.S with type t = 'el)
-> old:'el list -> 'el list -> 'el list
-> 'el list * 'el list
val to_json : t Decoders_yojson.Basic.Encode.encoder
val of_json : t Decoders_yojson.Basic.Decode.decoder
end
......@@ -106,8 +111,16 @@ val merge
| `Points_overlap of Point.t * Point.t
]) Result.t
val conflict_set
: old:t
-> name_x:string -> t
-> name_y:string -> t
-> (t * t, [> `Merging_points_and_intervals ]) Result.t
val to_json : t Decoders_yojson.Basic.Encode.encoder
val of_json : t Decoders_yojson.Basic.Decode.decoder
val has_conflict_markers : t -> bool
include Equal.S with type t := t
......@@ -9,16 +9,19 @@ module Info = struct
type known =
{ name : string
; uuid : Uuidm.t
; version : int64
; parents : int64 list
}
let equal_known x y =
String.equal x.name y.name &&
Uuidm.equal x.uuid y.uuid &&
Int64.equal x.version y.version
List.equal Int64.equal x.parents y.parents
let pp_known ppf { name; uuid; version } =
Fmt.pf ppf "known(%s, %a, %08Lx)" name Uuidm.pp uuid version
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
......@@ -27,21 +30,21 @@ module Info = struct
let to_string = function
| Fresh name ->
name
| Known { name; uuid; version } ->
| Known { name; uuid; parents } ->
String.concat ~sep:"@"
[ name
; Uuidm.to_string uuid
; Fmt.str "%08Lx" version
; List.map parents ~f:(Fmt.str "%08Lx") |> String.concat ~sep:","