Something went wrong. Try again.
Git-native issue tracker
Something went wrong. Try again.
24 kB · 676 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677module Repo = Git_eio.Repository
type snapshot = { commit : Git.Hash.t; tree : Git.Hash.t }type edit = Put of string list * string | Delete of string list
let ( let* ) = Result.bind
let resolve_root ~root = let given = Fpath.(root / ".tracker") in let err_link fmt = Fmt.kstr (fun s -> Error s) ("%a: " ^^ fmt) Fpath.pp given in try let link = Filename.concat (Unix.realpath (Fpath.to_string root)) ".tracker" in if (Unix.lstat link).st_kind <> Unix.S_LNK then err_link "expected a store symlink" else let store = Unix.realpath link in if (Unix.stat store).st_kind <> Unix.S_DIR then err_link "target is not a directory" else Ok (Fpath.v store) with Unix.Unix_error (err, fn, _) -> err_link "%s (%s)" (Unix.error_message err) fn
let err_store store pp error = Fmt.kstr (fun s -> Error s) "%s: %a" (Fpath.to_string store) pp error
let open_store ~sw ~fs store = match Repo.open_local ~sw ~fs store with | Ok repo -> Ok repo | Error (`Discover (Git.Discover.Not_a_repository _)) -> Error (Fpath.to_string store ^ ": not a Git repository") | Error (`Discover error) -> err_store store Git.Discover.pp_error error | Error (`Config error) -> err_store store Git.Config_layers.pp_error error
let object_at repo hash = match Repo.read repo hash with | Ok value -> Ok value | Error (`Msg message) -> Error message
let commit_at repo hash = let* value = object_at repo hash in match value with | Git.Value.Commit commit -> Ok commit | _ -> Error "main does not name a Git commit"
let tree_at repo hash = let* value = object_at repo hash in match value with | Git.Value.Tree tree -> Ok tree | _ -> Error "store path does not name a Git tree"
let current ~repo = match Repo.read_ref repo "refs/heads/main" with | None -> Error "tracker authority has no refs/heads/main" | Some hash -> let* commit = commit_at repo hash in Ok { commit = hash; tree = Git.Commit.tree commit }
let safe_component value = value <> "" && value <> "." && value <> ".." && (not (String.contains value '/')) && not (String.contains value '\000')
let shard id = let digest = Cas.Hash.(to_hex (sha256 id)) in [ String.sub digest 0 1; String.sub digest 1 1; String.sub digest 2 1 ]
let row_path id = [ "rows" ] @ shard id @ [ id; "row.json" ]
let exploration_path ~id ~artifact = [ "rows" ] @ shard id @ [ id; "exploration"; artifact ^ ".md" ]
let canonical = function | [ "schema.toml" ] | [ "tracker.toml" ] -> true | "rows" :: a :: b :: c :: id :: rest -> ( [ a; b; c ] = shard id && match rest with | [ "row.json" ] | [ "body.md" ] -> true | [ "comments"; name ] -> Filename.check_suffix name ".md" | [ "exploration"; name ] -> Filename.check_suffix name ".md" | _ -> false) | _ -> false
let valid_path path = List.for_all safe_component path && canonical path
let rec validate_tree ~repo ~prefix hash = let* tree = tree_at repo hash in List.fold_left (fun result (entry : Git.Tree.entry) -> let* () = result in let path = prefix @ [ entry.name ] in if not (safe_component entry.name) then Error ("unsafe tracker path: " ^ String.concat "/" path) else match entry.perm with | `Dir -> validate_tree ~repo ~prefix:path entry.hash | `Normal when valid_path path -> Ok () | _ -> Error ("non-canonical tracker path: " ^ String.concat "/" path)) (Ok ()) (Git.Tree.to_list tree)
let validate_new_history ~repo ~stop start = let seen = Hashtbl.create 32 in let rec walk hash = if Git.Hash.equal hash stop || Hashtbl.mem seen hash then Ok () else ( Hashtbl.add seen hash (); let* commit = commit_at repo hash in let* () = validate_tree ~repo ~prefix:[] (Git.Commit.tree commit) in List.fold_left (fun result parent -> let* () = result in walk parent) (Ok ()) (Git.Commit.parents commit)) in walk start
let rec update repo tree path value = match path with | [] -> Error "empty store path" | [ name ] -> let tree = match value with | Some text -> let hash = Repo.write_blob repo text in Git.Tree.add (Git.Tree.entry ~perm:`Normal ~name hash) tree | None -> Git.Tree.remove ~name tree in Ok tree | name :: rest -> let* child = match Git.Tree.find ~name tree with | None -> Ok Git.Tree.empty | Some entry when entry.perm = `Dir -> tree_at repo entry.hash | Some _ -> Error (name ^ ": expected a directory") in let* child = update repo child rest value in let tree = if Git.Tree.is_empty child then Git.Tree.remove ~name tree else let hash = Repo.write_tree repo child in Git.Tree.add (Git.Tree.entry ~perm:`Dir ~name hash) tree in Ok tree
let apply repo root edits = List.fold_left (fun result edit -> let* tree = result in let path, value = match edit with | Put (path, text) -> (path, Some text) | Delete path -> (path, None) in if not (valid_path path) then Error ("non-canonical tracker path: " ^ String.concat "/" path) else update repo tree path value) (Ok root) edits
type bulk_node = { files : (string, string) Hashtbl.t; dirs : (string, bulk_node) Hashtbl.t;}
let bulk_node () = { files = Hashtbl.create 4; dirs = Hashtbl.create 4 }
let rec bulk_insert node path value = match path with | [] -> Error "bootstrap: empty store path" | [ name ] -> if Hashtbl.mem node.dirs name || Hashtbl.mem node.files name then Error ("bootstrap: duplicate path " ^ String.concat "/" path) else ( Hashtbl.add node.files name value; Ok ()) | name :: rest -> if Hashtbl.mem node.files name then Error ("bootstrap: file is also a directory: " ^ name) else let child = match Hashtbl.find_opt node.dirs name with | Some child -> child | None -> let child = bulk_node () in Hashtbl.add node.dirs name child; child in bulk_insert child rest value
let rec bulk_write repo node = let entries = Hashtbl.fold (fun name value entries -> let hash = Repo.write_blob repo value in Git.Tree.entry ~perm:`Normal ~name hash :: entries) node.files [] in let entries = Hashtbl.fold (fun name child entries -> let hash = bulk_write repo child in Git.Tree.entry ~perm:`Dir ~name hash :: entries) node.dirs entries in Repo.write_tree repo (Git.Tree.of_list entries)
let bulk_tree repo files = let root = bulk_node () in let* () = List.fold_left (fun result (path, value) -> let* () = result in if not (valid_path path) then Error ("non-canonical tracker path: " ^ String.concat "/" path) else bulk_insert root path value) (Ok ()) files in Ok (bulk_write repo root)
(* The rows whose row.json [edits] write. *)let written_rows edits = List.filter_map (function | Put ([ "rows"; _; _; _; id; "row.json" ], _) -> Some id | _ -> None) edits |> List.sort_uniq String.compare
(* Every write rule of [tree]'s schema that a row written by [edits] breaks and its row in [before] did not, judged under that one schema. *)let admit_rows ~repo ~before ~tree edits = match written_rows edits with | [] -> Ok () | ids -> ( let* schema = Store_tree.schema ~repo ~tree in match Core.Schema.rules schema with | None -> Ok () | Some _ -> let* old_schema = Store_tree.schema ~repo ~tree:before.tree in let* refusals = List.fold_left (fun result id -> let* refusals = result in let* after = Store_tree.read_row ~repo ~tree ~schema ~id in let* previous = Store_tree.read_row ~repo ~tree:before.tree ~schema:old_schema ~id in match after with | None -> Ok refusals | Some row -> ( match Core.Schema.admit schema ~before:previous row with | Ok () -> Ok refusals | Error lines -> Ok (List.rev_append lines refusals))) (Ok []) ids in if refusals = [] then Ok () else Error (String.concat "\n" (List.rev refusals)))
type failure = Refused of string | Failed of string
let failure_message = function Refused message | Failed message -> messagelet refused r = Result.map_error (fun message -> Refused message) rlet failed r = Result.map_error (fun message -> Failed message) rlet contention = "authority main changed in 32 consecutive attempts"
(* The commit [change] makes on [before], refused when the change, the tree it leaves or the rows it writes break a rule of the store. *)let prepare_checked ~repo ~actor ~message ~change before = let* edits = refused (change before) in if edits = [] then Error (Refused "tracker operation changes no canonical file") else let* old_tree = failed (tree_at repo before.tree) in let* new_tree = refused (apply repo old_tree edits) in let tree = Repo.write_tree repo new_tree in let* () = refused (validate_tree ~repo ~prefix:[] tree) in let* () = refused (admit_rows ~repo ~before ~tree edits) in if Git.Hash.equal tree before.tree then Error (Refused "tracker operation leaves the source tree unchanged") else let commit = Git.Commit.v ~tree ~author:actor ~committer:actor ~parents:[ before.commit ] (Some message) in let hash = Repo.write_commit repo commit in let* _ = refused (Store_tree.load ~repo ~commit:hash) in Ok { commit = hash; tree }
let rec transact_attempt ~repo ~actor ~message ~change remaining = if remaining = 0 then Error (Refused contention) else let* before = failed (current ~repo) in let* prepared = prepare_checked ~repo ~actor ~message ~change before in match Repo.compare_and_swap_ref repo "refs/heads/main" ~expected:(Some before.commit) prepared.commit with | Ok () -> Ok prepared | Error (`Raced | `Locked _) -> transact_attempt ~repo ~actor ~message ~change (remaining - 1) | Error (`Hook_rejected reason) -> Error (Failed ("ref hook refused: " ^ reason))
let transact_checked ~repo ~actor ~message ~change = transact_attempt ~repo ~actor ~message ~change 32
let transact ~repo ~actor ~message ~change = transact_checked ~repo ~actor ~message ~change |> Result.map_error failure_message
let blob_at repo hash = let* value = object_at repo hash in match value with | Git.Value.Blob blob -> Ok (Git.Blob.to_string blob) | _ -> Error "merge input is not a Git blob"
let row_conflict_parts conflict = let parts = String.split_on_char '/' conflict.Git_eio.Merge.path in match parts with | [ "rows"; _; _; _; id; "row.json" ] -> Ok (parts, id) | _ -> Error (Refused ("sync conflict: " ^ conflict.path))
let required_conflict_hash ~path ~reason = function | Some { Git_eio.Merge.hash; _ } -> Ok hash | None -> Error (Refused ("sync " ^ reason ^ " conflict: " ^ path))
let merge_typed_row ~repo ~schema ~id conflict = let* base_hash = required_conflict_hash ~path:conflict.Git_eio.Merge.path ~reason:"add/add" conflict.base in let* ours_hash = required_conflict_hash ~path:conflict.path ~reason:"delete/modify" conflict.ours in let* theirs_hash = required_conflict_hash ~path:conflict.path ~reason:"modify/delete" conflict.theirs in let decode hash = let* text = failed (blob_at repo hash) in failed (Row_json.of_string ~schema ~id text) in let* base = decode base_hash in let* ours = decode ours_hash in let* theirs = decode theirs_hash in let* row = match Store_model.merge_row ~ancestor:base ours theirs with | Ok row -> Ok row | Error (Store_model.Scalar_conflict field) -> Error (Refused ("sync scalar conflict: " ^ conflict.path ^ ": " ^ field)) | Error (Store_model.Authority_only field) -> Error (Refused ("sync authority-only field: " ^ conflict.path ^ ": " ^ field)) in failed (Row_json.to_string ~schema row)
let merge_row ~repo ~schema conflict = let* parts, id = row_conflict_parts conflict in let* text = merge_typed_row ~repo ~schema ~id conflict in Ok (parts, text)
let merge_tree ~repo ~schema ~base_tree local remote = let* merge = match Git_eio.Merge.tree repo ~base:(Some base_tree) ~ours:local.tree ~theirs:remote.tree () with | Ok result -> Ok result | Error (`Msg message) -> Error (Failed message) in match merge with | Git_eio.Merge.Clean hash -> Ok hash | Git_eio.Merge.Conflicts (hash, conflicts) -> let* start = failed (tree_at repo hash) in let* resolved = List.fold_left (fun result conflict -> let* tree = result in let* path, text = merge_row ~repo ~schema conflict in failed (update repo tree path (Some text))) (Ok start) conflicts in Ok (Repo.write_tree repo resolved)
let merge_tips ~repo ~base local remote = let* base_commit = failed (commit_at repo base) in let* remote_state = failed (Store_tree.load ~repo ~commit:remote.commit) in let schema = Store_tree.candidate remote_state |> Schema_candidate.schema in let* tree = merge_tree ~repo ~schema ~base_tree:(Git.Commit.tree base_commit) local remote in let* local_commit = failed (commit_at repo local.commit) in let actor = Git.Commit.author local_commit in let commit = Git.Commit.v ~tree ~author:actor ~committer:actor ~parents:[ local.commit; remote.commit ] (Some "tk sync") in let hash = Repo.write_commit repo commit in let* _ = failed (Store_tree.load ~repo ~commit:hash) in Ok { commit = hash; tree }
let choose_candidate ~repo local remote = let common = Repo.merge_base repo local.commit remote.commit in match Store_model.choose ~local:local.commit ~remote:remote.commit ~common with | Store_model.Current | Store_model.Remote -> Ok remote | Store_model.Local -> Ok local | Store_model.Merge base -> merge_tips ~repo ~base local remote | Store_model.Unrelated -> Error (Failed "sync tips have no common ancestor")
let move_local ~repo local candidate = if Git.Hash.equal candidate.commit local.commit then Ok () else match Repo.compare_and_swap_ref repo "refs/heads/main" ~expected:(Some local.commit) candidate.commit with | Ok () -> Ok () | Error (`Raced | `Locked _) -> Error (Failed "local tracker ref changed during sync") | Error (`Hook_rejected reason) -> Error (Failed ("ref hook refused: " ^ reason))
let push_local ~repo ~authority ~expected candidate = match Git_eio.Push.local_updates ~src:repo ~dst:authority [ { Git_eio.Push.dst_ref = "refs/heads/main"; value = Some candidate.commit; expect = Lease (Some expected); }; ] with | Ok _ -> Ok () | Error (`Stale _ | `Non_fast_forward _) -> Error `Raced | Error (`Msg message) -> Error (`Msg ("authority push: " ^ message))
let fetch_authority ~repo ~authority = let* fetched = match Git_eio.Fetch.local ~src:authority ~dst:repo ~ref_name:"refs/heads/main" with | Ok hash -> Ok hash | Error (`Msg message) -> Error ("authority fetch: " ^ message) in let* remote_commit = commit_at repo fetched in Ok { commit = fetched; tree = Git.Commit.tree remote_commit }
let sync_once ~repo ~authority = let* remote = failed (fetch_authority ~repo ~authority) in let* local = failed (current ~repo) in let* candidate = choose_candidate ~repo local remote in let actions = Store_model.publication ~local:local.commit ~remote:remote.commit ~candidate:candidate.commit in let* () = failed (validate_new_history ~repo ~stop:remote.commit candidate.commit) in let* () = if actions.move_local then move_local ~repo local candidate else Ok () in if actions.push_authority then Ok (Result.map (fun () -> candidate) (push_local ~repo ~authority ~expected:remote.commit candidate)) else Ok (Ok candidate)
let rec sync_attempt ~repo ~authority remaining = if remaining = 0 then Error (Refused contention) else match sync_once ~repo ~authority with | Error failure -> Error failure | Ok (Ok candidate) -> Ok candidate | Ok (Error `Raced) -> sync_attempt ~repo ~authority (remaining - 1) | Ok (Error (`Msg message)) -> Error (Failed message)
let sync_local_checked ~repo ~authority = sync_attempt ~repo ~authority 32
let sync_local ~repo ~authority = sync_local_checked ~repo ~authority |> Result.map_error failure_message
let snapshot_of_fetched ~repo fetched = let commit = Store_remote.tip fetched in let* value = commit_at repo commit in let tree = Git.Commit.tree value in let* () = validate_tree ~repo ~prefix:[] tree in let* _ = Store_tree.load ~repo ~commit in Ok { commit; tree }
let sync_remote_once ~sw ~fs ~net ~mono ~repo ~remote = let* fetched = failed (Store_remote.fetch ~sw ~fs ~net ~mono ~repo remote) in let* authority = failed (snapshot_of_fetched ~repo fetched) in let* local = failed (current ~repo) in if Git.Hash.equal local.commit authority.commit then Ok (Ok local) else let* candidate = choose_candidate ~repo local authority in let* () = failed (validate_new_history ~repo ~stop:authority.commit candidate.commit) in let* () = move_local ~repo local candidate in if Git.Hash.equal candidate.commit authority.commit then Ok (Ok candidate) else match Store_remote.push ~sw ~fs ~net ~mono ~repo ~fetched ~commit:candidate.commit with | Ok _ -> Ok (Ok candidate) | Error (`Stale | `Non_fast_forward) -> Ok (Error `Raced) | Error (`Msg message) -> Error (Failed ("authority push: " ^ message))
let rec sync_remote_attempt ~sw ~fs ~net ~mono ~repo ~remote remaining = if remaining = 0 then Error (Refused contention) else match sync_remote_once ~sw ~fs ~net ~mono ~repo ~remote with | Error failure -> Error failure | Ok (Ok candidate) -> Ok candidate | Ok (Error `Raced) -> sync_remote_attempt ~sw ~fs ~net ~mono ~repo ~remote (remaining - 1)
let sync_remote_checked ~sw ~fs ~net ~mono ~repo ~remote = sync_remote_attempt ~sw ~fs ~net ~mono ~repo ~remote 32
let sync_remote ~sw ~fs ~net ~mono ~repo ~remote = sync_remote_checked ~sw ~fs ~net ~mono ~repo ~remote |> Result.map_error failure_message
let rollback_remote_attempt ~repo ~before prepared = match Repo.compare_and_swap_ref repo "refs/heads/main" ~expected:(Some prepared.commit) before.commit with | Ok () -> Ok () | Error _ -> Error "local tracker ref changed while remote push failed"
let publish_remote_attempt ~sw ~fs ~net ~mono ~repo ~before ~fetched prepared = match Repo.compare_and_swap_ref repo "refs/heads/main" ~expected:(Some before.commit) prepared.commit with | Error (`Raced | `Locked _) -> Ok `Retry | Error (`Hook_rejected reason) -> Error ("ref hook refused: " ^ reason) | Ok () -> ( match Store_remote.push ~sw ~fs ~net ~mono ~repo ~fetched ~commit:prepared.commit with | Ok _ -> Ok (`Published prepared) | Error push_error -> ( let* () = rollback_remote_attempt ~repo ~before prepared in match push_error with | `Stale | `Non_fast_forward -> Ok `Retry | `Msg reason -> Error ("authority push: " ^ reason)))
let rec authority_remote_attempt ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~change remaining = if remaining = 0 then Error (Refused contention) else let retry () = authority_remote_attempt ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~change (remaining - 1) in let* before = sync_remote_checked ~sw ~fs ~net ~mono ~repo ~remote in let* fetched = failed (Store_remote.fetch ~sw ~fs ~net ~mono ~repo remote) in let* result = if not (Git.Hash.equal (Store_remote.tip fetched) before.commit) then Ok `Retry else let* prepared = prepare_checked ~repo ~actor ~message ~change before in failed (publish_remote_attempt ~sw ~fs ~net ~mono ~repo ~before ~fetched prepared) in match result with `Published prepared -> Ok prepared | `Retry -> retry ()
let transact_authority_checked ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~change = authority_remote_attempt ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~change 32
let transact_authority ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~change = transact_authority_checked ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~change |> Result.map_error failure_message
let rec authority_attempt ~repo ~authority ~actor ~message ~change remaining = if remaining = 0 then Error (Refused contention) else let* before = sync_local_checked ~repo ~authority in let* provisional = transact_checked ~repo ~actor ~message ~change in match push_local ~repo ~authority ~expected:before.commit provisional with | Ok _ -> Ok provisional | Error error -> ( let* () = match Repo.compare_and_swap_ref repo "refs/heads/main" ~expected:(Some provisional.commit) before.commit with | Ok () -> Ok () | Error _ -> Error (Failed "local tracker ref changed while remote push failed") in match error with | `Raced -> authority_attempt ~repo ~authority ~actor ~message ~change (remaining - 1) | `Msg reason -> Error (Failed reason))
let transact_authority_local_checked ~repo ~authority ~actor ~message ~change = authority_attempt ~repo ~authority ~actor ~message ~change 32
let transact_authority_local ~repo ~authority ~actor ~message ~change = transact_authority_local_checked ~repo ~authority ~actor ~message ~change |> Result.map_error failure_message
let prepare_bootstrap ~repo ~actor ~message ~parent files = let* tree = bulk_tree repo files in let* () = validate_tree ~repo ~prefix:[] tree in let* config = Config.of_tree ~repo ~tree in let* _ = Config.remote config in let commit = Git.Commit.v ~tree ~author:actor ~committer:actor ~parents:[ parent ] (Some message) |> Repo.write_commit repo in let* snapshot = Store_tree.load ~repo ~commit in let* () = Store_tree.validate_content ~repo snapshot in Ok { commit; tree }
let preview_bootstrap ~repo ~actor ~message ~expected ~files = if files = [] then Error "bootstrap: replacement tree is empty" else let* before = current ~repo in if not (Git.Hash.equal before.commit expected) then Error "bootstrap: local main differs from expected authority" else prepare_bootstrap ~repo ~actor ~message ~parent:expected files
let bootstrap_authority ~sw ~fs ~net ~mono ~repo ~remote ~actor ~message ~expected ~files = if files = [] then Error "bootstrap: replacement tree is empty" else let* fetched = Store_remote.fetch ~sw ~fs ~net ~mono ~repo remote in if not (Git.Hash.equal (Store_remote.tip fetched) expected) then Error "bootstrap: authority main changed before conversion" else let* before = current ~repo in if not (Git.Hash.equal before.commit expected) then Error "bootstrap: local main differs from expected authority" else let* prepared = preview_bootstrap ~repo ~actor ~message ~expected ~files in let* published = publish_remote_attempt ~sw ~fs ~net ~mono ~repo ~before ~fetched prepared in match published with | `Published value -> Ok value | `Retry -> Error "bootstrap: authority main changed during push"