Something went wrong. Try again.
Git-native issue tracker
Something went wrong. Try again.
8.0 kB · 224 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225(* docs/design/2026-09-24-tracker.md, section 5.9 and acceptance case 11: tk schema change validates every existing row against the proposed schema and publishes it only if all rows remain valid, in one Git transaction. *)module Repo = Git_eio.Repositorymodule Store = Tracker.Store_gitmodule Command = Tracker.Schema_command
let author = Git.User.v ~name:"Test" ~email:"test@example.com" ~date:0L ()let ok = function Ok x -> x | Error e -> Alcotest.fail e
let schema kinds = Fmt.str {|kinds = [%s]statuses = ["open"]check_kinds = ["case"]
[[label_families]]name = "journey"values = ["*"]|} (String.concat ", " (List.map (Fmt.str "%S") kinds))
let row = {|{"kind":"task","title":"A task","status":"open","priority":2,"triage":"ready","filed":"2026-09-24T08:55:10Z","labels":[],"packages":[],"claim":null,"edges":[],"checks":[],"anchors":[]}|}
(* One tree: schema.toml, tracker.toml and the task row test-a under its shard (section 5.2). *)let seed repo = let entry perm name hash = Git.Tree.entry ~perm ~name hash in let rec nest path leaf = match path with | [] -> assert false | [ name ] -> entry `Normal name (Repo.write_blob repo leaf) | name :: rest -> entry `Dir name (Repo.write_tree repo (Git.Tree.v [ nest rest leaf ])) in let tree = Repo.write_tree repo (Git.Tree.v [ entry `Normal "schema.toml" (Repo.write_blob repo (schema [ "task" ])); entry `Normal "tracker.toml" (Repo.write_blob repo "organisation = \"test\"\nprefix = \"test\"\n"); nest (Store.row_path "test-a") row; ]) in let commit = Repo.write_commit repo (Git.Commit.v ~tree ~author ~committer:author (Some "init")) in Repo.write_ref repo "refs/heads/main" commit
(* A clone and its authority, both at the same seeded commit. *)let with_store f = Eio_main.run @@ fun env -> let fs = Eio.Stdenv.fs env in let dir = Filename.temp_dir ~temp_dir:"." "tracker-schema-" "" in Fun.protect ~finally:(fun () -> Eio.Path.rmtree ~missing_ok:true Eio.Path.(fs / dir)) (fun () -> Eio.Switch.run @@ fun sw -> let init name = Repo.init ~sw ~fs (Fpath.v (Filename.concat dir name)) in let repo = init "clone" and authority = Tracker_fixture.bare (init "authority") in seed repo; seed authority; f ~sw ~fs ~repo ~authority)
let change ~sw ~fs ~repo ~authority ~expected kinds = Command.change_local ~sw ~fs ~repo ~authority ~actor:author ~message:"tk schema change" ~expected ~schema_text:(schema kinds) ~row:Fun.id |> Result.map fst
let tip repo = (ok (Store.current ~repo)).commit
let a_rejected_row_commits_nothing () = with_store @@ fun ~sw ~fs ~repo ~authority -> let before = ok (Store.current ~repo) in (match change ~sw ~fs ~repo ~authority ~expected:before [ "bug" ] with | Ok _ -> Alcotest.fail "a schema without the row's kind was published" | Error e -> Alcotest.(check string) "reason" "row test-a: kind task is not admitted" e); Alcotest.(check bool) "clone unchanged" true (Git.Hash.equal before.commit (tip repo)); Alcotest.(check bool) "authority unchanged" true (Git.Hash.equal before.commit (tip authority))
let a_valid_schema_is_published () = with_store @@ fun ~sw ~fs ~repo ~authority -> let before = ok (Store.current ~repo) in let after = ok (change ~sw ~fs ~repo ~authority ~expected:before [ "task"; "bug" ]) in Alcotest.(check bool) "authority took it" true (Git.Hash.equal after.commit (tip authority)); let view = ok (Command.inspect ~repo) in Alcotest.(check bool) "inspect reads the new commit" true (Git.Hash.equal view.snapshot.commit after.commit); Alcotest.(check bool) "both kinds" true (List.length (Tracker.Core.Schema.kinds view.schema) = 2)
let a_stale_view_is_refused () = with_store @@ fun ~sw ~fs ~repo ~authority -> let before = ok (Store.current ~repo) in let _ = ok (change ~sw ~fs ~repo ~authority ~expected:before [ "task"; "bug" ]) in match change ~sw ~fs ~repo ~authority ~expected:before [ "task"; "chore" ] with | Ok _ -> Alcotest.fail "a change from a stale view was published" | Error e -> Alcotest.(check string) "reason" "schema source is stale; inspect the current local store" e
(* A clone commit the authority has not taken is not the schema change's to publish: the change refuses and the authority keeps its tip. *)let unpublished_local_history_stays_local () = with_store @@ fun ~sw ~fs ~repo ~authority -> let published = tip authority in let local = ok (Store.transact ~repo ~actor:author ~message:"unpublished config" ~change:(fun _ -> Ok [ Store.Put ( [ "tracker.toml" ], "organisation = \"test\"\nprefix = \"test\"\n# local\n" ); ])) in (match change ~sw ~fs ~repo ~authority ~expected:local [ "task"; "bug" ] with | Ok _ -> Alcotest.fail "a schema change published unrelated local history" | Error _ -> ()); Alcotest.(check bool) "authority unchanged" true (Git.Hash.equal published (tip authority))
(* The schema and every rewritten row are one commit on the old tip, and the clone's typed projection is rebuilt from it. *)let schema_and_rows_are_one_commit () = with_store @@ fun ~sw ~fs ~repo ~authority -> let before = ok (Store.current ~repo) in let after, rewritten = ok (Command.change_local ~sw ~fs ~repo ~authority ~actor:author ~message:"tk schema change" ~expected:before ~schema_text:(schema [ "feature" ]) ~row:(Tracker.Core.Row.with_kind "feature")) in Alcotest.(check (list string)) "the rewritten row" [ "test-a" ] rewritten; let stored = ok (Tracker.Store_tree.load ~repo:authority ~commit:after.commit) in let rows = Tracker.Schema_candidate.rows (Tracker.Store_tree.candidate stored) in Alcotest.(check int) "one row" 1 (List.length rows); Alcotest.(check bool) "rewritten row kind" true (Tracker.Core.Row.kind (List.hd rows) = "feature"); (match Repo.read authority after.commit with | Ok (Git.Value.Commit value) -> Alcotest.(check bool) "one parent, the old tip" true (List.equal Git.Hash.equal [ before.commit ] (Git.Commit.parents value)) | _ -> Alcotest.fail "the schema change wrote no commit"); let index = Filename.concat (Fpath.to_string (Repo.git_dir repo)) "tk/index.sqlite" in Alcotest.(check bool) "projection rebuilt" true (Sys.file_exists index)
let doc_prints_the_tables () = with_store @@ fun ~sw:_ ~fs:_ ~repo ~authority:_ -> let view = ok (Command.inspect ~repo) in Alcotest.(check string) "doc" "# Tracker schema\n\n\ ## Kinds\n\n\ | Value |\n\ |---|\n\ | `task` |\n\n\ ## Statuses\n\n\ | Value |\n\ |---|\n\ | `open` |\n\n\ ## Checks\n\n\ | Value |\n\ |---|\n\ | `case` |\n\n\ ## Label families\n\n\ | Family | Values |\n\ |---|---|\n\ | `journey` | any value |\n\n\ ## Fields\n\n\ | Kind | Field | Type |\n\ |---|---|---|\n\n\ ## Write rules\n\n\ This schema states no write rule.\n" (Command.doc view)
let suite = ( "schema_command", [ Alcotest.test_case "a rejected row commits nothing" `Quick a_rejected_row_commits_nothing; Alcotest.test_case "a valid schema is published" `Quick a_valid_schema_is_published; Alcotest.test_case "a stale view is refused" `Quick a_stale_view_is_refused; Alcotest.test_case "unpublished local history stays local" `Quick unpublished_local_history_stays_local; Alcotest.test_case "schema and rows are one commit" `Quick schema_and_rows_are_one_commit; Alcotest.test_case "doc prints the tables" `Quick doc_prints_the_tables; ] )