Something went wrong. Try again.
Git-native issue tracker
Something went wrong. Try again.
7.1 kB · 189 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190module Store = Store_gitmodule Candidate = Schema_candidate
type view = { snapshot : Store.snapshot; schema : Core.Schema.t; text : string }
let ( let* ) = Result.bind
let inspect ~repo = let* snapshot = Store.current ~repo in let* tree = Store_tree.load ~repo ~commit:snapshot.commit in let schema = Store_tree.candidate tree |> Candidate.schema in let* text = Store_tree.schema_text ~repo ~tree:snapshot.tree in Ok { snapshot; schema; text }
let status_name = function | Core.Open -> "open" | Claimed -> "claimed" | Landed -> "landed" | Closed -> "closed"
let check_name = function | `Case -> "case" | `Count -> "count" | `Reading -> "reading"
let rec type_name : Core.Field.type_ -> string = function | Text -> "text" | Integer { min; max } -> let bound = Option.fold ~none:"" ~some:string_of_int in if min = None && max = None then "integer" else "integer " ^ bound min ^ ".." ^ bound max | Texts -> "texts" | Records decls -> "records of " ^ String.concat ", " (List.map (fun (d : Core.Field.decl) -> d.name ^ ": " ^ type_name d.type_) decls)
let table heading values = "## " ^ heading ^ "\n\n| Value |\n|---|\n" ^ String.concat "" (List.map (fun value -> "| `" ^ value ^ "` |\n") values) ^ "\n"
let doc view = let schema = view.schema in let families = Core.Schema.label_families schema |> List.map (fun (name, values) -> let values = match values with | None -> "any value" | Some values -> String.concat ", " values in "| `" ^ name ^ "` | " ^ values ^ " |\n") in let fields = Core.Schema.declared_fields schema |> List.map (fun (kind, (d : Core.Field.decl)) -> "| `" ^ kind ^ "` | `" ^ d.name ^ "` | " ^ type_name d.type_ ^ (if d.optional then ", optional" else "") ^ " |\n") in "# Tracker schema\n\n" ^ table "Kinds" (Core.Schema.kinds schema) ^ table "Statuses" (List.map status_name (Core.Schema.statuses schema)) ^ table "Checks" (List.map check_name (Core.Schema.check_kinds schema)) ^ "## Label families\n\n| Family | Values |\n|---|---|\n" ^ String.concat "" families ^ "\n" ^ "## Fields\n\n| Kind | Field | Type |\n|---|---|---|\n" ^ String.concat "" fields ^ "\n## Write rules\n\n" ^ match Core.Schema.rules schema with | None -> "This schema states no write rule.\n" | Some rules -> let module R = Core.Schema.Rules in let rule name value = "| `" ^ name ^ "` | " ^ value ^ " |\n" in let list values = String.concat ", " values in "| Rule | Value |\n|---|---|\n" ^ rule "title_limit" (string_of_int (R.title_limit rules)) ^ rule "heading_markers" (list (R.heading_markers rules)) ^ rule "leads_at_most" (string_of_int (R.leads_at_most rules)) ^ rule "queues" (list (R.queues rules)) ^ rule "requires" (list (List.map (fun (label, family) -> label ^ " needs " ^ family) (R.requires rules))) ^ rule "decided" (list (R.decided rules)) ^ rule "waits" (R.waits rules)
let row_path id = let digest = Cas.Hash.(to_hex (sha256 id)) in [ "rows"; String.sub digest 0 1; String.sub digest 1 1; String.sub digest 2 1; id; "row.json"; ]
(* The row.json of every row [after] changes, and their ids. *)let row_edits ~before ~after = let old_schema = Candidate.schema before in let new_schema = Candidate.schema after in let old_rows = Hashtbl.create (List.length (Candidate.rows before)) in List.iter (fun row -> Hashtbl.add old_rows (Core.Row.id row) row) (Candidate.rows before); let* edits = List.fold_left (fun result row -> let* acc = result in let id = Core.Row.id row in let old = Hashtbl.find old_rows id in let* old_text = Row_json.to_string ~schema:old_schema old in let* new_text = Row_json.to_string ~schema:new_schema row in if String.equal old_text new_text then Ok acc else Ok ((id, Store.Put (row_path id, new_text)) :: acc)) (Ok []) (Candidate.rows after) in Ok (List.map snd edits, List.sort String.compare (List.map fst edits))
let edits ~schema_text ~before ~after = let* rows, rewritten = row_edits ~before ~after in Ok (Store.Put ([ "schema.toml" ], schema_text) :: List.rev rows, rewritten)
let prepare ~repo ~(expected : Store.snapshot) ~schema_text ~row = let* schema = Schema_toml.of_string schema_text in let* local = Store.current ~repo in if not (Git.Hash.equal local.commit expected.commit) then Error "schema source is stale; inspect the current local store" else let* before = Store_tree.load ~repo ~commit:expected.commit in if not (Git.Hash.equal (Store_tree.tree_id before) expected.tree) then Error "schema source commit does not name the expected tree" else let original = Store_tree.candidate before in let refused = List.filter_map (fun old -> match Row_json.to_string ~schema (row old) with | Ok _ -> None | Error reason -> Some reason) (Candidate.rows original) in if refused <> [] then Error (String.concat "\n" refused) else let* replacement = Candidate.rewrite original ~schema ~row in let* edits, rewritten = edits ~schema_text ~before:original ~after:replacement in Ok ( (fun (now : Store.snapshot) -> if Git.Hash.equal now.commit expected.commit then Ok edits else Error "schema source is stale; inspect the current authority"), rewritten )
let change_local ~sw ~fs ~repo ~authority ~actor ~message ~expected ~schema_text ~row = let* change, rewritten = prepare ~repo ~expected ~schema_text ~row in let* authoritative = Store.current ~repo:authority in if not (Git.Hash.equal authoritative.commit expected.commit) then Error "schema source is stale; inspect the current authority" else let* after = Store.transact_authority_local ~repo ~authority ~actor ~message ~change in match Sqlite_index.init ~sw ~fs ~repo ~tree:after.tree with | Ok () -> Ok (after, rewritten) | Error reason -> Error ("schema published; local index rebuild failed: " ^ reason)
let change_remote ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~expected ~schema_text ~row = let* change, rewritten = prepare ~repo ~expected ~schema_text ~row in let* fetched = Store_remote.fetch ~sw ~fs ~net ~mono ~repo remote in if not (Git.Hash.equal (Store_remote.tip fetched) expected.commit) then Error "schema source is stale; inspect the current authority" else let* after = Store.transact_authority ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~change in match Sqlite_index.init ~sw ~fs ~repo ~tree:after.tree with | Ok () -> Ok (after, rewritten) | Error reason -> Error ("schema published; local index rebuild failed: " ^ reason)