Something went wrong. Try again.
Git-native issue tracker
Something went wrong. Try again.
10 kB · 292 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293open Cmdlineropen Common
(* What [tk operator finding] files, as its options give it. *)type finding = { key : string; family_prefix : string option; title : string; kind : string; priority : int; priority_reason : string option; labels : string list; packages : string list; checks : string list; body_file : string option; comment_file : string option; comment_id : string option; comment_at : string option;}
let finding key family_prefix title kind priority priority_reason labels packages checks body_file comment_file comment_id comment_at = { key; family_prefix; title; kind; priority; priority_reason; labels; packages; checks; body_file; comment_file; comment_id; comment_at; }
(* [in_family prefix key] is [true] iff [key] is [prefix] or under [prefix:]. *)let in_family prefix key = String.equal key prefix || String.starts_with ~prefix:(prefix ^ ":") key
let validate f = if f.priority < 0 || f.priority > 4 then Error "priority must be from 0 to 4" else if f.priority <> 2 && Option.is_none f.priority_reason then Error "a changed finding priority needs --priority-reason" else if Option.fold ~none:false ~some:(fun prefix -> String.trim prefix = "" || not (in_family prefix f.key)) f.family_prefix then Error "finding key is outside its family prefix" else Ok ()
let read_file what path = try Ok (In_channel.with_open_bin path In_channel.input_all) with Sys_error message -> Error (what ^ ": " ^ message)
let read_body f = match f.body_file with | None -> Ok None | Some path -> Result.map Option.some (read_file "body file" path)
let read_comment f = match (f.comment_file, f.comment_id, f.comment_at) with | None, None, None -> Ok None | Some path, Some id, Some at -> Result.map (fun text -> Some (id, at, text)) (read_file "comment file" path) | _ -> Error "comment-file, comment-id and comment-at are required together"
let is_closed row = Tracker.Core.Row.status row = Tracker.Core.Closed
(* The key a new occurrence joins: a closed row's own key is filed again, and otherwise the one live finding of the family, if there is one. *)let joined_key f rows = let closed_with_key row = Option.equal String.equal (Tracker.Core.Row.external_ref row) (Some f.key) && is_closed row in if List.exists closed_with_key rows then Ok f.key else match f.family_prefix with | None -> Ok f.key | Some prefix -> ( let live row = (not (is_closed row)) && Option.fold ~none:false ~some:(in_family prefix) (Tracker.Core.Row.external_ref row) in match List.filter live rows with | [] -> Ok f.key | [ row ] -> Option.to_result ~none:"active finding has no external ref" (Tracker.Core.Row.external_ref row) | _ -> Error ("more than one active finding uses " ^ prefix))
(* A row filed now takes the finding's kind, labels and priority. *)let first_filing f row = let row = row |> Tracker.Core.Row.with_kind f.kind |> Tracker.Core.Row.with_labels f.labels in match f.priority_reason with | None -> row | Some reason -> Tracker.Core.Row.with_priority ~reason f.priority row
let folder_of id = Store.row_path id |> List.rev |> List.tl |> List.rev
let existing_view ~repo ~(before : Store.snapshot) id = let* view = Tracker.Store_tree.row_view ~repo ~tree:before.tree ~id in Option.to_result ~none:("row " ^ id ^ " is missing") view
(* A new row gets the body; a row filed before must hold the same one. *)let body_edits ~repo ~before ~key ~id ~previous ~row body = match (previous, body) with | None, Some text when text <> "" -> Ok [ Store.Put (folder_of id @ [ "body.md" ], text) ] | None, _ | Some _, None -> Ok [] | Some _, Some text -> let* view = existing_view ~repo ~before id in if is_closed row || Option.equal String.equal view.body body || String.equal text "" then Ok [] else Error ("finding body differs for " ^ key)
(* The named report goes under the row once; a replay with other content is refused. A closed row takes no report. *)let comment_edits ~repo ~before ~actor ~id ~previous ~row = function | None -> Ok [] | Some _ when is_closed row -> Ok [] | Some (comment_id, at, text) -> ( let* comment = Tracker.Comment.v ~id:comment_id ~author:(Git.User.name actor) ~created_at:at ~body:text in let* existing = match previous with | None -> Ok [] | Some _ -> let* view = existing_view ~repo ~before id in Ok view.comments in match List.find_opt (fun old -> String.equal (Tracker.Comment.id old) comment_id) existing with | None -> Ok [ Store.Put ( folder_of id @ [ "comments"; Tracker.Comment.filename comment ], Tracker.Comment.to_blob comment ); ] | Some old when String.equal (Tracker.Comment.body old) (Tracker.Comment.body comment) -> Ok [] | Some _ -> Error ("comment ID " ^ comment_id ^ " already has different content"))
let row_edits ~schema ~id ~previous row = if Option.equal Tracker.Core.Row.equal previous (Some row) then Ok [] else let* encoded = Tracker.Row_json.to_string ~schema row in Ok [ Store.Put (Store.row_path id, encoded) ]
let finding_edits ~repo ~actor ~chosen ~body ~comment f (before : Store.snapshot) = let* snapshot = Tracker.Store_tree.load_tree ~repo ~tree:before.tree in let candidate = Tracker.Store_tree.candidate snapshot in let schema = Tracker.Schema_candidate.schema candidate in let rows = Tracker.Schema_candidate.rows candidate in let* key = joined_key f rows in let* config = Tracker.Config.of_tree ~repo ~tree:before.tree in let checks = List.map (fun name -> Tracker.Core.Check.Case { arm = "mq"; name }) f.checks in let* next, id = Tracker.Hook_transition.file_finding ~prefix:(Tracker.Config.prefix config) ~key ~title:f.title ~packages:f.packages ~checks ~at:(now_utc ()) rows in chosen := Some (id, key); let has_id row = String.equal (Tracker.Core.Row.id row) id in let previous = List.find_opt has_id rows in let row = List.find has_id next in let row = if Option.is_some previous then row else first_filing f row in let* row_edits = row_edits ~schema ~id ~previous row in let* body_edits = body_edits ~repo ~before ~key ~id ~previous ~row body in let* comment_edits = comment_edits ~repo ~before ~actor ~id ~previous ~row comment in Ok (row_edits @ body_edits @ comment_edits)
(* The row the transaction filed; one that changed nothing is a replay when the authority still holds the key on the same row. *)let filed_id ~sw ~fs ~net ~mono ~repo ~remote result chosen = match (result, chosen) with | Ok _, Some (id, _) -> Ok id | ( Error (Store.Refused "tracker operation changes no canonical file"), Some (id, key) ) -> let* current = Store.sync_remote_checked ~sw ~fs ~net ~mono ~repo ~remote in let* found = failed (Index.with_read ~sw ~fs ~repo ~tree:current.tree (fun db -> Index.external_ref_id ~db ~tree:current.tree key)) in if Option.equal String.equal found (Some id) then Ok id else Error (Store.Refused ("finding key changed during replay: " ^ key)) | Error failure, _ -> Error failure | Ok _, None -> Error (Store.Failed "finding transaction returned no row")
let operator_finding root authority json f = run_write @@ fun ~sw ~fs ~net ~mono -> let* () = refused (validate f) in let* body = refused (read_body f) in let* comment = refused (read_comment f) in let* store, repo, remote, actor = failed ( with_store ~sw ~fs ~root @@ fun ~store ~repo ~commit:_ ~tree -> let* url = configured_authority ~repo ~tree authority in let* remote = remote_of_url ~fs ~net url in let* _, actor = checkout_actor ~sw ~fs root in Ok (store, repo, remote, actor) ) in let chosen = ref None in let result = Store.transact_authority_checked ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message:("tk operator finding " ^ f.key) ~change:(finding_edits ~repo ~actor ~chosen ~body ~comment f) in let* id = filed_id ~sw ~fs ~net ~mono ~repo ~remote result !chosen in Fmt.epr "tracker: %a@." Fpath.pp store; if json then Fmt.pr "%s@." (Json.Value.to_string (Json.object' [ field "id" (Json.string id) ])) else Fmt.pr "%s@." id; Ok ()
let cmd = let family_prefix = Arg.( value & opt (some string) None & info [ "family-prefix" ] ~docv:"PREFIX") in let kind = Arg.( value & opt (enum [ ("bug", "bug"); ("task", "task") ]) "bug" & info [ "kind" ] ~docv:"KIND") in let priority = Arg.(value & opt int 2 & info [ "priority" ] ~docv:"N") in let priority_reason = Arg.( value & opt (some string) None & info [ "priority-reason" ] ~docv:"TEXT") in let labels = Arg.(value & opt_all string [] & info [ "label" ] ~docv:"FAMILY:VALUE") in let packages = Arg.(value & opt_all string [] & info [ "package" ] ~docv:"PACKAGE") in let checks = Arg.(value & opt_all string [] & info [ "check" ] ~docv:"CASE") in let body_file = Arg.(value & opt (some string) None & info [ "body-file" ] ~docv:"PATH") in let comment_file = Arg.(value & opt (some string) None & info [ "comment-file" ] ~docv:"PATH") in let comment_id = Arg.(value & opt (some string) None & info [ "comment-id" ] ~docv:"ID") in let comment_at = Arg.(value & opt (some string) None & info [ "comment-at" ] ~docv:"TIME") in Cmd.v (Cmd.info "finding" ~doc:"File or join one mq finding by external key.") Term.( const operator_finding $ root $ authority $ json $ (const finding $ external_ref $ family_prefix $ title $ kind $ priority $ priority_reason $ labels $ packages $ checks $ body_file $ comment_file $ comment_id $ comment_at))