Something went wrong. Try again.
My own corner of monopam
Something went wrong. Try again.
5.2 kB · 154 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155(* Copyright (c) 2026 Thomas Gazagnaire <thomas@gazagnaire.org>
Permission to use, copy, modify, and distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)
open Alcobar
module Mem = struct type t = { objects : (Git.Hash.t, Git.Value.t) Hashtbl.t; refs : (string, Git.Hash.t) Hashtbl.t; }
let v () = { objects = Hashtbl.create 256; refs = Hashtbl.create 1 }
let read t h = match Hashtbl.find_opt t.objects h with | Some v -> Ok v | None -> Error (`Msg ("no object " ^ Git.Hash.to_hex h))
let write t v = let h = Git.Value.digest v in Hashtbl.replace t.objects h v; h
let commit_graph _ = None let read_ref t name = Ok (Hashtbl.find_opt t.refs name)
let compare_and_swap_ref t name ~expected ~reflog:_ hash = if Option.equal Git.Hash.equal (Hashtbl.find_opt t.refs name) expected then begin Hashtbl.replace t.refs name hash; Ok () end else Error `Racedend
module Notes = Git.Notes.Make (Mem)
let ref = "refs/notes/fuzz"let who = Git.User.v ~name:"fuzz" ~email:"fuzz@nox" ~date:0L ()let ok = function Ok x -> x | Error (`Msg m) -> fail m
(* A store whose notes ref starts at a commit holding one entry that is not a note, [README]. *)let store readme = let s = Mem.v () in let blob = Mem.write s (Git.Value.Blob (Git.Blob.of_string readme)) in let tree = Mem.write s (Git.Value.Tree (Git.Tree.v [ Git.Tree.entry ~perm:`Normal ~name:"README" blob ])) in let commit = Mem.write s (Git.Value.Commit (Git.Commit.v ~tree ~author:who ~committer:who None)) in Hashtbl.replace s.refs ref commit; (s, blob)
let root s = match Mem.read s (Hashtbl.find s.refs ref) with | Ok (Git.Value.Commit c) -> Git.Commit.tree c | _ -> fail "the notes ref names no commit"
let append s key line = ignore (ok (Notes.append s ~author:who ~committer:who ~ref key line))
(* [run readme keys order extra] appends a first line to each of [keys], in [order], then a second line to the key each of [extra] names. *)let run readme keys order extra = let s, readme_blob = store readme in List.iter (fun i -> append s keys.(i) (Fmt.str "first %d" i)) order; List.iter (fun (i, l) -> append s keys.(i) (Fmt.str "extra %d" l)) extra; (s, readme_blob)
(* The notes [run] gives each key, as [(object, note blob)] in object order. *)let model keys extra = let m = Hashtbl.create (Array.length keys) in Array.iteri (fun i k -> Hashtbl.replace m k (Fmt.str "first %d\n" i)) keys; List.iter (fun (i, l) -> let k = keys.(i) in Hashtbl.replace m k (Hashtbl.find m k ^ Fmt.str "extra %d\n" l)) extra; m
let check_notes s model = let expected = Hashtbl.fold (fun k note acc -> ( Git.Hash.to_hex k, Git.Hash.to_hex (Git.Blob.digest (Git.Blob.of_string note)) ) :: acc) model [] |> List.sort compare in let listed = List.map (fun (o, n) -> (Git.Hash.to_hex o, Git.Hash.to_hex n)) (ok (Notes.list s ~ref)) in if listed <> expected then fail "list differs from the notes appended"; Hashtbl.iter (fun k note -> match ok (Notes.find s ~ref k) with | Some n when n = note -> () | _ -> failf "find %s differs" (Git.Hash.to_hex k)) model
let check_readme s readme_blob = match Mem.read s (root s) with | Ok (Git.Value.Tree t) -> ( match Git.Tree.find ~name:"README" t with | Some e when Git.Hash.equal e.hash readme_blob -> () | _ -> fail "README is gone from the root") | _ -> fail "the root is not a tree"
(* [count] objects get a first line each; then each of [extra] appends a second line to one of them. The notes read back are the model's, the entry that is not a note is still at the root, and the tree is the same whichever order the first lines came in. *)let test_round_trip seed count extra readme = let keys = Array.init count (Fmt.kstr (Git.Hash.digest_string ~kind:`Blob) "%s %d" seed) in let extra = if count = 0 then [] else List.map (fun (i, l) -> (i mod count, l mod 4)) extra in let forward = List.init count Fun.id in let s, readme_blob = run readme keys forward extra in check_notes s (model keys extra); check_readme s readme_blob; let r, _ = run readme keys (List.rev forward) extra in if not (Git.Hash.equal (root s) (root r)) then fail "the tree depends on the order of the appends"
let suite = ( "notes", [ test_case "round trip" [ bytes; range 160; list (pair uint8 uint8); bytes ] test_round_trip; ] )